From 4d3751f654187af88851c45479a31010efbd0d30 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 14 Jul 2018 11:43:17 +0200 Subject: [PATCH] resurrect builtins: WIP --- build-aux/build-guile.sh | 1 + gash/builtins.scm | 116 ++++++++++++++++++++++++++++++++++++ gash/gash.scm | 125 ++------------------------------------- gash/peg.scm | 64 +++++++++++++++++--- gash/pipe.scm | 14 ++--- 5 files changed, 183 insertions(+), 137 deletions(-) create mode 100644 gash/builtins.scm diff --git a/build-aux/build-guile.sh b/build-aux/build-guile.sh index 7c4f75a..d9fd178 100755 --- a/build-aux/build-guile.sh +++ b/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 diff --git a/gash/builtins.scm b/gash/builtins.scm new file mode 100644 index 0000000..988ba38 --- /dev/null +++ b/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) + )) diff --git a/gash/gash.scm b/gash/gash.scm index e9d78b2..3c8513e 100644 --- a/gash/gash.scm +++ b/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))) diff --git a/gash/peg.scm b/gash/peg.scm index 2498155..dad53c4 100644 --- a/gash/peg.scm +++ b/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" . "") - ("PIPESTATUS" . "([0]=\"0\"") - ("?" . "") + `(,(cons "SHELLOPTS" "") + ,(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) - ;;(map (lambda (command) (command)) commands) - ) + (apply (@ (gash pipe) pipeline) #t commands)) diff --git a/gash/pipe.scm b/gash/pipe.scm index ed8cc15..bf9789c 100644 --- a/gash/pipe.scm +++ b/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) - (command input w))))) + (let ((status (if (thunk? command) (command) + (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") - (for-each - (lambda (o) - (format (current-error-port) "+ ~a\n" (string-join o))) - (reverse commands))) + ;; (when (shell-opt? "xtrace") + ;; (for-each + ;; (lambda (o) + ;; (format (current-error-port) "+ ~a\n" (string-join o))) + ;; (reverse commands))) (receive (r w) (pipe*) (move->fdes w 2)