resurrect builtins: WIP

build-aux/build-guile.sh

@@ -37,6 +37,7 @@ set -e
 
 SCM_FILES="
 gash/bournish-commands.scm
+gash/builtins.scm
 gash/guix-build-utils.scm
 gash/gash.scm
 gash/io.scm

gash/builtins.scm

@@ -0,0 +1,116 @@
+(define-module (gash builtins)
+  #:use-module (ice-9 match)
+
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+
+  #:use-module (gash bournish-commands)
+  #:use-module (gash gash)
+  #:use-module (gash job)
+  #:use-module (gash peg)
+
+  #:export (
+            %builtin-commands
+            PATH-search-path
+    ;;         cd-command
+    ;; ("bg"     . ,bg-command)
+    ;; ("cat"    . ,cat-command)
+    ;; ("cd"     . ,cd-command)
+    ;; ("cp"     . ,cp-command)
+    ;; ("echo"   . ,echo-command)
+    ;; ("exit"   . ,exit-command)
+    ;; ("fg"     . ,fg-command)
+    ;; ("help"   . ,help-command)
+    ;; ("jobs"   . ,jobs-command)
+    ;; ("ls"     . ,ls-command)
+    ;; ("pwd"    . ,pwd-command)
+    ;; ("reboot" . ,reboot-command)
+    ;; ("rm"     . ,rm-command)
+    ;; ("set"    . ,set-command)
+    ;; ("wc"     . ,wc-command)
+    ;; ("which"  . ,which-command)
+
+))
+ 
+(define (PATH-search-path program)
+  (search-path (string-split (getenv "PATH") #\:) program))
+
+(define (cd-command . args)
+  (match args
+    (() (chdir (getenv "HOME")))
+    ((dir)
+     (chdir dir))
+    ((args ...)
+     (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args)))))
+
+(define (echo-command . args)
+  (match args
+    (() (newline))
+    (("-n" args ...) (map display args))
+    (_ (map display args) (newline))))
+
+(define (bg-command . args)
+  (match args
+    (() (bg 1))
+    ((job x ...) (bg (string->number (car job))))))
+
+(define (fg-command . args)
+  (match args
+    (() (fg 1))
+    ((job x ...) (fg (string->number (car job))))))
+
+(define pwd-command (lambda _ (stdout (getcwd))))
+
+(define (set-command . args) ;; TODO export; env vs set
+  (define (display-var o)
+    (format #t "~a=~a\n" (car o) (cdr o)))
+  (match args
+    (() (for-each display-var global-variables))
+    (("-e") (set-shell-opt! "errexit" #t))
+    (("+e") (set-shell-opt! "errexit" #f))
+    (("-x") (set-shell-opt! "xtrace" #t))
+    (("+x") (set-shell-opt! "xtrace" #f))))
+
+(define (exit-command . args)
+  (match args
+    (() (exit 0))
+    ((status)
+     (exit (string->number status)))
+    ((args ...)
+     (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args)))))
+
+(define (help-command . _)
+  (display "\
+Hello, this is gash, Guile As SHell.
+
+Gash is work in progress; many language constructs work, globbing
+mostly works, pipes work, some redirections work.
+")
+  (when (or %prefer-builtins? (not (PATH-search-path "ls")))
+    (display "\nIt features the following, somewhat naive builtin commands\n")
+    (display-tabulated (map car %commands))))
+
+(define (cp-command-implementation source dest . rest)
+  (copy-file source dest))
+
+(define cp-command (wrap-command cp-command-implementation "cp"))
+
+(define %builtin-commands
+  `(
+    ("bg"     . ,bg-command)
+    ("cat"    . ,cat-command)
+    ("cd"     . ,cd-command)
+    ("cp"     . ,cp-command)
+    ;;("echo"   . ,echo-command) BROKEN wrt variables for now
+    ("exit"   . ,exit-command)
+    ("fg"     . ,fg-command)
+    ("help"   . ,help-command)
+    ("jobs"   . ,jobs-command)
+    ("ls"     . ,ls-command)
+    ("pwd"    . ,pwd-command)
+    ("reboot" . ,reboot-command)
+    ("rm"     . ,rm-command)
+    ("set"    . ,set-command)
+    ("wc"     . ,wc-command)
+    ("which"  . ,which-command)
+    ))

gash/gash.scm

@@ -19,13 +19,14 @@
   #:use-module (gash peg)
   #:use-module (gash io)
   #:use-module (gash util)
-  #:use-module (gash bournish-commands)
 
   #:export (main
             %debug-level
+            %prefer-builtins?
             shell-opt?))
 
-(define %debug-level 0)
+(define %debug-level 0)       ; 1 informational, 2 verbose, 3 peg tracing
+(define %prefer-builtins? #f) ; use builtin, even if COMMAND is available in PATH?
 
 (define (remove-shell-comments s)
   (string-join (map
@@ -177,132 +178,14 @@ copyleft.
                             (loop (cdr patterns) (glob- (car patterns) paths))))))
    (#t (list pattern))))
 
-(define (background ast)
+(define (DEAD-background ast)
   (match ast
     (('pipeline fg rest ...) `(pipeline #f ,@rest))
     (_ ast)))
 
-(define (PATH-search-path program)
-  (search-path (string-split (getenv "PATH") #\:) program))
-
-(define (cd-command . args)
-  (match args
-    (() (chdir (getenv "HOME")))
-    ((dir)
-     (chdir dir))
-    ((args ...)
-     (format (current-error-port) "cd: too many arguments: ~a\n" (string-join args)))))
-
-(define (echo-command . args)
-  (match args
-    (() (newline))
-    (("-n" args ...) (map display args))
-    (_ (map display args) (newline))))
-
-(define (bg-command . args)
-  (match args
-    (() (bg 1))
-    ((job x ...) (bg (string->number (car job))))))
-
-(define (fg-command . args)
-  (match args
-    (() (fg 1))
-    ((job x ...) (fg (string->number (car job))))))
-
-(define pwd-command (lambda _ (stdout (getcwd))))
-
-(define (set-command . args) ;; TODO export; env vs set
-  (define (display-var o)
-    (format #t "~a=~a\n" (car o) (cdr o)))
-  (match args
-    (() (for-each display-var global-variables))
-    (("-e") (set-shell-opt! "errexit" #t))
-    (("+e") (set-shell-opt! "errexit" #f))
-    (("-x") (set-shell-opt! "xtrace" #t))
-    (("+x") (set-shell-opt! "xtrace" #f))))
-
-(define (exit-command . args)
-  (match args
-    (() (exit 0))
-    ((status)
-     (exit (string->number status)))
-    ((args ...)
-     (format (current-error-port) "exit: too many arguments: ~a\n" (string-join args)))))
-
-(define (help-command . _)
-  (display "\
-Hello, this is gash, Guile As SHell.
-
-Gash is work in progress; many language constructs work, globbing
-mostly works, pipes work, some redirections work.
-")
-  (when (or %prefer-builtins? (not (PATH-search-path "ls")))
-    (display "\nIt features the following, somewhat naive builtin commands\n")
-    (display-tabulated (map car %commands))))
-
-(define (cp-command-implementation source dest . rest)
-  (copy-file source dest))
-
-(define cp-command (wrap-command cp-command-implementation "cp"))
-
-(define (set-shell-opt! name set?)
-  (let* ((shell-opts (assoc-ref %global-variables "SHELLOPTS"))
-         (options (if (string-null? shell-opts) '()
-                      (string-split shell-opts #\:)))
-         (new-options (if set? (delete-duplicates (sort (cons name options) string<))
-                          (filter (negate (cut equal? <> name)) options)))
-         (new-shell-opts (string-join new-options ":")))
-    (assignment "SHELLOPTS" new-shell-opts)))
-
 (define (shell-opt? name)
   (member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:)))
 
-(define %commands
-  ;; Built-in commands.
-  `(
-    ("bg"     . ,bg-command)
-    ("cat"    . ,cat-command)
-    ("cd"     . ,cd-command)
-    ("cp"     . ,cp-command)
-    ("echo"   . ,echo-command)
-    ("exit"   . ,exit-command)
-    ("fg"     . ,fg-command)
-    ("help"   . ,help-command)
-    ("jobs"   . ,jobs-command)
-    ("ls"     . ,ls-command)
-    ("pwd"    . ,pwd-command)
-    ("reboot" . ,reboot-command)
-    ("rm"     . ,rm-command)
-    ("set"    . ,set-command)
-    ("wc"     . ,wc-command)
-    ("which"  . ,which-command)
-    ))
-
-(define %prefer-builtins? #t) ; use builtin, even if COMMAND is available in PATH?
-(define (builtin ast)
-  (receive (command args)
-      (match ast
-        ((('append ('glob command) args ...)) (values command args))
-        ((('glob command)) (values command #f))
-        (_ (values #f #f)))
-    (let ((program (and command (PATH-search-path command))))
-      (when (> %debug-level 0)
-        (format (current-error-port) "command ~a => ~s ~s\n" program command args))
-      (cond ((and program (not %prefer-builtins?))
-             #f)
-            ((and command (assoc-ref %commands command))
-             =>
-             (lambda (command)
-               (if args
-                   `(,apply ,command ,@args)
-                   `(,command))))
-            (else
-             (match ast
-               (('for-each rest ...) ast)
-               (('if rest ...) ast)
-               (#t #t)
-               (_ #f)))))))
-
 (define (tostring . args)
   (with-output-to-string (cut map display args)))
 

gash/peg.scm

@@ -5,11 +5,13 @@
   #:use-module (ice-9 pretty-print)
   #:use-module (ice-9 peg)
   #:use-module (ice-9 peg codegen)
+  #:use-module (ice-9 receive)
   #:use-module (ice-9 regex)
 
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
 
+  #:use-module (gash builtins)
   #:use-module (gash gash)
   #:use-module (gash io)
   #:use-module (gash job)
@@ -20,6 +22,7 @@
             %global-variables
             parse
             peg-trace?
+            set-shell-opt!
             ))
 
 (define (wrap-parser-for-users for-syntax parser accumsym s-syn)
@@ -220,7 +223,16 @@
     (format (current-error-port) "sh-exec:exec ast=~s\n" ast))
   (match ast
     ('script #t) ;; skip
-    (('pipeline command ...) (exec ast))
+    (('pipeline commands ...)
+     (when (shell-opt? "xtrace")
+       (for-each
+        (lambda (o)
+          (match o
+            (('command command ...)
+             (format (current-error-port) "+ ~a\n" (string-join command)))
+            (_ (format (current-error-port) "FIXME trace:~s" o))))
+        (reverse commands)))
+     (exec ast))
     (_ (for-each exec ast))))
 
 
@@ -237,10 +249,12 @@
            ast))))
 
 (define (transform ast)
+  (when (> %debug-level 1)
+    (format (current-error-port) "transform ast=~s\n" ast))
   (match ast
     (('script o ...) (map transform o))
     (('substitution o) `(substitution ,@(transform o)))
-    (('pipeline o) (pk `(pipeline ,(transform o))))
+    (('pipeline o) (pk `(pipeline ,(let ((c (warn 'transform (transform o)))) (or (builtin c) c)))))
     (('pipeline h t) (pk `(pipeline ,(transform h) ,@(map transform t))))
     (('command o ...) `(command ,@(map transform o)))
     (('literal o) (transform o))
@@ -255,12 +269,46 @@
     (('else-part o ...) `(begin ,@(map transform o)))
     (_ ast)))
 
+(define (set-shell-opt! name set?)
+  (let* ((shell-opts (assoc-ref %global-variables "SHELLOPTS"))
+         (options (if (string-null? shell-opts) '()
+                      (string-split shell-opts #\:)))
+         (new-options (if set? (delete-duplicates (sort (cons name options) string<))
+                          (filter (negate (cut equal? <> name)) options)))
+         (new-shell-opts (string-join new-options ":")))
+    ;; HMM
+    (assignment "SHELLOPTS" new-shell-opts)
+    (lambda _ (format (current-error-port) "hiero\n") "daro")
+    '("hiero2")))
+
+(define (builtin ast)
+  (when (> %debug-level 0)
+    (format (current-error-port) "builtin ast=~s\n" ast))
+  (receive (command args)
+      (match ast
+        (('command (and (? string?) command) args ...) (values command args))
+        ;; ((('append ('glob command) args ...)) (values command args))
+        ;; ((('glob command)) (values command #f))
+        (_ (values #f #f)))
+    (let ((program (and command (PATH-search-path command))))
+      (when (> %debug-level 0)
+        (format (current-error-port) "command ~a => ~s ~s\n" program command args))
+      (cond ((and program (not %prefer-builtins?))
+             #f)
+            ((and command (assoc-ref %builtin-commands command))
+             =>
+             (lambda (command)
+               (if args
+                   `(,apply ,command ',args)
+                   command)))
+            (else #f)))))
+
 ;; FIXME: export/env vs set
 (define %global-variables
   (map identity ;; FIXME: make mutable
-       `(("SHELLOPTS" . "")
+       `(,(cons "SHELLOPTS" "")
-         ("PIPESTATUS" . "([0]=\"0\"")
+         ,(cons "PIPESTATUS" "([0]=\"0\"")
-         ("?" . "")
+         ,(cons "?" "")
          ,@(map (lambda (key-value)
                   (let* ((key-value (string-split key-value #\=))
                          (key (car key-value))
@@ -333,12 +381,10 @@
                                (cut warn 'status <>)
                                system*) command))
           (else (lambda () #t))))
-  (warn 'command=> (exec (append-map glob args))))
+  (exec (append-map glob args)))
 
 (define (substitution . commands)
   (apply (@ (gash pipe) pipeline->string) (map cdr commands)))
 
 (define (pipeline . commands)
-  (apply (@ (gash pipe) pipeline) #t commands)
+  (apply (@ (gash pipe) pipeline) #t commands))
-  ;;(map (lambda (command) (command)) commands)
-  )

gash/pipe.scm

@@ -73,8 +73,8 @@
                  (when (pair? w)
                    (close-port (current-output-port))
                    (set-current-output-port (car w)))
-                 (let ((status (warn 'spawn-status (if (thunk? command) (command)
+                 (let ((status (if (thunk? command) (command)
-                                                       (command input w)))))
+                                   (command input w))))
                    (exit (cond ((number? status) status)
                                ((boolean? status) status)
                                (else 0)))))
@@ -90,11 +90,11 @@
 (define (pipeline fg? . commands)
   (when (> %debug-level 0)
     (format (current-error-port) "pipeline[~a]: COMMANDS: ~s\n" fg? commands))
-  (when (shell-opt? "xtrace")
+  ;; (when (shell-opt? "xtrace")
-    (for-each
+  ;;   (for-each
-     (lambda (o)
+  ;;    (lambda (o)
-       (format (current-error-port) "+ ~a\n" (string-join o)))
+  ;;      (format (current-error-port) "+ ~a\n" (string-join o)))
-     (reverse commands)))
+  ;;    (reverse commands)))
   (receive (r w)
       (pipe*)
     (move->fdes w 2)