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

geesh: initial integration. 

GUILE_LOAD_PATH=$HOME/src/geesh:$GUILE_LOAD_PATH
    GUILE_LOAD_COMPILED_PATH=$HOME/src/geesh:$GUILE_LOAD_COMPILED_PATH

    bin/gash --parse -c 'echo boo | sed s,o,O, | grep .'
    bin/gash --geesh --parse -c 'echo boo | sed s,o,O, | grep .'
This commit is contained in:
Jan Nieuwenhuizen 2018-07-16 08:41:10 +02:00
parent 9462aaa163
commit 0f5b538c3a
33 changed files with 1029 additions and 669 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
INSTALL Normal file
View File

@ -0,0 +1,30 @@
-*- org -*-
Building and Installing Gash
* Get it
git clone https://gitlab.com/rutger.van.beusekom/gash
* Regular build
** Prerequisites
*** Guix
guix environment -l guix.scm
*** Other GNU/Linux
- [[https://gitlab.com/samplet/geesh][geesh]], 0.1-rc is known to work.
- GNU Guile, version 2.2.3 or is known to work.
- GNU make, version 4.2 known to work.
- SH, /bin/sh, GNU Bash 4.3 is known to work.
- git, 2.10 is known to work.
** Build it
./configure
make
** Check it
make check
** Install it
make install
* Guix it
guix package -f guix.scm

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

@ -27,6 +27,9 @@ export GUILE_AUTO_COMPILE
export GUILE_LOAD_PATH
export GUILE_LOAD_COMPILED_PATH
GUILE_LOAD_PATH=$HOME/src/geesh:$GUILE_LOAD_PATH
GUILE_LOAD_COMPILED_PATH=$HOME/src/geesh:$GUILE_LOAD_COMPILED_PATH
GUILE_LOAD_PATH=$(pwd):$GUILE_LOAD_PATH
GUILE_LOAD_COMPILED_PATH=$(pwd):$GUILE_LOAD_COMPILED_PATH
GUILE=${GUILE-$(command -v guile)}
@ -37,15 +40,17 @@ set -e
SCM_FILES="
gash/bournish-commands.scm
gash/guix-build-utils.scm
gash/builtins.scm
gash/config.scm
gash/environment.scm
gash/guix-build-utils.scm
gash/geesh.scm
gash/gash.scm
gash/io.scm
gash/job.scm
gash/peg.scm
gash/pipe.scm
gash/script.scm
gash/util.scm
"

9
configure vendored
View File

@ -18,6 +18,15 @@ GUILE_SITE_DIR=$PREFIX/share/guile/site/$GUILE_EFFECTIVE_VERSION
GUILE_SITE_CCACHE_DIR=$PREFIX/lib/guile/$GUILE_EFFECTIVE_VERSION/site-ccache
GUILE_EFFECTIVE_VERSION=$(guile -c '(display (effective-version))')
MAKEINFO=$(command -v makeinfo)
GEESH_PREFIX=${GEESH_PREFIX-$HOME/src/geesh}
if [ -d $GEESH_PREFIX ]; then
GUILE_LOAD_PATH=$GEESH_PREFIX:$GUILE_LOAD_PATH
GUILE_LOAD_COMPILED_PATH=$GEESH_PREFIX:$GUILE_LOAD_COMPILED_PATH
if ! $GUILE -c '(use-modules (geesh parser)) (exit (defined? '"'"'read-sh-all))'; then
echo "your geesh is too old"
exit 1
fi
fi
sed \
-e s,@GUILE@,$GUILE,\

253
gash/bournish-commands.scm
View File

@ -33,15 +33,19 @@
#:use-module (gash guix-build-utils)
#:use-module (gash config)
#:use-module (gash io)
#:use-module (gash util)
#:export (
display-tabulated
%bournish-commands
cat-command
display-tabulated
find-command
grep-command
ls-command
reboot-command
rm-command
wc-command
which-command
wrap-command
))
;;; Commentary:
@ -105,24 +109,21 @@ TERMINAL-WIDTH. Use COLUMN-GAP spaces between two subsequent columns."
(module-define! (resolve-module '(ice-9 getopt-long)) 'short-opt-rx (make-regexp "^-([a-zA-Z0-9]+)(.*)")))
(else))
(define ls-command-implementation
(define (ls-command-implementation . args)
;; Run-time support procedure.
(case-lambda
(()
(display-tabulated (scandir ".")))
(args
(let* ((option-spec
'((all (single-char #\a))
(help)
(one-file-per-line (single-char #\1))
(version)))
(options (getopt-long (cons "ls" args) option-spec))
(all? (option-ref options 'all #f))
(help? (option-ref options 'help #f))
(one-file-per-line? (option-ref options 'one-file-per-line #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: ls [OPTION]... [FILE]...
(lambda _
(let* ((option-spec
'((all (single-char #\a))
(help)
(one-file-per-line (single-char #\1))
(version)))
(options (getopt-long (cons "ls" args) option-spec))
(all? (option-ref options 'all #f))
(help? (option-ref options 'help #f))
(one-file-per-line? (option-ref options 'one-file-per-line #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: ls [OPTION]... [FILE]...
Options:
-a, --all do not ignore entries starting with .
@ -130,60 +131,62 @@ Options:
--help display this help and exit
--version display version information and exit
"))
(version? (format #t "ls (GASH) ~a\n" %version))
(else
(let* ((files (if (null? files) (scandir ".")
(append-map (lambda (file)
(catch 'system-error
(lambda ()
(match (stat:type (lstat file))
('directory
;; Like GNU ls, list the contents of
;; FILE rather than FILE itself.
(match (scandir file
(match-lambda
((or "." "..") #f)
(_ #t)))
(#f
(list file))
((files ...)
(map (cut string-append file "/" <>)
files))))
(_
(list file))))
(lambda args
(let ((errno (system-error-errno args)))
(format (current-error-port) "~a: ~a~%"
file (strerror errno))
'()))))
files)))
(files (if all? files
(filter (negate (cut string-prefix? "." <>)) files))))
(if one-file-per-line? (for-each stdout files)
(display-tabulated files)))))))))
(version? (format #t "ls (GASH) ~a\n" %version))
(else
(let* ((files (if (null? files) (scandir ".")
(append-map (lambda (file)
(catch 'system-error
(lambda ()
(match (stat:type (lstat file))
('directory
;; Like GNU ls, list the contents of
;; FILE rather than FILE itself.
(match (scandir file
(match-lambda
((or "." "..") #f)
(_ #t)))
(#f
(list file))
((files ...)
(map (cut string-append file "/" <>)
files))))
(_
(list file))))
(lambda args
(let ((errno (system-error-errno args)))
(format (current-error-port) "~a: ~a~%"
file (strerror errno))
'()))))
files)))
(files (if all? files
(filter (negate (cut string-prefix? "." <>)) files))))
(if one-file-per-line? (for-each stdout files)
(display-tabulated files))))))))
(define ls-command (wrap-command ls-command-implementation "ls"))
(define (which-command program . rest)
(stdout (search-path (executable-path) program)))
(lambda _
(stdout (search-path (executable-path) program))))
(define (cat-command-implementation . args)
(fold (lambda (file p)
(if (string=? file "-") (dump-port (current-input-port) (current-output-port))
(call-with-input-file file
(lambda (port)
(dump-port port (current-output-port))))))
0 args))
(lambda _
(fold (lambda (file p)
(if (string=? file "-") (dump-port (current-input-port) (current-output-port))
(call-with-input-file file
(lambda (port)
(dump-port port (current-output-port))))))
0 args)))
(define cat-command (wrap-command cat-command-implementation "cat"))
(define (rm-command-implementation . args)
"Emit code for the 'rm' command."
(cond ((member "-r" args)
(for-each delete-file-recursively
(apply delete (cons "-r" args))))
(else
(for-each delete-file args))))
(lambda _
(cond ((member "-r" args)
(for-each delete-file-recursively
(apply delete (cons "-r" args))))
(else
(for-each delete-file args)))))
(define rm-command (wrap-command rm-command-implementation "rm"))
@ -235,12 +238,13 @@ Options:
(define (wc-command . args)
"Emit code for the 'wc' command."
(cond ((member "-l" args)
(apply wc-l-command-implementation (delete "-l" args)))
((member "-c" args)
(apply wc-c-command-implementation (delete "-c" args)))
(else
(apply wc-command-implementation args))))
(lambda _
(cond ((member "-l" args)
(apply wc-l-command-implementation (delete "-l" args)))
((member "-c" args)
(apply wc-c-command-implementation (delete "-c" args)))
(else
(apply wc-command-implementation args)))))
(define (reboot-command . args)
"Emit code for 'reboot'."
@ -259,3 +263,114 @@ Options:
(match (getenv "PATH")
(#f '())
(str (string-tokenize str %not-colon))))
(define (cp-command-implementation source dest . rest)
(lambda _ (copy-file source dest)))
(define cp-command (wrap-command cp-command-implementation "cp"))
(define (find-command-implementation . args)
;; Run-time support procedure.
(lambda _
(let* ((option-spec
'((help)
(version)))
(options (getopt-long (cons "find" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(files (if (null? files) '(".") files))
(file (car files)))
(when (> (length files) 1)
(format (current-error-port) "find: too many FILEs: ~s\n" files)
(error "find failed"))
;; TODO: find [OPTION]... [FILE]... [EXPRESSION]...
;; and options: esp: -x, -L
(cond (help? (display "Usage: find [OPTION]... [FILE]
Options:
--help display this help and exit
--version display version information and exit
"))
(version? (format #t "find (GASH) ~a\n" %version))
(else
(let* ((files (find-files file #:directories? #t #:fail-on-error? #t)))
(for-each stdout files)))))))
(define find-command (wrap-command find-command-implementation "find"))
(define (grep-command . args)
(lambda _
(let* ((option-spec
'((help)
(line-number (single-char #\n))
(files-with-matches (single-char #\l))
(files-without-match (single-char #\L))
(with-file-name (single-char #\H))
(no-file-name (single-char #\h))
(only-matching (single-char #\o))
(version (single-char #\V))))
(options (getopt-long (cons "ls" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: grep [OPTION]... PATTERN [FILE]...
Options:
--help display this help and exit
-h, --no-filename suppress the file name prefix on output
-H, --with-filename print file name with output lines
-l, --files-with-matches print only names of FILEs with selected lines
-L, --files-without-match print only names of FILEs with no selected lines
-n, --line-number print line number with output lines
-o, --only-matching show only the part of a line matching PATTERN
-V, --version display version information and exit
"))
(version? (format #t "grep (GASH) ~a\n" %version))
((null? files) #t)
(else
(let* ((pattern (car files))
(files (if (pair? (cdr files)) (cdr files)
(list "-")))
(matches (append-map (cut grep pattern <>) files)))
(define (display-match o)
(let* ((s (grep-match-string o))
(s (if (option-ref options 'only-matching #f)
(substring s (grep-match-column o) (grep-match-end-column o))
s))
(s (if (option-ref options 'line-number #f)
(string-append (number->string (grep-match-line o)) ":" s)
s))
(s (if (option-ref options 'with-file-name #f)
(string-append (grep-match-file-name o) ":" s)
s)))
(stdout s)))
(define (files-with-matches)
(delete-duplicates (map grep-match-file-name matches)))
(cond ((option-ref options 'files-with-matches #f)
(let ((result (files-with-matches)))
(and (pair? result)
(for-each stdout result)
0)))
((option-ref options 'files-without-match #f)
(let* ((result (files-with-matches))
(result (filter (negate (cut member <> result)) files)))
(and (pair? result)
(for-each stdout result)
0)))
(else
(and (pair? matches)
(for-each display-match matches)
0)))))))))
(define %bournish-commands
`(
("cat" . ,cat-command)
("cp" . ,cp-command)
("find" . ,find-command)
("grep" . ,grep-command)
("ls" . ,ls-command)
("reboot" . ,reboot-command)
("wc" . ,wc-command)
("which" . ,which-command)
))

621
gash/builtins.scm
View File

@ -28,60 +28,54 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash bournish-commands)
#:use-module (gash config)
#:use-module (gash gash) ; %prefer-builtins?
#:use-module (gash bournish-commands)
#:use-module (gash environment)
#:use-module (gash gash)
#:use-module (gash guix-build-utils)
#:use-module (gash io)
#:use-module (gash job)
#:use-module (gash pipe)
#:use-module (gash script)
#:use-module (gash util)
#:export (
%builtin-commands
builtin
pipeline
command
glob
singlequotes
doublequotes
sequence
splice
for
split
substitution
script
if-clause
xtrace
word
PATH-search-path
trace
bg-command
cd-command
echo-command
eval-command
exit-command
fg-command
find-command
help-command
jobs-command
pwd-command
set-command
))
(define (PATH-search-path program)
(search-path (string-split (getenv "PATH") #\:) program))
(define (cd-command . args)
(match args
(() (cd-command (getenv "HOME")))
((dir)
(assignment "OLDPWD" (getcwd))
(if (string=? dir "-") (chdir (variable "OLDPWD"))
(chdir dir)))
(let ((old (variable "OLDPWD")))
(assignment "OLDPWD" (getcwd))
(if (string=? dir "-") (chdir old)
(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 ...) (display (string-join args)))
(_ (display (string-join args)) (newline))))
(lambda _
(match args
(() (newline))
(("-n" args ...) (display (string-join args)))
(_ (display (string-join args)) (newline)))))
(define (bg-command . args)
(match args
@ -93,18 +87,34 @@
(() (fg 1))
((job x ...) (fg (string->number (car job))))))
(define pwd-command (lambda _ (stdout (getcwd))))
(define (jobs-command)
(format (current-error-port) "jobs: ~s\n" job-table)
(for-each (lambda (job) (display-job job)) (reverse job-table)))
(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))
(() (lambda _ (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 (eval-command . args)
(lambda _
(match args
(() #t)
((args ...)
(let ((ast (parse-string (string-join args))))
;;(ignore-error (run ast))
(run ast)
(assignment "?" "0")
#t)))))
(define (exit-command . args)
(match args
(() (exit 0))
@ -114,68 +124,34 @@
(format (current-error-port) "exit: too many arguments: ~a\n" (string-join args)))))
(define (help-command . _)
(display "\
(lambda _
(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 %builtin-commands))))
(define (cp-command-implementation source dest . rest)
(copy-file source dest))
(define cp-command (wrap-command cp-command-implementation "cp"))
(define find-command-implementation
;; Run-time support procedure.
(case-lambda
(()
(find-command-implementation "."))
(args
(let* ((option-spec
'((help)
(version)))
(options (getopt-long (cons "find" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(files (if (null? files) '(".") files))
(file (car files)))
(when (> (length files) 1)
(format (current-error-port) "find: too many FILEs: ~s\n" files)
(error "find failed"))
;; TODO: find [OPTION]... [FILE]... [EXPRESSION]...
;; and options: esp: -x, -L
(cond (help? (display "Usage: find [OPTION]... [FILE]
Options:
--help display this help and exit
--version display version information and exit
"))
(version? (format #t "find (GASH) ~a\n" %version))
(else
(let* ((files (find-files file #:directories? #t #:fail-on-error? #t)))
(for-each stdout files))))))))
(define find-command (wrap-command find-command-implementation "find"))
(display "\nIt has these builtin commands:\n")
(display-tabulated (map car %builtin-commands))
(when (or %prefer-builtins? (not (PATH-search-path "ls")))
(display "\nand features the following, somewhat naive, bournish commands:\n")
(display-tabulated (map car %bournish-commands)))))
(define command-command
(case-lambda
(() #t)
(args
(let* ((option-spec
'((describe (single-char #\V))
(help)
(show (single-char #\v))
(version)))
(options (getopt-long (cons "command" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: command [OPTION]... [COMMAND [ARG]...]
(lambda _
(let* ((option-spec
'((describe (single-char #\V))
(help)
(show (single-char #\v))
(version)))
(options (getopt-long (cons "command" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: command [OPTION]... [COMMAND [ARG]...]
Options:
--help display this help and exit
@ -183,93 +159,95 @@ Options:
-v display a description of COMMAND similar to the `type' builtin
-V display a more verbose description of COMMAND
"))
(version? (format #t "command (GASH) ~a\n" %version))
((null? files) #t)
((option-ref options 'describe #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(cond (builtin (format #t "~a is a shell builtin\n" command)
0)
(else (let ((program (PATH-search-path command)))
(if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0)
1))))))
((option-ref options 'show #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(if builtin (begin (stdout command) 0)
(let ((program (PATH-search-path command)))
(if (string? program) (begin (stdout program) 0)
1)))))
(else (let* ((command (car files))
(builtin (builtin command #:prefer-builtin? %prefer-builtins?)))
;; FIXME:
`(command ,@args))))))))
(version? (format #t "command (GASH) ~a\n" %version))
((null? files) #t)
((option-ref options 'describe #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(cond (builtin (format #t "~a is a shell builtin\n" command)
0)
(else (let ((program (PATH-search-path command)))
(if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0)
1))))))
((option-ref options 'show #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(if builtin (begin (stdout command) 0)
(let ((program (PATH-search-path command)))
(if (string? program) (begin (stdout program) 0)
1)))))
(else (let* ((command (car files))
(builtin (builtin command #:prefer-builtin? %prefer-builtins?)))
;; FIXME:
`(command ,@args)))))))))
(define type-command
(case-lambda
(() #t)
(args
(let* ((option-spec
'((help)
(canonical-file-name (single-char #\p))
(version)))
(options (getopt-long (cons "type" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: type [OPTION]... [COMMAND]
(lambda _
(let* ((option-spec
'((help)
(canonical-file-name (single-char #\p))
(version)))
(options (getopt-long (cons "type" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: type [OPTION]... [COMMAND]
Options:
--help display this help and exit
-p display canonical file name of COMMAND
--version display version information and exit
"))
(version? (format #t "type (GASH) ~a\n" %version))
((null? files) #t)
((option-ref options 'canonical-file-name #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(if builtin 0
(let ((program (PATH-search-path command)))
(and (string? program)
(stdout program)
0)))))
(else
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(cond (builtin (format #t "~a is a shell builtin\n" command)
0)
(else (let ((program (PATH-search-path command)))
(if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0)
1)))))))))))
(version? (format #t "type (GASH) ~a\n" %version))
((null? files) #t)
((option-ref options 'canonical-file-name #f)
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(if builtin 0
(let ((program (PATH-search-path command)))
(and (string? program)
(stdout program)
0)))))
(else
(let* ((command (car files))
(builtin (builtin `(,command) #:prefer-builtin? %prefer-builtins?)))
(cond (builtin (format #t "~a is a shell builtin\n" command)
0)
(else (let ((program (PATH-search-path command)))
(if (string? program) (begin (format #t "~a hashed (~a)\n" command ) 0)
1))))))))))))
(define test-command
(case-lambda
(() #f)
(args
(let* ((option-spec
'((is-directory (single-char #\d))
(exists (single-char #\e))
(has-size (single-char #\s))
(help)
(is-directory (single-char #\d))
(is-file (single-char #\f))
(is-symbolic-link (single-char #\L))
(is-symbolic-link (single-char #\h))
(is-readable (single-char #\r))
(is-writable (single-char #\w))
(is-exeutable (single-char #\x))
(string-not-null (single-char #\n))
(string-null (single-char #\z))
(version)))
(options (getopt-long (cons "test" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(file (and (pair? files) (car files)))
(no-options? (and file
(= (length options) 1))))
(cond (help? (display "Usage: test [EXPRESSION]
(lambda _
(let* ((option-spec
'((is-directory (single-char #\d))
(exists (single-char #\e))
(has-size (single-char #\s))
(help)
(is-directory (single-char #\d))
(is-file (single-char #\f))
(is-symbolic-link (single-char #\L))
(is-symbolic-link (single-char #\h))
(is-readable (single-char #\r))
(is-writable (single-char #\w))
(is-exeutable (single-char #\x))
(string-not-null (single-char #\n))
(string-null (single-char #\z))
(version)))
(options (getopt-long (cons "test" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '()))
(file (and (pair? files) (car files)))
(no-options? (and file
(= (length options) 1))))
(cond (help? (display "Usage: test [EXPRESSION]
Expression:
@ -297,310 +275,87 @@ Options:
--help display this help and exit
--version display version information and exit
"))
(version? (format #t "test (GASH) ~a\n" %version))
((null? files) #f)
((or (option-ref options 'n #f)
no-options?)
(not (string-null? file)))
((option-ref options 'z #f)
(string-null? file))
((and (= (length files) 3)
(member (cadr files) '("=" "==")))
(match files
((or (left "=" right)
(left "==" right))
(equal? left right))
((left "!=" right)
(not (equal? left right)))
(expression
(pipeline (command expression)))))
((not (= (length files) 1))
(format (current-error-port) "test: too many files: ~a\n" files)
1)
((option-ref options 'is-file #f)
(regular-file? file))
((option-ref options 'is-directory #f)
(directory-exists? file))
((option-ref options 'exists #f)
(file-exists? file))
((option-ref options 'is-symbolic-link #f)
(symbolic-link? file))
((option-ref options 'is-readable #f)
(access? file R_OK))
((option-ref options 'has-size #f)
(and (file-exists? file)
(not (zero? (stat:size (stat file))))))
((option-ref options 'is-writable #f)
(access? file W_OK))
((option-ref options 'is-exeutable #f)
(access? file X_OK))
(else
(error "gash: test: not supported" args)))))))
(version? (format #t "test (GASH) ~a\n" %version))
((null? files) #f)
((or (option-ref options 'n #f)
no-options?)
(not (string-null? file)))
((option-ref options 'z #f)
(string-null? file))
((and (= (length files) 3)
(member (cadr files) '("=" "==")))
(match files
((or (left "=" right)
(left "==" right))
(equal? left right))
((left "!=" right)
(not (equal? left right)))
(expression
(pipeline (command expression)))))
((not (= (length files) 1))
(format (current-error-port) "test: too many files: ~a\n" files)
1)
((option-ref options 'is-file #f)
(regular-file? file))
((option-ref options 'is-directory #f)
(directory-exists? file))
((option-ref options 'exists #f)
(file-exists? file))
((option-ref options 'is-symbolic-link #f)
(symbolic-link? file))
((option-ref options 'is-readable #f)
(access? file R_OK))
((option-ref options 'has-size #f)
(and (file-exists? file)
(not (zero? (stat:size (stat file))))))
((option-ref options 'is-writable #f)
(access? file W_OK))
((option-ref options 'is-exeutable #f)
(access? file X_OK))
(else
(error "gash: test: not supported" args))))))))
(define bracket-command
(case-lambda
(() #f)
(args
(cond ((and (pair? args) (equal? (car args) "--help"))
(test-command "--help"))
((and (pair? args) (equal? (car args) "--version"))
(test-command "--version"))
(else
(if (not (equal? (last args) "]")) (begin
(format (current-error-port) "gash: [: missing `]'\n")
#f)
(apply test-command (drop-right args 1))))))))
(define grep-command
(case-lambda
(() #f)
(args
(let* ((option-spec
'((help)
(line-number (single-char #\n))
(files-with-matches (single-char #\l))
(files-without-match (single-char #\L))
(with-file-name (single-char #\H))
(no-file-name (single-char #\h))
(only-matching (single-char #\o))
(version (single-char #\V))))
(options (getopt-long (cons "ls" args) option-spec))
(help? (option-ref options 'help #f))
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(cond (help? (display "Usage: grep [OPTION]... PATTERN [FILE]...
Options:
--help display this help and exit
-h, --no-filename suppress the file name prefix on output
-H, --with-filename print file name with output lines
-l, --files-with-matches print only names of FILEs with selected lines
-L, --files-without-match print only names of FILEs with no selected lines
-n, --line-number print line number with output lines
-o, --only-matching show only the part of a line matching PATTERN
-V, --version display version information and exit
"))
(version? (format #t "grep (GASH) ~a\n" %version))
((null? files) #t)
(lambda _
(cond ((and (pair? args) (equal? (car args) "--help"))
(test-command "--help"))
((and (pair? args) (equal? (car args) "--version"))
(test-command "--version"))
(else
(let* ((pattern (car files))
(files (cdr files))
(matches (append-map (cut grep pattern <>) files)))
(define (display-match o)
(let* ((s (grep-match-string o))
(s (if (option-ref options 'only-matching #f)
(substring s (grep-match-column o) (grep-match-end-column o))
s))
(s (if (option-ref options 'line-number #f)
(string-append (number->string (grep-match-line o)) ":" s)
s))
(s (if (option-ref options 'with-file-name #f)
(string-append (grep-match-file-name o) ":" s)
s)))
(stdout s)))
(define (files-with-matches)
(delete-duplicates (map grep-match-file-name matches)))
(cond ((option-ref options 'files-with-matches #f)
(let ((result (files-with-matches)))
(and (pair? result)
(for-each stdout result)
0)))
((option-ref options 'files-without-match #f)
(let* ((result (files-with-matches))
(result (filter (negate (cut member <> result)) files)))
(and (pair? result)
(for-each stdout result)
0)))
(else
(and (pair? matches)
(for-each display-match matches)
0))))))))))
(if (not (equal? (last args) "]")) (begin
(format (current-error-port) "gash: [: missing `]'\n")
#f)
(apply test-command (drop-right args 1)))))))))
(define (PATH-search-path program)
(search-path (string-split (getenv "PATH") #\:) program))
(define* (builtin ast #:key prefer-builtin?)
;; FIXME: distinguish between POSIX compliant builtins and
;; `best-effort'/`fallback'?
"Possibly modify command to use a builtin."
(when (> %debug-level 0)
(format (current-error-port) "builtin ast=~s\n" ast))
(receive (command args)
(match ast
(((and (? string?) command) args ...) (values command args))
(_ (values #f #f)))
(let ((program (and command
(cond ((string-prefix? "/" command)
(when (not (file-exists? command))
(format (current-error-port) "gash: ~a: no such file or directory\n" command))
command)
(else (PATH-search-path command))))))
;; FIXME: find some generic strerror/errno way: what about permissions and stuff?
;; after calling system* we're too late for that?
(when (> %debug-level 0)
(format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args))
(cond ((and program (not prefer-builtin?))
(when (not program)
(format (current-error-port) "gash: ~a: command not found\n" command))
(when (not (access? program X_OK))
(format (current-error-port) "gash: ~a: permission denied\n" command))
#f)
((and command (assoc-ref %builtin-commands command))
=>
(lambda (command)
(if args
(apply command (map (cut local-eval <> (the-environment)) args))
(command))))
(else #f)))))
(define (command . args)
(define (exec command)
(cond ((procedure? command) command)
((every string? command)
(let* ((program (car command))
(escape-builtin? (and (string? program) (string-prefix? "\\" program)))
(program (if escape-builtin? (string-drop program 1) program))
(command (cons program (cdr command))))
(or (builtin command #:prefer-builtin? (and %prefer-builtins?
(not escape-builtin?)))
(cut apply (compose status:exit-val system*) command))))
(else (lambda () #t))))
(exec (append-map glob args)))
(define (glob pattern)
(define (glob? pattern)
(and (string? pattern) (string-match "\\?|\\*" pattern)))
(define (glob2regex pattern)
(let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post))
(pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post))
(pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post)))
(make-regexp (string-append "^" pattern "$"))))
(define (glob-match regex path) ;; pattern path -> bool
(regexp-match? (regexp-exec regex path)))
(define (glob- pattern file-names)
(map (lambda (file-name)
(if (string-prefix? "./" file-name) (string-drop file-name 2) file-name))
(append-map (lambda (file-name)
(map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>)
(filter (conjoin (negate (cut string-prefix? "." <>))
(cute glob-match (glob2regex pattern) <>))
(or (scandir file-name) '()))))
file-names)))
(cond
((not pattern) '(""))
((glob? pattern) (let ((absolute? (string-prefix? "/" pattern)))
(let loop ((patterns (filter (negate string-null?) (string-split pattern #\/)))
(file-names (if absolute? '("/") '("."))))
(if (null? patterns)
file-names
(begin
(loop (cdr patterns) (glob- (car patterns) file-names)))))))
(#t (list pattern))))
(define (singlequotes . o)
(string-join o ""))
(define (doublequotes . o)
(string-join (append-map glob o) ""))
(define (sequence . args)
(pke 'sequence (append-map glob (apply append args)))
;;(pke 'sequence (map glob (pke 'apply-append (apply append (pke 'seq-args: args)))))
;;(list (apply append args))
)
(define (script . o)
o)
(define (for name sequence body)
(for-each (lambda (value)
(assignment name value)
(body))
(sequence)))
(define (split o)
((compose string-tokenize string-trim-right) o))
(define (xtrace o)
(o))
(define (word . o)
(apply string-append o))
(define-syntax-rule (substitution commands)
(let ((lst (pke 'split (split (pke 'string (with-output-to-string (lambda _ commands)))))))
(if (= (length lst) 1) (car lst)
lst)))
(define-syntax if-clause
(lambda (x)
(syntax-case x ()
((_ expr then)
(with-syntax ((it (datum->syntax x 'it)))
#'(let ((it expr))
(if (zero? it) then))))
((_ expr then else)
(with-syntax ((it (datum->syntax x 'it)))
#'(let ((it expr))
(if (zero? it) then else)))))))
(define (pipeline . commands)
(define (handle job)
(let* ((stati (cond ((job? job) (map status:exit-val (job-status job)))
((boolean? job) (list (if job 0 1)))
((number? job) (list job))
(else (list 0))))
(status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0)
(car stati)))
(pipestatus (string-append
"("
(string-join
(map (lambda (s i)
(format #f "[~a]=\"~a\"" s i))
stati
(iota (length stati))))
")")))
(assignment "PIPESTATUS" pipestatus)
(assignment "?" (number->string status))
(when (and (not (zero? status))
(shell-opt? "errexit"))
(exit status))
status))
(when (> %debug-level 1)
(format (current-error-port) "pijp: commands=~s\n" commands))
;; FIXME: after running a builtin, we still end up here with the builtin's result
;; that should probably not happen, however, cater for it here for now
(match commands
(((and (? boolean?) boolean))
(handle boolean))
(((and (? number?) number))
(handle number))
(((? unspecified?))
(handle #t))
(_ (handle (apply pipeline+ #t commands)))))
(define (trace commands)
`(xtrace
,(lambda _
(when (shell-opt? "xtrace")
(for-each
(lambda (o)
(match o
(('command (and command (? string?)) ...)
(format (current-error-port) "+ ~a\n" (string-join command)))
(_ format (current-error-port) "+ ~s <FIXME>\n" o)))
(reverse commands))))))
(define %builtin-commands
`(
("bg" . ,bg-command)
("cat" . ,cat-command)
("command" . ,command-command)
("cd" . ,cd-command)
("cp" . ,cp-command)
("echo" . ,echo-command)
("eval" . ,eval-command)
("exit" . ,exit-command)
("fg" . ,fg-command)
("find" . ,find-command)
("grep" . ,grep-command)
("help" . ,help-command)
("jobs" . ,jobs-command)
("ls" . ,ls-command)
("pwd" . ,pwd-command)
("reboot" . ,reboot-command)
("rm" . ,rm-command)
("set" . ,set-command)
("test" . ,test-command)
("type" . ,type-command)
("wc" . ,wc-command)
("which" . ,which-command)
("[" . ,bracket-command)
))

4
gash/environment.scm
View File

@ -27,6 +27,7 @@
%global-variables
assignment
set-shell-opt!
shell-opt?
variable
))
@ -60,3 +61,6 @@
(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") #\:)))

144
gash/gash.scm
View File

@ -18,57 +18,47 @@
#:use-module (gash environment)
#:use-module (gash job)
#:use-module (gash pipe)
#:use-module (gash peg)
#:use-module (gash io)
#:use-module (gash script)
#:use-module (gash util)
#:export (main
%debug-level
%prefer-builtins?
shell-opt?))
parse
parse-string))
(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 %geesh-parser? #f) ; use Geesh parser [EXPERIMENTAL]
(define (remove-shell-comments s)
(string-join (map
(lambda (s)
(let* ((n (string-index s #\#)))
(if n (string-pad-right s (string-length s) #\space 0 n)
s)))
(string-split s #\newline)) "\n"))
(define (parse-string string)
(let ((parser (cond (%geesh-parser? (@ (gash geesh) parse-string))
(else (@ (gash peg) parse-string)))))
(parser string)))
(define (remove-escaped-newlines s)
(reduce (lambda (next prev)
(let* ((escaped? (string-suffix? "\\" next))
(next (if escaped? (string-drop-right next 1) next))
(sep (if escaped? "" "\n")))
(string-append prev sep next)))
"" (string-split s #\newline)))
(define (file-to-string file-name)
(format (current-error-port) "gash: reading: ~s\n" file-name)
(with-input-from-file file-name read-string))
(define (string-to-ast string)
((compose parse remove-escaped-newlines remove-shell-comments) string))
(define (parse port)
(let ((parser (cond (%geesh-parser? (@ (gash geesh) parse))
(else (@ (gash peg) parse)))))
(parser port)))
(define (file-to-ast file-name)
((compose string-to-ast file-to-string) file-name))
(call-with-input-file file-name parse))
(define (display-help)
(display "\
Usage: gash [OPTION]... [FILE]...
Options:
-c, --command=STRING Evaluate STRING and exit
-e, --errexit Exit upon error
-d, --debug Enable PEG tracing
-h, --help Display this help
-p, --parse Parse the shell script and print the parse tree
--prefer-builtins Use builtins, even if command is available in PATH
-v, --version Display the version
-x, --xtrace Print simple command trace
-c, --command=STRING Evaluate STRING and exit
-e, --errexit Exit upon error
-d, --debug Enable PEG tracing
-g, --geesh Use Geesh parser [EXPERIMENTAL]
-h, --help Display this help
-p, --parse Parse the shell script and print the parse tree
--prefer-builtins Use builtins, even if command is available in PATH
-v, --version Display the version
-x, --xtrace Print simple command trace
"))
(define (display-version)
@ -93,6 +83,7 @@ copyleft.
(help (single-char #\h))
(parse (single-char #\p))
(prefer-builtins)
(geesh (single-char #\g))
(version (single-char #\v))
(xtrace (single-char #\x))))
(options (getopt-long args option-spec #:stop-at-first-non-option #t ))
@ -105,6 +96,7 @@ copyleft.
(version? (option-ref options 'version #f))
(files (option-ref options '() '())))
(set! %prefer-builtins? (option-ref options 'prefer-builtins #f))
(set! %geesh-parser? (option-ref options 'geesh #f))
(set-shell-opt! "errexit" (option-ref options 'errexit #f))
(set-shell-opt! "xtrace" (option-ref options 'xtrace #f))
(when (option-ref options 'debug #f)
@ -112,19 +104,24 @@ copyleft.
(cond
(help? (display-help))
(version? (display-version))
(command? (let ((ast (string-to-ast command?)))
(exit (assoc-ref %global-variables "?"))))
(command? (let ((ast (parse-string command?)))
(if parse? (pretty-print ast)
(run ast))
(exit (script-status))))
((pair? files)
(let* ((asts (map file-to-ast files))
(status (assoc-ref %global-variables "?")))
(exit status)))
(let ((asts (map file-to-ast files)))
(if parse? (map pretty-print asts)
(for-each run asts))
(exit (script-status))))
(#t (let* ((HOME (string-append (getenv "HOME") "/.gash_history"))
(thunk (lambda ()
(let loop ((line (readline (prompt))))
(when (not (eof-object? line))
(let* ((ast (string-to-ast line)))
(let* ((ast (parse-string line)))
(when (and ast
(not (string-null? line)))
(unless parse?
(run ast))
(add-history line))
(loop (let ((previous (if ast "" (string-append line "\n")))
(next (readline (if ast (prompt) "> "))))
@ -137,77 +134,6 @@ copyleft.
(newline))))))))
(thunk)))
(define (expand identifier o) ;;identifier-string -> symbol
(define (expand- o)
(let ((dollar-identifier (string-append "$" identifier)))
(match o
((? symbol?) o)
((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o))
((? list?) (map expand- o))
(_ o))))
(map expand- o))
(define (DEAD-background ast)
(match ast
(('pipeline fg rest ...) `(pipeline #f ,@rest))
(_ ast)))
(define (shell-opt? name)
(member name (string-split (assoc-ref %global-variables "SHELLOPTS") #\:)))
(define (tostring . args)
(with-output-to-string (cut map display args)))
;; transform ast -> list of expr
;; such that (map eval expr)
(define (DEAD-transform ast)
(format (current-error-port) "transform=~s\n" ast)
(match ast
(('script term "&") (list (background (transform term))))
(('script term) `(,(transform term)))
(('script terms ...) (transform terms))
(('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
(('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
((('term command)) `(,(transform command)))
((('term command) ...) (map transform command))
((('term command) (('term commands) ...)) (map transform (cons command commands)))
(('compound-list terms ...) (transform terms))
(('if-clause "if" (expression "then" consequent "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))))
(('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))
(begin ,@(transform alternative))))
(('for-clause ("for" identifier sep do-group)) #t)
(('for-clause "for" ((identifier "in" lst sep) do-group))
`(for-each (lambda (,(string->symbol identifier))
(begin ,@(expand identifier (transform do-group))))
(glob ,(transform lst))))
(('do-group "do" (command "done")) (transform command))
(('pipeline command) (pk 1) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command))))
(('pipeline command piped-commands) (pk 2) `(pipeline #t ,@(transform command) ,@(transform piped-commands)))
(('simple-command ('word (assignment name value))) `((lambda _ (let ((name ,(tostring (transform name)))
(value ,(tostring (transform value))))
(stderr "assignment: " name "=" value)
(set! global-variables (assoc-set! global-variables name (glob value)))))))
(('simple-command ('word s)) `((glob ,(transform s))))
(('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1))))
(('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2)))))
(('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))))
(('variable s) s)
(('literal s) (transform s))
(('singlequotes s) (string-concatenate `("'" ,s "'")))
(('doublequotes s) (string-concatenate `("\"" ,s "\"")))
(('backticks s) (string-concatenate `("`" ,s "`")))
(('delim ('singlequotes s ...)) (string-concatenate (map transform s)))
(('delim ('doublequotes s ...)) (string-concatenate (map transform s)))
(('delim ('backticks s ...)) (string-concatenate (map transform s)))
((('pipe _) command) (transform command))
(((('pipe _) command) ...) (map (compose car transform) command))
((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...)
(_ ast))) ;; done
(define prompt
(let* ((l (string #\001))
(r (string #\002))

127
gash/geesh.scm Normal file
View File

@ -0,0 +1,127 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash geesh)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (gash builtins)
#:use-module (gash gash)
#:use-module (gash io)
#:use-module (geesh parser)
#:export (
parse
parse-string
))
(define (parse port)
(let ((parse-tree (read-sh-all port)))
(when (> %debug-level 1)
(format (current-error-port) "parse-tree:\n")
(pretty-print parse-tree (current-error-port)))
(let ((ast (parse-tree->script parse-tree)))
(format (current-error-port) "transformed:\n")
(pretty-print ast (current-error-port))
(let* ((script (match ast
(((or 'command 'pipeline) _ ...) `(script ,ast))
((_ ...) `(script ,@ast))
(_ `(script ,ast))))
(tracing-script (annotate-tracing script)))
(when (> %debug-level 0)
(format (current-error-port) "script:\n")
(pretty-print tracing-script (current-error-port)))
tracing-script))))
(define (parse-string string)
(call-with-input-string string parse))
(define (parse-tree->script tree)
(define (transform o)
(when (> %debug-level 2)
(format (current-error-port) "transform:\n")
(pretty-print o (current-error-port)))
(match o
(('<sh-begin> body ...) `(begin ,@(map transform body)))
(('<sh-pipeline> (('<sh-pipeline> (left ...))) right)
`(pipeline ,@(map transform left) ,(transform right)))
(('<sh-pipeline> ('<sh-pipeline> (left ...) right))
`(pipeline ,@(map transform left) ,(transform right)))
(('<sh-pipeline> (left right))
`(pipeline ,(transform left) ,(transform right)))
(('<sh-exec> command) `(command ,(transform command)))
(('<sh-exec> command ...) `(command ,@(map transform command)))
(((and ref ('<sh-ref> _)) words ...)
`(word ,(transform ref) ,@(map transform words)))
(('<sh-ref> var) `(variable ,var))
(('<sh-set!> (var (and value ((? symbol?) _ ...))))
`(assignment ,(transform var) ,(transform value)))
(('<sh-set!> (var (value ...)))
`(assignment ,(transform var) (word ,@(map transform value))))
(('<sh-set!> (var value)) `(assignment ,(transform var) ,(transform value)))
(((and kwote ('<sh-quote> _)) word)
`(word ,(transform kwote) ,(transform word)))
(('<sh-quote>)
`(doublequotes ""))
(('<sh-quote> words ...)
`(doublequotes (word ,@(map transform words))))
(((and quote ('<sh-quote> _)) tail ...)
`(word ,(transform quote) ,@(map transform tail)))
(('<sh-cmd-sub> cmd) `(substitution ,(transform cmd)))
(('<sh-cond> (expression then)) `(if-clause ,(transform expression) ,(transform then)))
(('<sh-with-redirects> (('<< 0 string)) pipeline)
(let ((pipeline (pke 'pipeline (transform pipeline))))
`(pipeline (display ,(transform string))
,@(match pipeline
(('command command ...) `(,pipeline))
(('pipeline commands ...) commands)))))
(('<sh-for> (name (sequence)) body)
`(for ,(transform name)
(lambda _ (split ,(transform sequence)))
(lambda _ ,(transform body))))
(('<sh-for> (name sequence) body)
`(for ,(transform name)
(lambda _ (split ,(transform sequence)))
(lambda _ ,(transform body))))
((? string?) o)
(((? string?) _ ...) `(word ,@(map re-word o)))
((_ ...) (map transform o))
(_ o)))
(transform tree))
(define (re-word word)
(match word
((? string?) word)
(((and h (? string?)) t ...)
`(word ,h ,@(map (compose re-word parse-tree->script) t)))
(_ (parse-tree->script word))))
(define (annotate-tracing script)
(match script
(('pipeline command)
`(pipeline ,(trace (list command)) ,command))
(('pipeline commands ...)
`(pipeline ,(trace commands) ,@commands))
(('command command ...)
`(pipeline ,(trace (list script)) ,script))
((_ ...) (map annotate-tracing script))
(_ script)))

36
gash/guix-build-utils.scm
View File

@ -34,6 +34,7 @@
dump-port
file-name-predicate
find-files
grep*
grep
<grep-match>
grep-match-file-name
@ -163,17 +164,24 @@ transferred and the continuation of the transfer as a thunk."
(column grep-match-column)
(end-column grep-match-end-column))
(define (grep regexp file)
(call-with-input-file file
(lambda (in)
(let loop ((line (read-line in)) (ln 1) (matches '()))
(if (eof-object? line) (reverse matches)
(let* ((m (list-matches regexp line))
(m (and (pair? m) (car m))))
(loop (read-line in) (1+ ln)
(if m (cons (make-grep-match file
(match:string m)
ln
(match:start m)
(match:end m)) matches)
matches))))))))
(define* (grep* pattern #:key (port (current-input-port)) (file-name "<stdin>"))
;; FIXME: collect later? for scripting usage implicit collect is
;; nice; for pipeline usage not so much
(let loop ((line (read-line port)) (ln 1) (matches '()))
(if (eof-object? line) (reverse matches)
(let* ((m (list-matches pattern line))
(m (and (pair? m) (car m))))
(loop (read-line port) (1+ ln)
(if m (cons (make-grep-match file-name
(match:string m)
ln
(match:start m)
(match:end m)) matches)
matches))))))
(define (grep pattern file)
(cond ((and (string? file)
(not (equal? file "-"))) (call-with-input-file file
(lambda (in)
(grep* pattern #:port in #:file-name file))))
(else (grep* pattern))))

12
gash/job.scm
View File

@ -7,18 +7,21 @@
#:use-module (gash io)
#:use-module (gash util)
#:export (bg
#:export (
bg
fg
display-job
job-table
job?
job-add-process
job-control-init
job-debug-id
job-setup-process
job-status
jobs-command
new-job
report-jobs
wait))
wait
))
(define-record-type <process>
(make-process pid command status)
@ -67,9 +70,6 @@
(stdout "[" (job-id job) "] " (map status->state (job-status job)) "\t\t"
(job-command job)))
(define (jobs-command)
(for-each (lambda (job) (display-job job)) (reverse job-table)))
(define (job-status job)
(map process-status (job-processes job)))

141
gash/peg.scm
View File

@ -4,6 +4,7 @@
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 peg)
#:use-module (ice-9 peg codegen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
@ -13,10 +14,11 @@
#:use-module (gash environment)
#:use-module (gash gash)
#:use-module (gash io)
#:use-module (gash job)
#:use-module (gash script)
#:export (
parse
parse-string
peg-trace?
))
@ -64,6 +66,74 @@
(or (loop (car x))
(loop (cdr x)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;; WIP
(define (expand identifier o) ;;identifier-string -> symbol
(define (expand- o)
(let ((dollar-identifier (string-append "$" identifier)))
(match o
((? symbol?) o)
((? string?) (if (string=? o dollar-identifier) (string->symbol identifier) o))
((? list?) (map expand- o))
(_ o))))
(map expand- o))
(define (tostring . args)
(with-output-to-string (cut map display args)))
;; transform ast -> list of expr
;; such that (map eval expr)
(define (DEAD-transform ast)
(format (current-error-port) "transform=~s\n" ast)
(match ast
(('script term "&") (list (background (transform term))))
(('script term) `(,(transform term)))
(('script terms ...) (transform terms))
(('substitution "$(" script ")") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
(('substitution "`" script "`") (local-eval (cons 'substitute (cddr (car (transform script)))) (the-environment)))
((('term command)) `(,(transform command)))
((('term command) ...) (map transform command))
((('term command) (('term commands) ...)) (map transform (cons command commands)))
(('compound-list terms ...) (transform terms))
(('if-clause "if" (expression "then" consequent "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))))
(('if-clause "if" (expression "then" consequent ('else-part "else" alternative) "fi"))
`(if (equal? 0 (status:exit-val ,@(transform expression)))
(begin ,@(transform consequent))
(begin ,@(transform alternative))))
(('for-clause ("for" identifier sep do-group)) #t)
(('for-clause "for" ((identifier "in" lst sep) do-group))
`(for-each (lambda (,(string->symbol identifier))
(begin ,@(expand identifier (transform do-group))))
(glob ,(transform lst))))
(('do-group "do" (command "done")) (transform command))
(('pipeline command) (pk 1) (let* ((command (transform command))) (or (builtin command) `(pipeline #t ,@command))))
(('pipeline command piped-commands) (pk 2) `(pipeline #t ,@(transform command) ,@(transform piped-commands)))
(('simple-command ('word (assignment name value))) `((lambda _ (let ((name ,(tostring (transform name)))
(value ,(tostring (transform value))))
(stderr "assignment: " name "=" value)
(set! global-variables (assoc-set! global-variables name (glob value)))))))
(('simple-command ('word s)) `((glob ,(transform s))))
(('simple-command ('word s1) ('io-redirect "<<" ('here-document s2))) `((append (glob "echo") (cons "-n" (glob ,s2))) (glob ,(transform s1))))
(('simple-command ('word s1) ('word s2)) `((append (glob ,(transform s1)) (glob ,(transform s2)))))
(('simple-command ('word s1) (('word s2) ...)) `((append (glob ,(transform s1)) (append-map glob (list ,@(map transform s2))))))
(('variable s) s)
(('literal s) (transform s))
(('singlequotes s) (string-concatenate `("'" ,s "'")))
(('doublequotes s) (string-concatenate `("\"" ,s "\"")))
(('backticks s) (string-concatenate `("`" ,s "`")))
(('delim ('singlequotes s ...)) (string-concatenate (map transform s)))
(('delim ('doublequotes s ...)) (string-concatenate (map transform s)))
(('delim ('backticks s ...)) (string-concatenate (map transform s)))
((('pipe _) command) (transform command))
(((('pipe _) command) ...) (map (compose car transform) command))
((_ o) (transform o)) ;; peel the onion: (symbol (...)) -> (...)
(_ ast))) ;; done
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (parse- input)
(define label "")
(define (label-name str len pos)
@ -195,36 +265,10 @@
(define (flatten o)
(keyword-flatten '(and assignent command doublequotes for-clause literal name or pipeline singlequotes substitution word) o))
(define (parse input)
(let* ((pt (parse- input))
(foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt)))
(flat (flatten pt))
(foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat)))
(ast (transform flat))
(foo (when (> %debug-level 0) (display "ast:\n") (pretty-print ast))))
(cond ((error? ast)
(stderr "error:") (pretty-print ast (current-error-port)) #f)
((eq? ast 'script)
#t)
(else
(map (cut local-eval <> (the-environment)) ast)
ast))))
(define (unspecified? o)
(eq? o *unspecified*))
(define (trace commands)
`(xtrace
,(lambda _
(when (shell-opt? "xtrace")
(for-each
(lambda (o)
(match o
(('command (and command (? string?)) ...)
(format (current-error-port) "+ ~a\n" (string-join command)))
(_ format (current-error-port) "+ ~s <FIXME>\n" o)))
(reverse commands))))))
(define (transform ast)
(when (> %debug-level 1)
(pretty-print ast (current-error-port)))
@ -240,8 +284,10 @@
((('singlequotes _ ...) _ ...) (map transform (flatten ast)))
((('word _ ...) _ ...) (map transform (flatten ast)))
(('script ('pipeline ('command command ... (word (literal "&")))))
(background `(pipeline ',(map transform command))))
(('script o ...) `(script ,@(map transform o)))
(('script terms ...) `(script ,@(map transform terms)))
(('pipeline o ...)
(let ((commands (map transform o)))
@ -254,6 +300,7 @@
;;(('assignment a b) `(assignment ,(transform a) ',(transform b)))
;; FIXME: to quote or not?
(('assignment a) `(substitution (variable ,(transform a))))
(('assignment a b) `(assignment ,(transform a) ,(transform b)))
;; (('assignment a (and b ('literal _ ...))) `(assignment ,(transform a) ,(transform b)))
@ -261,8 +308,8 @@
;; `(assignment ,(transform a) ,(map transform b)))
(('for-clause name expr (and body ('pipeline _ ...)))
`(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,(transform body))))
(('for-clause name sequence (and body ('pipeline _ ...)))
`(for ,(transform name) (lambda _ ,(transform sequence)) (lambda _ ,(transform body))))
(('for-clause name expr body)
`(for ,(transform name) (lambda _ ,(transform expr)) (lambda _ ,@(map transform body))))
(('sequence o)
@ -290,3 +337,37 @@
(('word o) (transform o))
(('word o ...) `(string-append ,@(map transform o)))
(_ ast)))
(define (remove-shell-comments s)
(string-join (map
(lambda (s)
(let* ((n (string-index s #\#)))
(if n (string-pad-right s (string-length s) #\space 0 n)
s)))
(string-split s #\newline)) "\n"))
(define (remove-escaped-newlines s)
(reduce (lambda (next prev)
(let* ((escaped? (string-suffix? "\\" next))
(next (if escaped? (string-drop-right next 1) next))
(sep (if escaped? "" "\n")))
(string-append prev sep next)))
"" (string-split s #\newline)))
(define (parse-string string)
(let* ((pt ((compose parse- remove-escaped-newlines remove-shell-comments) string))
(foo (when (> %debug-level 1) (display "tree:\n") (pretty-print pt)))
(flat (flatten pt))
(foo (when (> %debug-level 0) (display "flat:\n") (pretty-print flat)))
(ast (transform flat))
(foo (when (> %debug-level 0) (display "ast:\n") (pretty-print ast))))
(cond ((error? ast)
(stderr "error:") (pretty-print ast (current-error-port)) #f)
((eq? ast 'script)
#t)
(else ast))))
(define (parse port)
(parse-string (read-string port)))

251
gash/script.scm Normal file
View File

@ -0,0 +1,251 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful, but WITHOUT ANY
;;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;;; details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash script)
#:use-module (ice-9 ftw)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 local-eval)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (gash bournish-commands)
#:use-module (gash builtins)
#:use-module (gash config)
#:use-module (gash environment)
#:use-module (gash gash)
#:use-module (gash guix-build-utils)
#:use-module (gash io)
#:use-module (gash job)
#:use-module (gash pipe)
#:use-module (gash util)
#:export (
background
builtin
command
doublequotes
for
glob
if-clause
ignore-error
pipeline
run
script
script-status
sequence
singlequotes
splice
split
substitution
word
xtrace
))
(define (background term)
(format (current-error-port) "background: ~s\n" term)
(match (pke 'background-term term)
(('pipeline command) (pke 'background: `(pipeline+ #f ,command)))
(_ term)))
(define (command . args)
(define (exec command)
(cond ((procedure? command) command)
((every string? command)
(let* ((program (car command))
(escape-builtin? (and (string? program) (string-prefix? "\\" program)))
(program (if escape-builtin? (string-drop program 1) program))
(command (cons program (cdr command))))
(or (builtin command #:prefer-builtin? (and %prefer-builtins?
(not escape-builtin?)))
(cut apply (compose status:exit-val system*) command))))
(else (lambda () #t))))
(exec (append-map glob args)))
(define (glob pattern)
(define (glob? pattern)
(and (string? pattern) (string-match "\\?|\\*" pattern)))
(define (glob2regex pattern)
(let* ((pattern (regexp-substitute/global #f "\\." pattern 'pre "\\." 'post))
(pattern (regexp-substitute/global #f "\\?" pattern 'pre "." 'post))
(pattern (regexp-substitute/global #f "\\*" pattern 'pre ".*" 'post)))
(make-regexp (string-append "^" pattern "$"))))
(define (glob-match regex path) ;; pattern path -> bool
(regexp-match? (regexp-exec regex path)))
(define (glob- pattern file-names)
(map (lambda (file-name)
(if (string-prefix? "./" file-name) (string-drop file-name 2) file-name))
(append-map (lambda (file-name)
(map (cut string-append (if (string=? "/" file-name) "" file-name) "/" <>)
(filter (conjoin (negate (cut string-prefix? "." <>))
(cute glob-match (glob2regex pattern) <>))
(or (scandir file-name) '()))))
file-names)))
(cond
((not pattern) '(""))
((glob? pattern) (let ((absolute? (string-prefix? "/" pattern)))
(let loop ((patterns (filter (negate string-null?) (string-split pattern #\/)))
(file-names (if absolute? '("/") '("."))))
(if (null? patterns)
file-names
(begin
(loop (cdr patterns) (glob- (car patterns) file-names)))))))
(#t (list pattern))))
(define (singlequotes . o)
(string-join o ""))
(define (doublequotes . o)
(string-join (append-map glob o) ""))
(define (sequence . args)
(format (current-error-port) "sequence args=~s\n" args)
(let ((glob (append-map glob (apply append args))))
(format (current-error-port) " => sequence glob=~s\n" glob)
glob))
(define (run ast)
(map (cut local-eval <> (the-environment)) ast))
(define (script-status)
((compose string->number variable) "?"))
(define (script . o)
o)
(define (for name sequence body)
(for-each (lambda (value)
(assignment name value)
(body))
(sequence)))
(define (split o)
((compose string-tokenize string-trim-right) o))
(define (xtrace o)
(o))
(define (word . o)
(define (flatten o)
(match o
((h t ...) (append (flatten h) (append-map flatten t)))
(_ (list o))))
(string-join (flatten o) ""))
(define-syntax-rule (substitution commands)
(with-output-to-string (lambda _ commands)))
(define-syntax-rule (ignore-error o)
(let ((errexit (shell-opt? "errexit")))
(when errexit
(set-shell-opt! "errexit" #f))
(let ((r o))
(assignment "?" "0")
(when errexit
(set-shell-opt! " errexit" #t))
r)))
(define-syntax if-clause
(lambda (x)
(syntax-case x ()
((_ expr then)
(with-syntax ((it (datum->syntax x 'it)))
#'(let ((it (ignore-error expr)))
(if (zero? it) then))))
((_ expr then else)
(with-syntax ((it (datum->syntax x 'it)))
#'(let ((it (ignore-error expr)))
(if (zero? it) then else)))))))
(define (pipeline . commands)
(define (handle job)
(when (> %debug-level 1)
(format (current-error-port) "job=~s\n" job))
(let* ((stati (cond ((job? job) (map status:exit-val (job-status job)))
((boolean? job) (list (if job 0 1)))
((number? job) (list job))
(else (list 0))))
(foo (when (> %debug-level 1)
(format (current-error-port) "stati=~s\n" stati)))
(status (if (shell-opt? "pipefail") (or (find (negate zero?) stati) 0)
(car stati)))
(pipestatus (string-append
"("
(string-join
(map (lambda (s i)
(format #f "[~a]=\"~a\"" s i))
stati
(iota (length stati))))
")")))
(assignment "PIPESTATUS" pipestatus)
(assignment "?" (number->string status))
(when (and (not (zero? status))
(shell-opt? "errexit"))
(exit status))
status))
(when (> %debug-level 1)
(format (current-error-port) "pijp: commands=~s\n" commands))
;; FIXME: after running a builtin, we still end up here with the builtin's result
;; that should probably not happen, however, cater for it here for now
(match commands
(((and (? boolean?) boolean))
(handle boolean))
(((and (? number?) number))
(handle number))
(((? unspecified?))
(handle #t))
(_ (handle (apply pipeline+ #t commands)))))
(define* (builtin ast #:key prefer-builtin?)
;; FIXME: distinguish between POSIX compliant builtins and
;; `best-effort'/`fallback'?
"Possibly modify command to use a builtin."
(when (> %debug-level 0)
(format (current-error-port) "builtin ast=~s\n" ast))
(receive (command args)
(match ast
(((and (? string?) command) args ...) (values command args))
(_ (values #f #f)))
(let ((program (and command
(cond ((string-prefix? "/" command)
(when (not (file-exists? command))
(format (current-error-port) "gash: ~a: no such file or directory\n" command))
command)
(else (PATH-search-path command))))))
;; FIXME: find some generic strerror/errno way: what about permissions and stuff?
;; after calling system* we're too late for that?
(when (> %debug-level 0)
(format (current-error-port) "command ~a => ~s ~s\n" (or program 'builtin) command args))
(cond ((and program (not prefer-builtin?))
(when (not program)
(format (current-error-port) "gash: ~a: command not found\n" command))
(when (not (access? program X_OK))
(format (current-error-port) "gash: ~a: permission denied\n" command))
#f)
((and command (or (assoc-ref %builtin-commands command)
(assoc-ref %bournish-commands command)))
=>
(lambda (command)
(if args
(apply command (map (cut local-eval <> (the-environment)) args))
(command))))
(else #f)))))

14
gash/util.scm
View File

@ -2,7 +2,11 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (disjoin conjoin))
#:export (
conjoin
disjoin
wrap-command
))
(define (disjoin . predicates)
(lambda (. arguments)
@ -11,3 +15,11 @@
(define (conjoin . predicates)
(lambda (. arguments)
(every (cut apply <> arguments) predicates)))
(define (wrap-command command name)
(lambda args
(catch #t
(cut apply command args)
(lambda (key . args)
(format (current-error-port) "~a: ~a ~a\n" name key args)
1))))

5
test.sh
View File

@ -1,11 +1,12 @@
if [ -n "$BUILD_DEBUG" ]; then
set -x
fi
SHELL=${SHELL-bin/gash}
#SHELL=${SHELL-bin/gash}
SHELL=bin/gash
for f in test/*.sh; do
echo -n "$f: "
b=test/$(basename $f .sh)
$SHELL -e $f
$SHELL --geesh -e $f
r=$?
if [ -f $b.exit ]; then
e=$(cat $b.exit)

5
test/05-assignment-doublequoted-doublequotes.sh Normal file
View File

@ -0,0 +1,5 @@
#set -x
aliaspath=alias
localedir=x
defines="-DALIASPATH=\"${aliaspath}\" -DLOCALEDIR=\"${localedir}\""
echo cc $defines

1
test/06-assignment-singlequote.sh Normal file
View File

@ -0,0 +1 @@
srcdir='.'

1
test/07-assignment-double-quote.sh Normal file
View File

@ -0,0 +1 @@
srcdir="."

1
test/08-assignment-variable-word.sh Normal file
View File

@ -0,0 +1 @@
libdir=${exec_prefix}/lib

2
test/09-compound-word.sh Normal file
View File

@ -0,0 +1,2 @@
srcdir=.
echo cc -c ${srcdir}/$file

2
test/0a-assign-substitute.sh Normal file
View File

@ -0,0 +1,2 @@
obj=ar.o
objs="$objs `basename $obj`"

3
test/0b-command-compound-word.sh Normal file
View File

@ -0,0 +1,3 @@
CC=echo
file=ar.o
$CC -I${srcdir} $file

4
test/10-if.sh Normal file
View File

@ -0,0 +1,4 @@
if true; then
exit 0
fi
exit 1

4
test/11-if-false.sh Normal file
View File

@ -0,0 +1,4 @@
if false; then
exit 1
fi
exit 0

0
test/08-assignment-susbtitution.sh → test/30-assignment-substitution.sh
View File

1
test/30-eval.sh Normal file
View File

@ -0,0 +1 @@
eval echo 0

2
test/31-eval-echo-variable.sh Normal file
View File

@ -0,0 +1,2 @@
bar=SHELL
eval echo '$'$bar

3
test/32-for-substitute.sh Normal file
View File

@ -0,0 +1,3 @@
for file in `echo ar.o arscan.o`; do
echo compiling ${file}...
done

1
test/35-assignment-eval-echo.sh Normal file
View File

@ -0,0 +1 @@
exec_prefix=`eval echo ${prefix}`

2
test/assign2.sh
View File

@ -1 +1,3 @@
defines="-DALIASPATH=\"${aliaspath}\" -"
echo defines:$defines

5
test/for-split-sequence.sh Normal file
View File

@ -0,0 +1,5 @@
one=1
two_n_halve=
for i in 0 $one 2 $two_n_halve 3 ""; do
echo $i;
done

3
test/for.sh Normal file
View File

@ -0,0 +1,3 @@
for i in 0 1 2; do
echo $i;
done

3
test/if.sh
View File

@ -1,3 +0,0 @@
if [ x"$y" != x ]; then
echo boo
fi

1
test/iohere.sh
View File

@ -1,4 +1,3 @@
cat <<EOF
foobar
EOF