andrius
/
gash
mirror of https://git.savannah.gnu.org/git/gash.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

resurrect builtins: WIP

This commit is contained in:
Jan Nieuwenhuizen 2018-07-14 11:43:17 +02:00
parent f3c8c2c7f0
commit 4d3751f654
5 changed files with 183 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
build-aux/build-guile.sh
View File

@ -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

116
gash/builtins.scm Normal file
View File

@ -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)
))

125
gash/gash.scm
View File

@ -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)))

64
gash/peg.scm
View File

@ -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))

14
gash/pipe.scm
View File

@ -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)