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

Globalize the environment module 

Instead of passing around references to the environment, just treat it
as a global.  The old way was just the remains of an idea to make the
environment immutable and keep the interpreter from manipulating any
global state.  By making everything global and mutable, we will have
less impedance mismatch with POSIX going forward.

The following changelog is only a sketch, since nearly every function
has changed.

* geesh/environment.scm: Replace this module with one that treats the
environment as a global resource.
* tests/environment.scm: Delete file.
* Makefile.am: Remove it from the list of tests.
* geesh/shell.scm, geesh/eval.scm, geesh/repl.scm, geesh/word.scm,
geesh/built-ins/break.scm, geesh/built-ins/continue.scm,
geesh/built-ins/echo.scm, geesh/built-ins/export.scm,
geesh/built-ins/false.scm, geesh/built-ins/read.scm,
geesh/built-ins/readonly.scm, geesh/built-ins/set.scm,
geesh/built-ins/true.scm, geesh/built-ins/unset.scm: Remove 'env'
parameters and use the new environment module.
* .dir-locals.el: Update indentation of functions that no longer take
an 'env' parameter and add with-arguments, with-environ, and
with-variables from the new environment module.
* tests/shell.scm, tests/word.scm: Update environment creation and
manipulation in tests.
This commit is contained in:
Timothy Sample 2018-11-25 00:47:09 -05:00
parent dd64f22361
commit 4ef6907851
20 changed files with 719 additions and 766 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.dir-locals.el
View File

@ -9,8 +9,12 @@
(eval . (put '<sh-with-redirects> 'scheme-indent-function 1)) (eval . (put '<sh-with-redirects> 'scheme-indent-function 1))
(eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1)) (eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1))
(eval . (put 'make-script 'scheme-indent-function 1)) (eval . (put 'make-script 'scheme-indent-function 1))
(eval . (put 'sh:for 'scheme-indent-function 2)) (eval . (put 'sh:for 'scheme-indent-function 1))
(eval . (put 'sh:subshell 'scheme-indent-function 1)) (eval . (put 'sh:subshell 'scheme-indent-function 0))
(eval . (put 'sh:substitute-command 'scheme-indent-function 1)) (eval . (put 'sh:substitute-command 'scheme-indent-function 0))
(eval . (put 'sh:with-redirects 'scheme-indent-function 2)) (eval . (put 'sh:with-redirects 'scheme-indent-function 1))
(eval . (put 'with-environment-arguments 'scheme-indent-function 2))))) (eval . (put 'call-with-break 'scheme-indent-function 0))
(eval . (put 'call-with-continue 'scheme-indent-function 0))
(eval . (put 'with-arguments 'scheme-indent-function 1))
(eval . (put 'with-environ 'scheme-indent-function 1))
(eval . (put 'with-variables 'scheme-indent-function 1)))))

1
Makefile.am
View File

@ -66,7 +66,6 @@ bin_SCRIPTS = \
scripts/geesh scripts/geesh
TESTS = \ TESTS = \
tests/environment.scm \
tests/lexer.scm \ tests/lexer.scm \
tests/parser.scm \ tests/parser.scm \
tests/pattern.scm \ tests/pattern.scm \

8
geesh/built-ins/break.scm
View File

@ -25,12 +25,12 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
(let* ((arg (and (pair? args) (car args))) (let* ((arg (and (pair? args) (car args)))
(n (string->number (or arg "1")))) (n (string->number (or arg "1"))))
(if (and arg (or (not n) (not (exact-integer? n)) (< n 1))) (if (and arg (or (not n) (not (exact-integer? n)) (< n 1)))
1 1
(let ((break-prompt (environment-break-prompt env))) (begin
;; Since we do not return, we have to set the status here. ;; Since we do not return, we have to set the status here.
(set-environment-status! env 0) (set-status! 0)
(abort-to-prompt break-prompt (1- n)))))) (break (1- n))))))

8
geesh/built-ins/continue.scm
View File

@ -25,12 +25,12 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
(let* ((arg (and (pair? args) (car args))) (let* ((arg (and (pair? args) (car args)))
(n (string->number (or arg "1")))) (n (string->number (or arg "1"))))
(if (and arg (or (not n) (not (exact-integer? n)) (< n 1))) (if (and arg (or (not n) (not (exact-integer? n)) (< n 1)))
1 1
(let ((continue-prompt (environment-continue-prompt env))) (begin
;; Since we do not return, we have to set the status here. ;; Since we do not return, we have to set the status here.
(set-environment-status! env 0) (set-status! 0)
(abort-to-prompt continue-prompt (1- n)))))) (continue (1- n))))))

2
geesh/built-ins/echo.scm
View File

@ -25,7 +25,7 @@
;;; ;;;
;;; Code: ;;; Code:
(define (echo env . args) (define (echo . args)
(let* ((n? (and (pair? args) (string=? (car args) "-n"))) (let* ((n? (and (pair? args) (string=? (car args) "-n")))
(args (if n? (cdr args) args))) (args (if n? (cdr args) args)))
(display (string-join args " ")) (display (string-join args " "))

4
geesh/built-ins/export.scm
View File

@ -27,12 +27,12 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
(match args (match args
(("-p") (throw 'not-implemented "export -p")) (("-p") (throw 'not-implemented "export -p"))
(_ (for-each (lambda (assignment) (_ (for-each (lambda (assignment)
(call-with-values (lambda () (split-assignment assignment)) (call-with-values (lambda () (split-assignment assignment))
(lambda (name value) (lambda (name value)
(set-var-export! env name value)))) (set-exported! name value))))
args) args)
0))) 0)))

2
geesh/built-ins/false.scm
View File

@ -24,5 +24,5 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
1) 1)

4
geesh/built-ins/read.scm
View File

@ -27,8 +27,8 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
(match (read-line (current-input-port)) (match (read-line (current-input-port))
((? eof-object?) 1) ((? eof-object?) 1)
(str (set-var! env (car args) str) (str (setvar! (car args) str)
0))) 0)))

4
geesh/built-ins/readonly.scm
View File

@ -27,12 +27,12 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
(match args (match args
(("-p") (throw 'not-implemented "readonly -p")) (("-p") (throw 'not-implemented "readonly -p"))
(_ (for-each (lambda (assignment) (_ (for-each (lambda (assignment)
(call-with-values (lambda () (split-assignment assignment)) (call-with-values (lambda () (split-assignment assignment))
(lambda (name value) (lambda (name value)
(set-var-read-only! env name value)))) (set-read-only! name value))))
args) args)
0))) 0)))

5
geesh/built-ins/set.scm
View File

@ -27,7 +27,8 @@
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
(match args (match args
(("--" . args) (set-environment-arguments! env args)) (("--" . args)
(set-program-arguments (cons (car (program-arguments)) args)))
(_ (throw 'not-implemented (string-join (cons "set" args)))))) (_ (throw 'not-implemented (string-join (cons "set" args))))))

2
geesh/built-ins/true.scm
View File

@ -24,5 +24,5 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
0) 0)

6
geesh/built-ins/unset.scm
View File

@ -26,12 +26,12 @@
;;; ;;;
;;; Code: ;;; Code:
(define (main env . args) (define (main . args)
(match args (match args
(("-f" . names) (("-f" . names)
(delete-environment-functions! env names) (for-each unsetfun! names)
0) 0)
((or ("-v" . names) ((or ("-v" . names)
names) names)
(delete-environment-vars! env names) (for-each unsetvar! names)
0))) 0)))

402
geesh/environment.scm
View File

@ -17,176 +17,286 @@
;;; along with Geesh. If not, see <http://www.gnu.org/licenses/>. ;;; along with Geesh. If not, see <http://www.gnu.org/licenses/>.
(define-module (geesh environment) (define-module (geesh environment)
#:use-module (ice-9 hash-table)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:export (<environment> #:export (get-status
make-environment set-status!
environment? getvar
var-ref setvar!
var-ref* unsetvar!
set-var! exported?
set-var-export! set-exported!
set-var-read-only! read-only?
delete-environment-vars! set-read-only!
environment->environ with-variables
environ->alist get-environ
environment-status with-environ
set-environment-status! getfun
environment-function-ref defun!
define-environment-function! unsetfun!
delete-environment-functions! with-arguments
environment-arguments call-with-continue
set-environment-arguments! continue
with-environment-arguments call-with-break
environment-break-prompt break
environment-continue-prompt)) *fd-count*
fd->current-port))
;;; Commentary: ;;; Commentary:
;;; ;;;
;;; This module contains data structures and functions for the ;;; This module contains functions to inspect and manipulate the
;;; environment of the Shell language. ;;; environment of the Shell language.
;;; ;;;
;;; Code: ;;; Code:
(define-record-type <variable>
(make-variable value export? read-only?) ;;; Status.
variable?
(value variable-value)
(export? variable-exported?)
(read-only? variable-read-only?))
(define-record-type <environment> (define *status* 0)
(%make-environment vars functions arguments status
break-prompt continue-prompt)
environment?
(vars environment-vars set-environment-vars!)
(functions environment-functions set-environment-functions!)
(arguments environment-arguments set-environment-arguments!)
(status environment-status set-environment-status!)
(break-prompt environment-break-prompt)
(continue-prompt environment-continue-prompt))
(define* (make-environment vars #:optional (arguments '())) (define (get-status)
;; In order to insure that each pair in the 'vars' alist is mutable, "Return the current status."
;; we copy each one into a new list. *status*)
(%make-environment (map (match-lambda
((key . val)
(cons key (make-variable val #t #f))))
vars)
'()
arguments
0
(make-prompt-tag)
(make-prompt-tag)))
(define (var-ref env name) (define (set-status! n)
"Get the value of the variable @var{name} in @var{env}. If "Set the current status."
@var{name} is unset, return @code{#f}." (set! *status* n))
(and=> (assoc-ref (environment-vars env) name)
(match-lambda
(($ <variable> value _ _) value))))
(define (var-ref* env name)
"Get the value of the variable @var{name} in @var{env}. If ;;; Variables.
@var{name} is unset return @code{\"\"}."
(or (var-ref env name) ""))
(define (set-var! env name val) (define (environ->alist env)
"Set the variable @var{name} to @var{val} in @var{env}." "Convert @var{environ} (a value of the type returned by
(match (assoc-ref (environment-vars env) name) @code{environ}) to an alist."
(#f (set-environment-vars!
env (acons name (make-variable val #f #f)
(environment-vars env))))
(($ <variable> _ export? read-only?)
(when read-only? (throw 'variable-assignment-error))
(set-environment-vars!
env (acons name (make-variable val export? #f)
(environment-vars env))))))
(define* (set-var-export! env name #:optional val)
"Set the export attribute for variable @var{name} in @var{env}. If
@var{val} is specified, update the variable's value as well."
(match (assoc-ref (environment-vars env) name)
(#f (set-environment-vars! env (acons name (make-variable val #t #f)
(environment-vars env))))
(($ <variable> value export? read-only?)
(when (and read-only? val) (throw 'variable-assignment-error))
(set-environment-vars!
env (acons name (make-variable (or val value) #t read-only?)
(environment-vars env))))))
(define* (set-var-read-only! env name #:optional val)
"Set the read-only attribute for variable @var{name} in @var{env}.
If @var{val} is specified, update the variable's value as well."
(match (assoc-ref (environment-vars env) name)
(#f (set-environment-vars! env (acons name (make-variable val #f #t)
(environment-vars env))))
(($ <variable> value export? read-only?)
(when (and read-only? val) (throw 'variable-assignment-error))
(set-environment-vars!
env (acons name (make-variable (or val value) export? #t)
(environment-vars env))))))
(define (delete-environment-vars! env names)
(set-environment-vars! env (remove (match-lambda
((key . _) (member key names)))
(environment-vars env))))
(define* (environment->environ env #:optional (bindings '()))
"Convert the environment variables from @var{env} into a list of
@code{\"name=value\"} strings (an @dfn{environ}). If @var{bindings}
is set to a list of pairs of strings, those name-value pairs take
precedence over the ones in @var{env}."
(let ((exported (filter-map (match-lambda
((name . ($ <variable> val export? _))
(and export? val `(,name . ,val))))
(environment-vars env))))
(let loop ((env-vars (append bindings exported))
(acc '())
(seen '()))
(match env-vars
(((name . value) . rest)
(if (member name seen)
(loop rest acc seen)
(loop rest
(cons (string-append name "=" value) acc)
(cons name seen))))
(() acc)))))
(define (environ->alist environ)
(define (string-split-1 str char_pred) (define (string-split-1 str char_pred)
(and=> (string-index str char_pred) (and=> (string-index str char_pred)
(lambda (index) (lambda (index)
`(,(substring str 0 index) . ,(substring str (1+ index)))))) `(,(substring str 0 index) . ,(substring str (1+ index))))))
(filter-map (cut string-split-1 <> #\=) environ)) (filter-map (cut string-split-1 <> #\=) env))
(define (environment-function-ref env name) (define *variables*
"Get the function named @var{name} in @var{env}. If there is no (alist->hash-table
such function, return @code{#f}." (map (match-lambda
(assoc-ref (environment-functions env) name)) ((name . value) `(,name . ,(vector value #t #f))))
(environ->alist (environ)))))
(define (define-environment-function! env name proc) (define (exported? name)
"Make @var{name} refer to @var{proc} in @var{env}." "Check if the variable @var{name} has been exported."
(set-environment-functions! env (acons name proc (match (hash-ref *variables* name)
(environment-functions env)))) (#(_ exported? _) exported?)
(_ #f)))
(define (delete-environment-functions! env . names) (define* (set-exported! name #:optional value)
(set-environment-functions! env (remove (match-lambda "Export the variable @var{name}. If the optional parameter
((key . _) (member key names))) @var{value} is provided, update the variable's value as well."
(environment-functions env)))) (match (hash-ref *variables* name)
((? vector? vec)
(vector-set! vec 1 #t)
(when value
(vector-set! vec 0 value)))
(v (hash-set! *variables* name (vector (or value v) #t #f)))))
(define (with-environment-arguments env arguments thunk) (define (read-only? name)
"Call @var{thunk} with the arguments in @var{env} set to "Check if the variable @var{name} has been marked read-only."
@var{arguments}." (match (hash-ref *variables* name)
(let ((saved-arguments #f)) (#(_ _ read-only?) read-only?)
(_ #f)))
(define* (set-read-only! name #:optional value)
"Mark the variable @var{name} as read-only. If the optional
parameter @var{value} is provided, update the variable's value as
well."
(match (hash-ref *variables* name)
((? vector? vec)
(vector-set! vec 2 #t)
(when value
(vector-set! vec 0 value)))
(v (hash-set! *variables* name (vector (or value v) #f #t)))))
(define* (getvar name #:optional dflt)
"Return the value of the variable @var{name}. If it does not exist
and @var{dflt} is provided, return @var{dflt}. Otherwise, return
@code{#f}."
(match (hash-ref *variables* name dflt)
(#(value _ _) value)
(value value)))
(define (setvar! name value)
"Set the variable @var{name} to @var{value}. If @var{value} is
@code{#f}, the variable will be removed from the set of current
variables. If @var{name} has been marked read-only, an exception will
be thrown."
(match (hash-ref *variables* name)
((? vector? vec)
(when (vector-ref vec 2)
(scm-error
'shell-error "setvar!"
"Attempted to assign the read-only only variable \"~A\"."
`(,name)
'(variable-assignment-error)))
(if value
(vector-set! vec 0 value)
(hash-remove! *variables* name)))
(_ (if value
(hash-set! *variables* name value)
(hash-remove! *variables* name)))))
(define (unsetvar! name)
"Remove the variable @var{name} from the set of current variables."
(setvar! name #f))
(define (with-variables variables thunk)
"Call @var{thunk} in a dynamic extent in which the set of current
variables contains only @var{variables}. The previous set of current
variables is unaffected by any changes made from within the dynamic
extent of @var{thunk}."
(let ((outside-variables #f)
(inside-variables (alist->hash-table variables)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(set! saved-arguments (environment-arguments env)) (set! outside-variables *variables*)
(set-environment-arguments! env arguments)) (set! *variables* inside-variables))
thunk thunk
(lambda () (lambda ()
(let ((tmp saved-arguments)) (set! inside-variables *variables*)
(set! saved-arguments (environment-arguments env)) (set! outside-variables *variables*)))))
(set-environment-arguments! env tmp))))))
(define* (get-environ #:optional (bindings '()))
"Return a value that represents the set of current variables is
suitable for passing to @code{environ}. If @var{bindings} is set,
consider them as part of the set of current variables."
(let ((exported (hash-fold (lambda (name v acc)
(match v
(#(value #t _)
(cons `(,name . ,value) acc))
(_ acc)))
'()
*variables*)))
(map (match-lambda
((name . value) (string-append name "=" value)))
(delete-duplicates!
(append bindings exported)
(lambda (x y)
(string=? (car x) (car y)))))))
(define (with-environ env thunk)
"Call @var{thunk} in a dynamic extent in which the environment (the
regular @code{getenv}/@code{setenv} one -- not the Geesh one) has been
set to @var{env} (a value suitable for passing to @code{environ}."
(let ((outside-env #f)
(inside-env env))
(dynamic-wind
(lambda ()
(set! outside-env (environ))
(environ inside-env))
thunk
(lambda ()
(set! inside-env (environ))
(environ outside-env)))))
;;; Functions.
(define *functions* (make-hash-table))
(define (getfun name)
"Return the function @var{name}. If it does not exist, return
@code{#f}."
(hash-ref *functions* name))
(define (defun! name proc)
"Define the function @var{name} to be @var{proc} (a procedure that
takes a variable number of arguments)."
(hash-set! *functions* name proc))
(define (unsetfun! name)
"Remove the function @var{name} from the set of current functions."
(hash-remove! *functions* name))
;;; Arguments.
(define (with-arguments args thunk)
"Call @var{thunk} in a dynamic extent in which the current arguments
list (as obtained by calling @code{program-arguments}) is set to
@var{args}. The previous arguments list is unaffected by any changes
made from within the dynamic extent of @var{thunk}."
(let ((outside-args #f)
(inside-args args))
(dynamic-wind
(lambda ()
(set! outside-args (program-arguments))
(set-program-arguments inside-args))
thunk
(lambda ()
(set! inside-args (program-arguments))
(set-program-arguments outside-args)))))
;;; Prompts
(define *continue-tag* (make-prompt-tag))
(define (call-with-continue thunk)
"Call @var{thunk} in such a way that a call to @code{continue} will
exit the dynamic extent of @var{thunk}."
(call-with-prompt *continue-tag*
thunk
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt *continue-tag* (1- n)))))))
(define* (continue #:optional (n 0))
"Exit to the closest invocation of @code{call-with-continue}. If
@var{n} is set, exit to the @math{n + 1}th closest invocation."
(abort-to-prompt *continue-tag* n))
(define *break-tag* (make-prompt-tag))
(define (call-with-break thunk)
"Call @var{thunk} in such a way that a call to @code{break} will
exit the dynamic extent of @var{thunk}."
(call-with-prompt *break-tag*
thunk
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt *break-tag* (1- n)))))))
(define* (break #:optional (n 0))
"Exit to the closest invocation of @code{call-with-break}. If
@var{n} is set, exit to the @math{n + 1}th closest invocation."
(abort-to-prompt *break-tag* n))
;;; Files.
(define *fd-count* 10)
(define current-3-port (make-parameter #f))
(define current-4-port (make-parameter #f))
(define current-5-port (make-parameter #f))
(define current-6-port (make-parameter #f))
(define current-7-port (make-parameter #f))
(define current-8-port (make-parameter #f))
(define current-9-port (make-parameter #f))
(define fd->current-port
(let ((cps (vector current-input-port
current-output-port
current-error-port
current-3-port
current-4-port
current-5-port
current-6-port
current-7-port
current-8-port
current-9-port)))
(lambda (fd)
"Return the current port (e.g. @code{current-input-port})
corresponding to the the Shell file descriptor @var{fd}. The value of
@var{fd} must be a nonnegative integer less than @code{*fd-count*}."
(vector-ref cps fd))))

124
geesh/eval.scm
View File

@ -31,17 +31,17 @@
;;; ;;;
;;; Code: ;;; Code:
(define* (eval-word env word #:key (output 'fields) (rhs-tildes? #f)) (define* (eval-word word #:key (output 'fields) (rhs-tildes? #f))
(parameterize ((eval-cmd-sub (lambda (exps) (parameterize ((eval-cmd-sub (lambda (exps)
(sh:substitute-command env (sh:substitute-command
(lambda () (lambda ()
(for-each (cut eval-sh env <>) exps)))))) (for-each eval-sh exps))))))
(expand-word env word #:output output #:rhs-tildes? rhs-tildes?))) (expand-word word #:output output #:rhs-tildes? rhs-tildes?)))
(define (eval-redir env redir) (define (eval-redir redir)
"Evaluate the redirect @var{redir} in environment @var{env}." "Evaluate the redirect @var{redir}."
(match-let* (((op fd word) redir) (match-let* (((op fd word) redir)
(field (eval-word env word #:output 'string))) (field (eval-word word #:output 'string)))
(match op (match op
((or '>& '<&) ((or '>& '<&)
(let ((n (string->number field))) (let ((n (string->number field)))
@ -51,127 +51,123 @@
(else (throw 'bad-dup))))) (else (throw 'bad-dup)))))
(_ `(,op ,fd ,field))))) (_ `(,op ,fd ,field)))))
(define (exp->thunk env exp) (define (exp->thunk exp)
(lambda () (eval-sh env exp))) (lambda () (eval-sh exp)))
(define (exps->thunk env exps) (define (exps->thunk exps)
(lambda () (eval-sh env `(<sh-begin> ,@exps)))) (lambda () (eval-sh `(<sh-begin> ,@exps))))
(define (eval-sh env exp) (define (eval-sh exp)
"Evaluate the Shell expression @var{exp} in the context of the Shell "Evaluate the Shell expression @var{exp}."
environment @var{env}."
(match exp (match exp
(('<sh-and> exp1 exp2) (('<sh-and> exp1 exp2)
(sh:and env (exp->thunk env exp1) (exp->thunk env exp2))) (sh:and (exp->thunk exp1) (exp->thunk exp2)))
(('<sh-begin> . sub-exps) (('<sh-begin> . sub-exps)
(for-each (cut eval-sh env <>) sub-exps)) (for-each eval-sh sub-exps))
(('<sh-case> word (pattern-lists . sub-exp-lists) ...) (('<sh-case> word (pattern-lists . sub-exp-lists) ...)
(let ((value (eval-word env word #:output 'string))) (let ((value (eval-word word #:output 'string)))
(apply sh:case env value (apply sh:case value
(map (lambda (patterns sub-exps) (map (lambda (patterns sub-exps)
`(,(map (cut eval-word env <> #:output 'pattern) `(,(map (cut eval-word <> #:output 'pattern)
patterns) patterns)
,(exps->thunk env sub-exps))) ,(exps->thunk sub-exps)))
pattern-lists pattern-lists
sub-exp-lists)))) sub-exp-lists))))
(('<sh-cond> (test-exps . sub-exp-lists) ..1) (('<sh-cond> (test-exps . sub-exp-lists) ..1)
(apply sh:cond env (apply sh:cond
(map (lambda (test-exp sub-exps) (map (lambda (test-exp sub-exps)
`(,(match test-exp `(,(match test-exp
('<sh-else> #t) ('<sh-else> #t)
(exp (exp->thunk env exp))) (exp (exp->thunk exp)))
,(exps->thunk env sub-exps))) ,(exps->thunk sub-exps)))
test-exps test-exps
sub-exp-lists))) sub-exp-lists)))
(('<sh-defun> name . sub-exps) (('<sh-defun> name . sub-exps)
(let ((proc (lambda (env . args) (let ((proc (lambda args
(eval-sh env `(<sh-begin> ,@sub-exps))))) (eval-sh `(<sh-begin> ,@sub-exps)))))
(define-environment-function! env name proc))) (defun! name proc)))
(('<sh-exec> words ..1) (('<sh-exec> words ..1)
(let ((args (append-map (cut eval-word env <>) words))) (let ((args (append-map eval-word words)))
(match args (match args
((name . args) (apply sh:exec env name args)) ((name . args) (apply sh:exec name args))
(() #f)))) (() #f))))
(('<sh-exec-let> ((names var-words) ..1) cmd-words ..1) (('<sh-exec-let> ((names var-words) ..1) cmd-words ..1)
(let* ((args (append-map (cut eval-word env <>) cmd-words)) (let* ((args (append-map eval-word cmd-words))
(bindings (map (lambda (name word) (bindings (map (lambda (name word)
`(,name . ,(eval-word env word `(,name . ,(eval-word word
#:output 'string #:output 'string
#:rhs-tildes? #t))) #:rhs-tildes? #t)))
names var-words))) names var-words)))
(match args (match args
((name . args) (apply sh:exec-let env bindings name args)) ((name . args) (apply sh:exec-let bindings name args))
(() (for-each (match-lambda (() (for-each (match-lambda
((name . value) (set-var! env name value))) ((name . value) (setvar! name value)))
bindings))))) bindings)))))
(('<sh-for> (name (words ...)) . sub-exps) (('<sh-for> (name (words ...)) . sub-exps)
(sh:for env `(,name ,(append-map (cut eval-word env <>) words)) (sh:for `(,name ,(append-map eval-word words))
(exps->thunk env sub-exps))) (exps->thunk sub-exps)))
(('<sh-not> exp) (('<sh-not> exp)
(sh:not env (exp->thunk env exp))) (sh:not (exp->thunk exp)))
(('<sh-or> exp1 exp2) (('<sh-or> exp1 exp2)
(sh:or env (exp->thunk env exp1) (exp->thunk env exp2))) (sh:or (exp->thunk exp1) (exp->thunk exp2)))
(('<sh-pipeline> cmd*s ..1) (('<sh-pipeline> cmd*s ..1)
(apply sh:pipeline env (map (cut exp->thunk env <>) cmd*s))) (apply sh:pipeline (map exp->thunk cmd*s)))
(('<sh-set!> (names words) ..1) (('<sh-set!> (names words) ..1)
(for-each (lambda (name word) (for-each (lambda (name word)
(set-var! env name (eval-word env word (setvar! name (eval-word word
#:output 'string #:output 'string
#:rhs-tildes? #t))) #:rhs-tildes? #t)))
names words)) names words))
(('<sh-subshell> . sub-exps) (('<sh-subshell> . sub-exps)
(sh:subshell env (exps->thunk env sub-exps))) (sh:subshell (exps->thunk sub-exps)))
(('<sh-while> test-exp sub-exps ..1) (('<sh-while> test-exp sub-exps ..1)
(sh:while env (exp->thunk env test-exp) (exps->thunk env sub-exps))) (sh:while (exp->thunk test-exp) (exps->thunk sub-exps)))
(('<sh-with-redirects> (redirs ..1) sub-exp) (('<sh-with-redirects> (redirs ..1) sub-exp)
(match sub-exp (match sub-exp
;; For "simple commands" we have to observe a special order of ;; For "simple commands" we have to observe a special order of
;; evaluation: first command words, then redirects, and finally ;; evaluation: first command words, then redirects, and finally
;; assignment words. ;; assignment words.
(('<sh-exec> words ..1) (('<sh-exec> words ..1)
(let ((args (append-map (cut eval-word env <>) words))) (let ((args (append-map eval-word words)))
(match (false-if-exception (match (false-if-exception (map eval-redir redirs))
(map (cut eval-redir env <>) redirs)) (#f (set-status! 1))
(#f (set-environment-status! env 1))
(redirs (redirs
(match args (match args
;; This built-in, called with no arguments, is a very ;; This built-in, called with no arguments, is a very
;; special case. We need to treat the redirects ;; special case. We need to treat the redirects
;; directly rather than pass them to ;; directly rather than pass them to
;; 'sh:with-redirects'. ;; 'sh:with-redirects'.
(("exec") (sh:set-redirects env redirs)) (("exec") (sh:set-redirects redirs))
((name . args) ((name . args)
(sh:with-redirects env redirs (sh:with-redirects redirs
(lambda () (lambda ()
(apply sh:exec env name args)))) (apply sh:exec name args))))
(() #f)))))) (() #f))))))
(('<sh-exec-let> ((names var-words) ..1) cmd-words ..1) (('<sh-exec-let> ((names var-words) ..1) cmd-words ..1)
(let ((args (append-map (cut eval-word env <>) cmd-words))) (let ((args (append-map eval-word cmd-words)))
(match (false-if-exception (match (false-if-exception (map eval-redir redirs))
(map (cut eval-redir env <>) redirs)) (#f (set-status! 1))
(#f (set-environment-status! env 1))
(redirs (redirs
(let ((bindings (map (lambda (name word) (let ((bindings (map (lambda (name word)
`(,name . ,(eval-word env word `(,name . ,(eval-word word
#:output 'string #:output 'string
#:rhs-tildes? #t))) #:rhs-tildes? #t)))
names var-words))) names var-words)))
(match args (match args
;; See the '<sh-exec>' case for why this built-in is ;; See the '<sh-exec>' case for why this built-in is
;; treated specially. ;; treated specially.
(("exec") (sh:set-redirects env redirs)) (("exec") (sh:set-redirects redirs))
((name . args) ((name . args)
(sh:with-redirects env redirs (sh:with-redirects redirs
(lambda () (lambda ()
(apply sh:exec-let env bindings name args)))) (apply sh:exec-let bindings name args))))
(() (for-each (match-lambda (() (for-each (match-lambda
((name . value) (set-var! env name value))) ((name . value) (setvar! name value)))
bindings)))))))) bindings))))))))
(_ (match (false-if-exception (_ (match (false-if-exception (map eval-redir redirs))
(map (cut eval-redir env <>) redirs)) (#f (set-status! 1))
(#f (set-environment-status! env 1))
(redirs (redirs
(sh:with-redirects env redirs (sh:with-redirects redirs
(exp->thunk env sub-exp))))))) (exp->thunk sub-exp)))))))
(('<sh-until> test-exp sub-exps ..1) (('<sh-until> test-exp sub-exps ..1)
(sh:until env (exp->thunk env test-exp) (exps->thunk env sub-exps))))) (sh:until (exp->thunk test-exp) (exps->thunk sub-exps)))))

9
geesh/repl.scm
View File

@ -30,10 +30,9 @@
;;; Code: ;;; Code:
(define (run-repl) (define (run-repl)
(let loop ((env (make-environment (environ->alist (environ)))) (let loop ((exp (read-sh (current-input-port))))
(exp (read-sh (current-input-port))))
(if (eof-object? exp) (if (eof-object? exp)
(environment-status env) (get-status)
(begin (begin
(eval-sh env exp) (eval-sh exp)
(loop env (read-sh (current-input-port))))))) (loop (read-sh (current-input-port)))))))

201
geesh/shell.scm
View File

@ -29,31 +29,6 @@
;;; ;;;
;;; Code: ;;; Code:
(define *fd-count* 10)
(define current-3-port (make-parameter #f))
(define current-4-port (make-parameter #f))
(define current-5-port (make-parameter #f))
(define current-6-port (make-parameter #f))
(define current-7-port (make-parameter #f))
(define current-8-port (make-parameter #f))
(define current-9-port (make-parameter #f))
(define (fd->current-port fd)
"Return the current port (e.g. @code{current-input-port})
corresponding to the the Shell file descriptor @var{fd}."
(match fd
(0 current-input-port)
(1 current-output-port)
(2 current-error-port)
(3 current-3-port)
(4 current-4-port)
(5 current-5-port)
(6 current-6-port)
(7 current-7-port)
(8 current-8-port)
(9 current-9-port)))
(define (install-current-ports!) (define (install-current-ports!)
"Install all current ports into their usual file descriptors. For "Install all current ports into their usual file descriptors. For
example, if @code{current-input-port} is a @code{file-port?}, make the example, if @code{current-input-port} is a @code{file-port?}, make the
@ -73,12 +48,11 @@ to @file{/dev/null}."
(_ #t))) (_ #t)))
(iota *fd-count*))) (iota *fd-count*)))
(define (exec-utility env bindings path name args) (define (exec-utility bindings path name args)
"Execute @var{path} as a subprocess with environment @var{env} and "Execute @var{path} as a subprocess with extra environment variables
extra environment variables @var{bindings}. The first argument given @var{bindings}. The first argument given to the new process will be
to the new process will be @var{name}, and the rest of the arguments @var{name}, and the rest of the arguments will be @var{args}."
will be @var{args}." (let ((utility-env (get-environ bindings)))
(let ((utility-env (environment->environ env bindings)))
;; We need to flush all ports here to ensure the proper sequence ;; We need to flush all ports here to ensure the proper sequence
;; of output. Without flushing, output that we have written could ;; of output. Without flushing, output that we have written could
;; stay in a buffer while the utility (which does not know about ;; stay in a buffer while the utility (which does not know about
@ -88,7 +62,7 @@ will be @var{args}."
(0 (install-current-ports!) (0 (install-current-ports!)
(apply execle path utility-env name args)) (apply execle path utility-env name args))
(pid (match-let (((pid . status) (waitpid pid))) (pid (match-let (((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status))))))) (set-status! (status:exit-val status)))))))
(define (slashless? s) (define (slashless? s)
"Test if the string @var{s} does not contain any slashes ('/')." "Test if the string @var{s} does not contain any slashes ('/')."
@ -98,10 +72,11 @@ will be @var{args}."
"Split the search path string @var{s}." "Split the search path string @var{s}."
(if (string-null? s) '() (string-split s #\:))) (if (string-null? s) '() (string-split s #\:)))
(define (find-utility env name) (define (find-utility name)
"Search for the path of the utility @var{name} using @var{env}. If "Search for the path of the utility @var{name} using the current
search path as specified by the environment variable @code{$PATH}. If
it cannot be found, return @code{#f}." it cannot be found, return @code{#f}."
(let loop ((prefixes (split-search-path (var-ref* env "PATH")))) (let loop ((prefixes (split-search-path (getvar "PATH" ""))))
(and (pair? prefixes) (and (pair? prefixes)
(let* ((prefix (car prefixes)) (let* ((prefix (car prefixes))
(path (if (string-suffix? "/" prefix) (path (if (string-suffix? "/" prefix)
@ -111,43 +86,42 @@ it cannot be found, return @code{#f}."
path path
(loop (cdr prefixes))))))) (loop (cdr prefixes)))))))
(define (sh:exec-let env bindings name . args) (define (sh:exec-let bindings name . args)
"Find and execute @var{name} with arguments @var{args}, environment "Find and execute @var{name} with arguments @var{args} and extra
@var{env}, and extra environment variable bindings @var{bindings}." environment variable bindings @var{bindings}."
(if (slashless? name) (if (slashless? name)
(or (and=> (search-special-built-ins name) (or (and=> (search-special-built-ins name)
(lambda (proc) (lambda (proc)
(for-each (match-lambda (for-each (match-lambda
((name . value) ((name . value)
(set-var! env name value))) (setvar! name value)))
bindings) bindings)
(let ((exit-val (apply proc env args))) (let ((exit-val (apply proc args)))
(set-environment-status! env exit-val)))) (set-status! exit-val))))
(and=> (environment-function-ref env name) (and=> (getfun name)
(lambda (proc) (lambda (proc)
(with-environment-arguments env args (with-arguments (cons (car (program-arguments)) args)
(lambda () (lambda ()
(apply proc env args))))) (apply proc args)))))
(and=> (search-built-ins name) (and=> (search-built-ins name)
(lambda (proc) (lambda (proc)
;; TODO: Use 'bindings' here. ;; TODO: Use 'bindings' here.
(let ((exit-val (apply proc env args))) (let ((exit-val (apply proc args)))
(set-environment-status! env exit-val)))) (set-status! exit-val))))
(and=> (find-utility env name) (and=> (find-utility name)
(lambda (path) (lambda (path)
(exec-utility env bindings path name args))) (exec-utility bindings path name args)))
(error "Command not found.")) (error "Command not found."))
(exec-utility env bindings name name args))) (exec-utility bindings name name args)))
(define (sh:exec env name . args) (define (sh:exec name . args)
"Find and execute @var{name} with arguments @var{args} and "Find and execute @var{name} with arguments @var{args}."
environment @var{env}." (apply sh:exec-let '() name args))
(apply sh:exec-let env '() name args))
;;; Redirects. ;;; Redirects.
(define (redir->parameter+port env redir) (define (redir->parameter+port redir)
"Convert @var{redir} into a pair consisting of the current-port "Convert @var{redir} into a pair consisting of the current-port
parameter to be updated and the port that should be its new value (or parameter to be updated and the port that should be its new value (or
@code{#f} if it should be considered closed)." @code{#f} if it should be considered closed)."
@ -187,20 +161,20 @@ parameter to be updated and the port that should be its new value (or
(seek port 0 SEEK_SET) (seek port 0 SEEK_SET)
(make-parameter+port fd port))))) (make-parameter+port fd port)))))
(define (sh:set-redirects env redirs) (define (sh:set-redirects redirs)
"Put the redirects @var{redirs} into effect." "Put the redirects @var{redirs} into effect."
(let loop ((redirs redirs)) (let loop ((redirs redirs))
(match redirs (match redirs
(() #t) (() #t)
((redir . rest) ((redir . rest)
(match (false-if-exception (match (false-if-exception
(redir->parameter+port env redir)) (redir->parameter+port redir))
(#f (set-environment-status! env 1)) (#f (set-status! 1))
((parameter . port) ((parameter . port)
(parameter port) (parameter port)
(loop rest))))))) (loop rest)))))))
(define (sh:with-redirects env redirs thunk) (define (sh:with-redirects redirs thunk)
"Call @var{thunk} with the redirects @var{redirs} in effect." "Call @var{thunk} with the redirects @var{redirs} in effect."
;; This may be too clever! We need to parameterize a variable ;; This may be too clever! We need to parameterize a variable
;; number of things in a particular order, and this seems to be the ;; number of things in a particular order, and this seems to be the
@ -208,8 +182,8 @@ parameter to be updated and the port that should be its new value (or
((fold-right (lambda (redir thunk) ((fold-right (lambda (redir thunk)
(lambda () (lambda ()
(match (false-if-exception (match (false-if-exception
(redir->parameter+port env redir)) (redir->parameter+port redir))
(#f (set-environment-status! env 1)) (#f (set-status! 1))
((parameter . port) ((parameter . port)
(parameterize ((parameter port)) (parameterize ((parameter port))
(thunk)) (thunk))
@ -233,13 +207,13 @@ process."
(primitive-exit)) (primitive-exit))
(pid pid))) (pid pid)))
(define (sh:subshell env thunk) (define (sh:subshell thunk)
"Run @var{thunk} in a subshell environment." "Run @var{thunk} in a subshell environment."
(match-let* ((pid (%subshell thunk)) (match-let* ((pid (%subshell thunk))
((pid . status) (waitpid pid))) ((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status)))) (set-status! (status:exit-val status))))
(define (sh:substitute-command env thunk) (define (sh:substitute-command thunk)
"Run @var{thunk} in a subshell environment and return its output as "Run @var{thunk} in a subshell environment and return its output as
a string." a string."
(match-let* (((sink . source) (pipe)) (match-let* (((sink . source) (pipe))
@ -250,7 +224,7 @@ a string."
(close-port source) (close-port source)
(match-let ((result (string-trim-right (get-string-all sink) #\newline)) (match-let ((result (string-trim-right (get-string-all sink) #\newline))
((pid . status) (waitpid pid))) ((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status)) (set-status! (status:exit-val status))
result))) result)))
@ -280,7 +254,7 @@ for an input port and the last will have @code{#f} as an output port."
(_ (let ((pipes (map (lambda (x) (pipe)) (cdr xs)))) (_ (let ((pipes (map (lambda (x) (pipe)) (cdr xs))))
(map cons xs (swap-and-shift-pairs pipes)))))) (map cons xs (swap-and-shift-pairs pipes))))))
(define (plumb env in out thunk) (define (plumb in out thunk)
"Run @var{thunk} in a new process with @code{current-input-port} set "Run @var{thunk} in a new process with @code{current-input-port} set
to @var{in} and @code{current-output-port} set to @var{out}. If to @var{in} and @code{current-output-port} set to @var{out}. If
@var{in} or @var{out} is @code{#f}, the corresponding ``current'' port @var{in} or @var{out} is @code{#f}, the corresponding ``current'' port
@ -296,93 +270,76 @@ is left unchanged."
(when out (close-port out)) (when out (close-port out))
pid)) pid))
(define (sh:pipeline env . thunks) (define (sh:pipeline . thunks)
"Run each thunk in @var{thunks} in its own process with the output "Run each thunk in @var{thunks} in its own process with the output
of each thunk sent to the input of the next thunk." of each thunk sent to the input of the next thunk."
(let ((pids (map (match-lambda (let ((pids (map (match-lambda
((thunk . (source . sink)) ((thunk . (source . sink))
(plumb env source sink thunk))) (plumb source sink thunk)))
(make-pipes thunks)))) (make-pipes thunks))))
(unless (null? pids) (unless (null? pids)
(match-let* ((pid (last pids)) (match-let* ((pid (last pids))
((pid . status) (waitpid pid))) ((pid . status) (waitpid pid)))
(set-environment-status! env (status:exit-val status)))))) (set-status! (status:exit-val status))))))
;;; Boolean expressions. ;;; Boolean expressions.
(define (sh:and env thunk1 thunk2) (define (sh:and thunk1 thunk2)
"Run @var{thunk1} then, if the @code{$?} variable is zero in @var{env}, "Run @var{thunk1} and if it exits with status zero, run
run @var{thunk2}." @var{thunk2}."
(thunk1) (thunk1)
(when (= (environment-status env) 0) (when (= (get-status) 0)
(thunk2))) (thunk2)))
(define (sh:or env thunk1 thunk2) (define (sh:or thunk1 thunk2)
"Run @var{thunk1} then, if the @code{$?} variable is nonzero in "Run @var{thunk1} and if it exits with a nonzero status, run
@var{env}, run @var{thunk2}." @var{thunk2}."
(thunk1) (thunk1)
(unless (= (environment-status env) 0) (unless (= (get-status) 0)
(thunk2))) (thunk2)))
(define (sh:not env thunk) (define (sh:not thunk)
"Run @var{thunk} and then invert the @code{$?} variable in @var{env}." "Run @var{thunk}, inverting its exit status."
(thunk) (thunk)
(let ((inverted-status (if (= (environment-status env) 0) 1 0))) (let ((inverted-status (if (= (get-status) 0) 1 0)))
(set-environment-status! env inverted-status))) (set-status! inverted-status)))
;;; Loops. ;;; Loops.
(define (sh:for env bindings thunk) (define (sh:for bindings thunk)
"Run @var{thunk} for each binding in @var{bindings}. The value of "Run @var{thunk} for each binding in @var{bindings}. The value of
@var{bindings} have the form @code{(@var{name} (@var{value} ...))}." @var{bindings} have the form @code{(@var{name} (@var{value} ...))}."
(set-environment-status! env 0) (set-status! 0)
(match-let ((break-prompt (environment-break-prompt env)) (match-let (((name (values ...)) bindings))
(continue-prompt (environment-continue-prompt env)) (call-with-break
((name (values ...)) bindings))
(call-with-prompt break-prompt
(lambda () (lambda ()
(for-each (lambda (value) (for-each (lambda (value)
(set-var! env name value) (setvar! name value)
(call-with-prompt continue-prompt (call-with-continue thunk))
thunk values)))))
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt continue-prompt (1- n)))))))
values))
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt break-prompt (1- n))))))))
(define (sh:while env test-thunk thunk) (define (sh:while test-thunk thunk)
(let ((break-prompt (environment-break-prompt env)) (call-with-break
(continue-prompt (environment-continue-prompt env))) (lambda ()
(call-with-prompt break-prompt (let loop ((last-status 0))
(lambda () (test-thunk)
(let loop ((last-status 0)) (cond
(test-thunk) ((= (get-status) 0)
(cond (thunk)
((= (environment-status env) 0) (loop (get-status)))
(thunk) (else
(loop (environment-status env))) (set-status! last-status)))))))
(else
(set-environment-status! env last-status)))))
(lambda (cont n)
(when (> n 0)
(false-if-exception
(abort-to-prompt break-prompt (1- n))))))))
(define (sh:until env test-thunk thunk) (define (sh:until test-thunk thunk)
(sh:while env (lambda () (sh:not env test-thunk)) thunk)) (sh:while (lambda () (sh:not test-thunk)) thunk))
;;; Conditionals. ;;; Conditionals.
(define (sh:case env value . cases) (define (sh:case value . cases)
(set-environment-status! env 0) (set-status! 0)
(let loop ((cases cases)) (let loop ((cases cases))
(match cases (match cases
(() #t) (() #t)
@ -391,8 +348,8 @@ run @var{thunk2}."
(thunk) (thunk)
(loop tail)))))) (loop tail))))))
(define (sh:cond env . cases) (define (sh:cond . cases)
(set-environment-status! env 0) (set-status! 0)
(let loop ((cases cases)) (let loop ((cases cases))
(match cases (match cases
(() #t) (() #t)
@ -400,6 +357,6 @@ run @var{thunk2}."
(thunk)) (thunk))
(((test-thunk thunk) . tail) (((test-thunk thunk) . tail)
(test-thunk) (test-thunk)
(if (= (environment-status env) 0) (if (= (get-status) 0)
(thunk) (thunk)
(loop tail)))))) (loop tail))))))

73
geesh/word.scm
View File

@ -218,84 +218,77 @@ string, the separator is derived from @var{ifs} using
"Check if @var{str} is a non-null string." "Check if @var{str} is a non-null string."
(and (string? str) (not (string-null? str)))) (and (string? str) (not (string-null? str))))
(define (parameter-ref env name) (define* (parameter-ref name #:optional dflt)
"Get the value of the variable or special parameter @var{name} in "Get the value of the variable or special parameter @var{name} from
@var{env}. If @var{name} is unset, return @code{#f}." the environment. If @var{name} is unset, return @code{#f}."
(match name (match name
("@" `(<sh-at> ,(environment-arguments env))) ("@" `(<sh-at> ,(cdr (program-arguments))))
("*" (let* ((ifs (or (var-ref env "IFS") ("*" (let* ((ifs (or (getvar "IFS")
(string #\space #\tab #\newline))) (string #\space #\tab #\newline)))
(sep (argument-separator ifs))) (sep (argument-separator ifs)))
(string-join (environment-arguments env) sep))) (string-join (cdr (program-arguments)) sep)))
("?" (number->string (environment-status env))) ("?" (number->string (get-status)))
(_ (var-ref env name)))) (_ (getvar name dflt))))
(define (parameter-ref* env name) (define (word->qword word)
"Get the value of the variable or special parameter @var{name} in
@var{env}. If @var{name} is unset, return @code{\"\"}."
(or (parameter-ref env name) ""))
(define (word->qword env word)
"Convert @var{word} into a qword by resolving all parameter, command, "Convert @var{word} into a qword by resolving all parameter, command,
and arithmetic substitions using the environment @var{env}." and arithmetic substitions."
(match word (match word
((? string?) ((? string?)
word) word)
(('<sh-quote> quoted-word) (('<sh-quote> quoted-word)
`(<sh-quote> ,(word->qword env quoted-word))) `(<sh-quote> ,(word->qword quoted-word)))
(('<sh-cmd-sub> . exps) (('<sh-cmd-sub> . exps)
((eval-cmd-sub) exps)) ((eval-cmd-sub) exps))
(('<sh-ref> name) (('<sh-ref> name)
(parameter-ref* env name)) (parameter-ref name ""))
(('<sh-ref-or> name default) (('<sh-ref-or> name default)
(or (parameter-ref env name) (or (parameter-ref name)
(word->qword env (or default "")))) (word->qword (or default ""))))
(('<sh-ref-or*> name default) (('<sh-ref-or*> name default)
(let ((value (parameter-ref env name))) (let ((value (parameter-ref name)))
(if (string-not-null? value) (if (string-not-null? value)
value value
(word->qword env (or default ""))))) (word->qword (or default "")))))
(('<sh-ref-or!> name default) (('<sh-ref-or!> name default)
(or (parameter-ref env name) (or (parameter-ref name)
(let ((new-value (expand-word env (or default "") (let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t))) #:output 'string #:rhs-tildes? #t)))
(set-var! env name new-value) (setvar! name new-value)
new-value))) new-value)))
(('<sh-ref-or!*> name default) (('<sh-ref-or!*> name default)
(let ((value (parameter-ref env name))) (let ((value (parameter-ref name)))
(if (string-not-null? value) (if (string-not-null? value)
value value
(let ((new-value (expand-word env (or default "") (let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t))) #:output 'string #:rhs-tildes? #t)))
(set-var! env name new-value) (setvar! name new-value)
new-value)))) new-value))))
(('<sh-ref-assert> name message) (error "Not implemented")) (('<sh-ref-assert> name message) (error "Not implemented"))
(('<sh-ref-assert*> name message) (error "Not implemented")) (('<sh-ref-assert*> name message) (error "Not implemented"))
(('<sh-ref-and> name value) (('<sh-ref-and> name value)
(if (string-not-null? (parameter-ref env name)) (if (string-not-null? (parameter-ref name))
(word->qword env (or value "")) (word->qword (or value ""))
"")) ""))
(('<sh-ref-and*> name value) (('<sh-ref-and*> name value)
(or (and (parameter-ref env name) (or (and (parameter-ref name)
(word->qword env (or value ""))) (word->qword (or value "")))
"")) ""))
(('<sh-ref-except-min> name pattern) (error "Not implemented")) (('<sh-ref-except-min> name pattern) (error "Not implemented"))
(('<sh-ref-except-max> name pattern) (error "Not implemented")) (('<sh-ref-except-max> name pattern) (error "Not implemented"))
(('<sh-ref-skip-min> name pattern) (error "Not implemented")) (('<sh-ref-skip-min> name pattern) (error "Not implemented"))
(('<sh-ref-skip-max> name pattern) (error "Not implemented")) (('<sh-ref-skip-max> name pattern) (error "Not implemented"))
(('<sh-ref-length> name) (('<sh-ref-length> name)
(number->string (string-length (parameter-ref* env name)))) (number->string (string-length (parameter-ref name ""))))
(_ (map (cut word->qword env <>) word)))) (_ (map word->qword word))))
(define* (expand-word env word #:key (output 'fields) (rhs-tildes? #f)) (define* (expand-word word #:key (output 'fields) (rhs-tildes? #f))
"Expand @var{word} into a list of fields using the environment "Expand @var{word} into a list of fields."
@var{env}."
;; The value of '$IFS' may depend on side-effects performed during ;; The value of '$IFS' may depend on side-effects performed during
;; 'word->qword', so use 'let*' here. ;; 'word->qword', so use 'let*' here.
(let* ((qword (word->qword env word)) (let* ((qword (word->qword word))
(ifs (or (and env (var-ref env "IFS")) (ifs (getvar "IFS" (string #\space #\tab #\newline)))
(string #\space #\tab #\newline))) (pwd (getvar "PWD")))
(pwd (and env (var-ref env "PWD"))))
(match output (match output
('fields (if pwd ('fields (if pwd
(append-map (cut expand-pathnames <> pwd ifs) (append-map (cut expand-pathnames <> pwd ifs)

111
tests/environment.scm
View File

@ -1,111 +0,0 @@
;;; The Geesh Shell Interpreter
;;; Copyright 2018 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Geesh.
;;;
;;; Geesh 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.
;;;
;;; Geesh 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 Geesh. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-environment)
#:use-module (geesh environment)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (tests automake))
;;; Commentary:
;;;
;;; Tests for the environment module.
;;;
;;; Code:
(test-begin "environment")
;;;
;;; Variables.
;;;
(test-equal "Stores existing variables"
"bar"
(let ((env (make-environment '(("FOO" . "bar")))))
(var-ref env "FOO")))
(test-equal "Stores new variables"
"bar"
(let ((env (make-environment '())))
(set-var! env "FOO" "bar")
(var-ref env "FOO")))
(test-equal "Updates variables"
"baz"
(let ((env (make-environment '(("FOO" . "bar")))))
(set-var! env "FOO" "baz")
(var-ref env "FOO")))
(test-equal "Returns '#f' for unset variables"
#f
(let ((env (make-environment '())))
(var-ref env "FOO")))
;;;
;;; Making and reading 'environs'.
;;;
(define (subset? lst1 lst2)
"Test if @var{lst1} is a subset of @var{lst2}."
(every (lambda (x) (member x lst2)) lst1))
(define (set=? lst1 lst2)
"Test if @var{lst1} is @code{equal?} to @var{lst2} without respect
to order."
(and (subset? lst1 lst2)
(subset? lst2 lst1)))
(test-equal "Creates environ from empty environment"
'()
(let ((env (make-environment '())))
(environment->environ env)))
(test-assert "Creates environ from environment"
(let* ((env (make-environment '(("FOO" . "abc")
("BAR" . "def"))))
(environ (environment->environ env)))
(set=? environ '("FOO=abc" "BAR=def"))))
(test-assert "Creates environ from empty environment and bindings"
(let* ((env (make-environment '()))
(bindings '(("FOO" . "abc")
("BAR" . "def")))
(environ (environment->environ env bindings)))
(set=? environ '("FOO=abc" "BAR=def"))))
(test-assert "Creates environ from environment and bindings"
(let* ((env (make-environment '(("FOO" . "abc")
("BAZ" . "ghi"))))
(bindings '(("BAR" . "def")
("QUUX" . "jkl")))
(environ (environment->environ env bindings)))
(set=? environ '("FOO=abc" "BAR=def" "BAZ=ghi" "QUUX=jkl"))))
(test-assert "Bindings override environment when creating an environ"
(let* ((env (make-environment '(("FOO" . "abc")
("BAR" . "def"))))
(bindings '(("FOO" . "ghi")))
(environ (environment->environ env bindings)))
(set=? environ '("FOO=ghi" "BAR=def"))))
(test-assert "Creates an alist from an environ"
(let* ((environ '("FOO=abc" "BAR=def"))
(alist (environ->alist environ)))
(set=? alist '(("FOO" . "abc") ("BAR" . "def")))))
(test-end)

221
tests/shell.scm
View File

@ -85,47 +85,46 @@
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(sentinal (string-append directory "/sentinal.txt")) (sentinal (string-append directory "/sentinal.txt")))
(env (make-environment '())))
(make-script utility (make-script utility
(with-output-to-file ,sentinal (with-output-to-file ,sentinal
(lambda () (lambda ()
(display "x")))) (display "x"))))
(sh:exec env utility) (sh:exec utility)
(file-exists? sentinal))))) (file-exists? sentinal)))))
(test-assert "Executes a utility by searching PATH" (test-assert "Executes a utility by searching PATH"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(sentinal (string-append directory "/sentinal.txt")) (sentinal (string-append directory "/sentinal.txt")))
(env (make-environment `(("PATH" . ,directory)))))
(make-script utility (make-script utility
(with-output-to-file ,sentinal (with-output-to-file ,sentinal
(lambda () (lambda ()
(display "x")))) (display "x"))))
(sh:exec env "utility") (with-variables `(("PATH" . ,directory))
(lambda () (sh:exec "utility")))
(file-exists? sentinal))))) (file-exists? sentinal)))))
(test-assert "Throws error if a utility cannot be found" (test-assert "Throws error if a utility cannot be found"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((env (make-environment `(("PATH" . ,directory))))) (with-variables `(("PATH" . ,directory))
(catch #t (lambda ()
(lambda () (catch #t
(sh:exec env "utility") (lambda ()
#f) (sh:exec "utility")
(lambda args #f)
(match args (lambda args
(('misc-error _ _ ("Command not found.") _) #t) (match args
(_ #f)))))))) (('misc-error _ _ ("Command not found.") _) #t)
(_ #f)))))))))
(test-equal "Executes regular built-ins" (test-equal "Executes regular built-ins"
"foo bar\n" "foo bar\n"
(let ((env (make-environment '()))) (with-output-to-string
(with-output-to-string (lambda ()
(lambda () (sh:exec "echo" "foo" "bar"))))
(sh:exec env "echo" "foo" "bar")))))
;;; Redirects. ;;; Redirects.
@ -136,9 +135,8 @@
"foo\n" "foo\n"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((foo (string-append directory "/foo.txt")) (let ((foo (string-append directory "/foo.txt")))
(env (make-environment '()))) (sh:with-redirects `((> 1 ,foo))
(sh:with-redirects env `((> 1 ,foo))
(lambda () (lambda ()
(display "foo") (display "foo")
(newline))) (newline)))
@ -148,9 +146,8 @@
"foo\n" "foo\n"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((foo (string-append directory "/foo.txt")) (let ((foo (string-append directory "/foo.txt")))
(env (make-environment '()))) (sh:with-redirects `((> 2 ,foo))
(sh:with-redirects env `((> 2 ,foo))
(lambda () (lambda ()
(display "foo" (current-error-port)) (display "foo" (current-error-port))
(newline (current-error-port)))) (newline (current-error-port))))
@ -161,14 +158,13 @@
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt")) (foo (string-append directory "/foo.txt")))
(env (make-environment '())))
(make-script utility (make-script utility
(display "foo") (display "foo")
(newline)) (newline))
(sh:with-redirects env `((> 1 ,foo)) (sh:with-redirects `((> 1 ,foo))
(lambda () (lambda ()
(sh:exec env utility))) (sh:exec utility)))
(call-with-input-file foo get-string-all))))) (call-with-input-file foo get-string-all)))))
(test-equal "Redirects external standard error to file" (test-equal "Redirects external standard error to file"
@ -176,14 +172,13 @@
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt")) (foo (string-append directory "/foo.txt")))
(env (make-environment '())))
(make-script utility (make-script utility
(display "foo" (current-error-port)) (display "foo" (current-error-port))
(newline (current-error-port))) (newline (current-error-port)))
(sh:with-redirects env `((> 2 ,foo)) (sh:with-redirects `((> 2 ,foo))
(lambda () (lambda ()
(sh:exec env utility))) (sh:exec utility)))
(call-with-input-file foo get-string-all))))) (call-with-input-file foo get-string-all)))))
(test-equal "Redirects built-in standard input from file" (test-equal "Redirects built-in standard input from file"
@ -191,13 +186,12 @@
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((foo (string-append directory "/foo.txt")) (let ((foo (string-append directory "/foo.txt"))
(output (string-append directory "/output.txt")) (output (string-append directory "/output.txt")))
(env (make-environment '())))
(with-output-to-file foo (with-output-to-file foo
(lambda () (lambda ()
(display "foo") (display "foo")
(newline))) (newline)))
(sh:with-redirects env `((< 0 ,foo)) (sh:with-redirects `((< 0 ,foo))
(lambda () (lambda ()
(with-output-to-file output (with-output-to-file output
(lambda () (lambda ()
@ -210,8 +204,7 @@
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt")) (foo (string-append directory "/foo.txt"))
(output (string-append directory "/output.txt")) (output (string-append directory "/output.txt")))
(env (make-environment '())))
(with-output-to-file foo (with-output-to-file foo
(lambda () (lambda ()
(display "foo") (display "foo")
@ -221,9 +214,9 @@
(with-output-to-file ,output (with-output-to-file ,output
(lambda () (lambda ()
(display (get-string-all (current-input-port)))))) (display (get-string-all (current-input-port))))))
(sh:with-redirects env `((< 0 ,foo)) (sh:with-redirects `((< 0 ,foo))
(lambda () (lambda ()
(sh:exec env utility))) (sh:exec utility)))
(call-with-input-file output get-string-all))))) (call-with-input-file output get-string-all)))))
;; These next two tests are non-deterministic, so we need to allow ;; These next two tests are non-deterministic, so we need to allow
@ -234,9 +227,8 @@
(test-assert "Redirects built-in standard error to standard output" (test-assert "Redirects built-in standard error to standard output"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((foo (string-append directory "/foo.txt")) (let ((foo (string-append directory "/foo.txt")))
(env (make-environment '()))) (sh:with-redirects `((> 1 ,foo) (>& 2 1))
(sh:with-redirects env `((> 1 ,foo) (>& 2 1))
(lambda () (lambda ()
(display "foo") (display "foo")
(newline) (newline)
@ -250,16 +242,15 @@
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt")) (foo (string-append directory "/foo.txt")))
(env (make-environment '())))
(make-script utility (make-script utility
(display "foo") (display "foo")
(newline) (newline)
(display "bar" (current-error-port)) (display "bar" (current-error-port))
(newline (current-error-port))) (newline (current-error-port)))
(sh:with-redirects env `((> 1 ,foo) (>& 2 1)) (sh:with-redirects `((> 1 ,foo) (>& 2 1))
(lambda () (lambda ()
(sh:exec env utility))) (sh:exec utility)))
(let ((result (call-with-input-file foo get-string-all))) (let ((result (call-with-input-file foo get-string-all)))
(or (string=? result "foo\nbar\n") (or (string=? result "foo\nbar\n")
(string=? result "bar\nfoo\n"))))))) (string=? result "bar\nfoo\n")))))))
@ -268,13 +259,12 @@
"foo\nbar\n" "foo\nbar\n"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((foo (string-append directory "/foo.txt")) (let ((foo (string-append directory "/foo.txt")))
(env (make-environment '())))
(with-output-to-file foo (with-output-to-file foo
(lambda () (lambda ()
(display "foo") (display "foo")
(newline))) (newline)))
(sh:with-redirects env `((>> 1 ,foo)) (sh:with-redirects `((>> 1 ,foo))
(lambda () (lambda ()
(display "bar") (display "bar")
(newline))) (newline)))
@ -282,31 +272,28 @@
(test-equal "Redirects here-document to standard input" (test-equal "Redirects here-document to standard input"
"foo\n" "foo\n"
(let ((env (make-environment '()))) (with-output-to-string
(with-output-to-string (lambda ()
(lambda () (sh:with-redirects '((<< 0 "foo\n"))
(sh:with-redirects env '((<< 0 "foo\n")) (lambda ()
(lambda () (display (get-string-all (current-input-port))))))))
(display (get-string-all (current-input-port)))))))))
(test-equal "Redirects work with string ports" (test-equal "Redirects work with string ports"
"foo\n" "foo\n"
(let ((env (make-environment '()))) (with-input-from-string "bar\n"
(with-input-from-string "bar\n" (lambda ()
(lambda () (setvbuf (current-input-port) 'none)
(setvbuf (current-input-port) 'none) (with-output-to-string
(with-output-to-string (lambda ()
(lambda () (sh:with-redirects '((<< 0 "foo\n"))
(sh:with-redirects env '((<< 0 "foo\n")) (lambda ()
(lambda () (display (get-string-all (current-input-port))))))))))
(display (get-string-all (current-input-port)))))))))))
(test-equal "Does not use buffered input from current-input-port" (test-equal "Does not use buffered input from current-input-port"
"foo\n" "foo\n"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((bar-baz (string-append directory "/bar-baz.txt")) (let ((bar-baz (string-append directory "/bar-baz.txt")))
(env (make-environment '())))
(with-output-to-file bar-baz (with-output-to-file bar-baz
(lambda () (lambda ()
(display "bar\nbaz\n"))) (display "bar\nbaz\n")))
@ -316,7 +303,7 @@
(get-line (current-input-port)) (get-line (current-input-port))
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(sh:with-redirects env '((<< 0 "foo\n")) (sh:with-redirects '((<< 0 "foo\n"))
(lambda () (lambda ()
(display (get-string-all (current-input-port))))))))))))) (display (get-string-all (current-input-port)))))))))))))
@ -324,21 +311,19 @@
"foo\n" "foo\n"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((foo (string-append directory "/foo.txt")) (let ((foo (string-append directory "/foo.txt")))
(env (make-environment '()))) (sh:with-redirects `((> 1 ,foo) (<< 0 "foo\n"))
(sh:with-redirects env `((> 1 ,foo) (<< 0 "foo\n"))
(lambda () (lambda ()
(display (get-string-all (current-input-port))))) (display (get-string-all (current-input-port)))))
(call-with-input-file foo get-string-all))))) (call-with-input-file foo get-string-all)))))
(test-equal "Uses last here-document specified" (test-equal "Uses last here-document specified"
"foo\n" "foo\n"
(let ((env (make-environment '()))) (with-output-to-string
(with-output-to-string (lambda ()
(lambda () (sh:with-redirects '((<< 0 "bar\n") (<< 0 "foo\n"))
(sh:with-redirects env '((<< 0 "bar\n") (<< 0 "foo\n")) (lambda ()
(lambda () (display (get-string-all (current-input-port))))))))
(display (get-string-all (current-input-port)))))))))
;; TODO: Read-write tests, closing tests, clobbering tests. ;; TODO: Read-write tests, closing tests, clobbering tests.
@ -347,11 +332,12 @@
(test-equal "Subshells cannot change variables" (test-equal "Subshells cannot change variables"
"foo" "foo"
(let ((env (make-environment '(("x" . "foo"))))) (with-variables '(("x" . "foo"))
(sh:subshell env (lambda ()
(lambda () (sh:subshell
(set-var! env "x" "bar"))) (lambda ()
(var-ref env "x"))) (setvar! "x" "bar")))
(getvar "x"))))
;; TODO: Test other means of manipulating the environment and exit ;; TODO: Test other means of manipulating the environment and exit
;; statuses. ;; statuses.
@ -361,45 +347,40 @@
(test-equal "Substitutes output from built-in" (test-equal "Substitutes output from built-in"
"foo" "foo"
(let ((env (make-environment '()))) (sh:substitute-command
(sh:substitute-command env (lambda ()
(lambda () (display "foo"))))
(display "foo")))))
(test-equal "Substitutes output from external utilities" (test-equal "Substitutes output from external utilities"
"foo" "foo"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility")))
(env (make-environment '())))
(make-script utility (make-script utility
(display "foo")) (display "foo"))
(sh:substitute-command env (sh:substitute-command
(lambda () (lambda ()
(sh:exec env utility))))))) (sh:exec utility)))))))
(test-equal "Trailing newlines are trimmed from substitutions" (test-equal "Trailing newlines are trimmed from substitutions"
"foo" "foo"
(let ((env (make-environment '()))) (sh:substitute-command
(sh:substitute-command env (lambda ()
(lambda () (display "foo")
(display "foo") (newline))))
(newline)))))
(test-equal "Non-trailing newlines are preserved in substitutions" (test-equal "Non-trailing newlines are preserved in substitutions"
"\nfoo\nbar" "\nfoo\nbar"
(let ((env (make-environment '()))) (sh:substitute-command
(sh:substitute-command env (lambda ()
(lambda () (newline)
(newline) (display "foo")
(display "foo") (newline)
(newline) (display "bar"))))
(display "bar")))))
(test-equal "Empty substitutions produce empty strings" (test-equal "Empty substitutions produce empty strings"
"" ""
(let ((env (make-environment '()))) (sh:substitute-command noop))
(sh:substitute-command env noop)))
;; Pipelines. ;; Pipelines.
@ -408,10 +389,8 @@
"foo" "foo"
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((foo (string-append directory "/foo.txt")) (let ((foo (string-append directory "/foo.txt")))
(env (make-environment '()))) (sh:pipeline (lambda ()
(sh:pipeline env
(lambda ()
(display "foo\n")) (display "foo\n"))
(lambda () (lambda ()
(with-output-to-file foo (with-output-to-file foo
@ -425,8 +404,7 @@
(lambda (directory) (lambda (directory)
(let ((utility1 (string-append directory "utility1")) (let ((utility1 (string-append directory "utility1"))
(utility2 (string-append directory "utility2")) (utility2 (string-append directory "utility2"))
(foo (string-append directory "/foo.txt")) (foo (string-append directory "/foo.txt")))
(env (make-environment '())))
(make-script utility1 (make-script utility1
(display "foo\n")) (display "foo\n"))
(make-script utility2 (make-script utility2
@ -434,11 +412,10 @@
(with-output-to-file ,foo (with-output-to-file ,foo
(lambda () (lambda ()
(display (get-line (current-input-port)))))) (display (get-line (current-input-port))))))
(sh:pipeline env (sh:pipeline (lambda ()
(sh:exec utility1))
(lambda () (lambda ()
(sh:exec env utility1)) (sh:exec utility2)))
(lambda ()
(sh:exec env utility2)))
(call-with-input-file foo get-string-all))))) (call-with-input-file foo get-string-all)))))
(test-equal "Externals and built-ins are connected by pipelines" (test-equal "Externals and built-ins are connected by pipelines"
@ -446,13 +423,11 @@
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt")) (foo (string-append directory "/foo.txt")))
(env (make-environment '())))
(make-script utility (make-script utility
(display "foo\n")) (display "foo\n"))
(sh:pipeline env (sh:pipeline (lambda ()
(lambda () (sh:exec utility))
(sh:exec env utility))
(lambda () (lambda ()
(with-output-to-file foo (with-output-to-file foo
(lambda () (lambda ()
@ -464,18 +439,16 @@
(call-with-temporary-directory (call-with-temporary-directory
(lambda (directory) (lambda (directory)
(let ((utility (string-append directory "/utility")) (let ((utility (string-append directory "/utility"))
(foo (string-append directory "/foo.txt")) (foo (string-append directory "/foo.txt")))
(env (make-environment '())))
(make-script utility (make-script utility
(use-modules (ice-9 textual-ports)) (use-modules (ice-9 textual-ports))
(with-output-to-file ,foo (with-output-to-file ,foo
(lambda () (lambda ()
(display (get-line (current-input-port)))))) (display (get-line (current-input-port))))))
(sh:pipeline env (sh:pipeline (lambda ()
(lambda ()
(display "foo\n")) (display "foo\n"))
(lambda () (lambda ()
(sh:exec env utility))) (sh:exec utility)))
(call-with-input-file foo get-string-all))))) (call-with-input-file foo get-string-all)))))
(test-end) (test-end)

284
tests/word.scm
View File

@ -28,17 +28,6 @@
;;; ;;;
;;; Code: ;;; Code:
;; This function exists to add a layer of slippage between the
;; "environment" module and our tests. The "environment" module is
;; still under development, and it would be annoying to have to
;; rewrite all the tests.
(define* (make-test-env vars #:key (noglob? #f) (nounset? #f))
"Create a testing environment with the alist @var{vars} as the
current variables. If @var{noglob?} is set, enable the `noglob'
option. If @var{nounset?} is set, enable the `nounset' option. (See
the `set' built-in for details on these options.)"
(make-environment vars))
(test-begin "word") (test-begin "word")
@ -46,70 +35,70 @@ the `set' built-in for details on these options.)"
(test-equal "Converts a simple word (string) to a single field" (test-equal "Converts a simple word (string) to a single field"
'("foo") '("foo")
(expand-word #f "foo")) (expand-word "foo"))
(test-equal "Converts a simple word (list) to a single field" (test-equal "Converts a simple word (list) to a single field"
'("foo") '("foo")
(expand-word #f '("foo"))) (expand-word '("foo")))
(test-equal "Concatenates contiguous parts into a single field" (test-equal "Concatenates contiguous parts into a single field"
'("foobar") '("foobar")
(expand-word #f '("foo" "bar"))) (expand-word '("foo" "bar")))
(test-equal "Splits a word along unquoted spaces" (test-equal "Splits a word along unquoted spaces"
'("foo" "bar") '("foo" "bar")
(expand-word #f '("foo bar"))) (expand-word '("foo bar")))
(test-equal "Splits a word on leading space" (test-equal "Splits a word on leading space"
'("foo" "bar") '("foo" "bar")
(expand-word #f '("foo" " bar"))) (expand-word '("foo" " bar")))
(test-equal "Splits a word on trailing space" (test-equal "Splits a word on trailing space"
'("foo" "bar") '("foo" "bar")
(expand-word #f '("foo " "bar"))) (expand-word '("foo " "bar")))
(test-equal "Ignores leading spaces" (test-equal "Ignores leading spaces"
'("foo") '("foo")
(expand-word #f '(" foo"))) (expand-word '(" foo")))
(test-equal "Ignores trailing spaces" (test-equal "Ignores trailing spaces"
'("foo") '("foo")
(expand-word #f '("foo "))) (expand-word '("foo ")))
(test-equal "Treats multiple spaces as a single space" (test-equal "Treats multiple spaces as a single space"
'("foo" "bar") '("foo" "bar")
(expand-word #f '("foo bar"))) (expand-word '("foo bar")))
(test-equal "Handles multiple joins and splits" (test-equal "Handles multiple joins and splits"
'("hi_how" "are_you") '("hi_how" "are_you")
(expand-word #f '("hi_" "how are" "_you"))) (expand-word '("hi_" "how are" "_you")))
(test-equal "Handles nested lists" (test-equal "Handles nested lists"
'("foo") '("foo")
(expand-word #f '("f" ("oo")))) (expand-word '("f" ("oo"))))
;;; Quotes. ;;; Quotes.
(test-equal "Ignores spaces in quotes" (test-equal "Ignores spaces in quotes"
'("foo bar") '("foo bar")
(expand-word #f '(<sh-quote> "foo bar"))) (expand-word '(<sh-quote> "foo bar")))
(test-equal "Concatenates strings and quotes" (test-equal "Concatenates strings and quotes"
'("foo bar") '("foo bar")
(expand-word #f '("foo" (<sh-quote> " bar")))) (expand-word '("foo" (<sh-quote> " bar"))))
(test-equal "Concatenates quotes" (test-equal "Concatenates quotes"
'("foo bar") '("foo bar")
(expand-word #f '((<sh-quote> "foo") (<sh-quote> " bar")))) (expand-word '((<sh-quote> "foo") (<sh-quote> " bar"))))
(test-equal "Handles nested quotes" (test-equal "Handles nested quotes"
'("foo bar") '("foo bar")
(expand-word #f '(<sh-quote> (<sh-quote> "foo bar")))) (expand-word '(<sh-quote> (<sh-quote> "foo bar"))))
(test-equal "Splits and concatenates words and quotes" (test-equal "Splits and concatenates words and quotes"
'("foo" "bar") '("foo" "bar")
(expand-word #f '((<sh-quote> "foo") " " (<sh-quote> "bar")))) (expand-word '((<sh-quote> "foo") " " (<sh-quote> "bar"))))
;;; Tildes. ;;; Tildes.
@ -123,43 +112,51 @@ the `set' built-in for details on these options.)"
(test-equal "Resolves parameters" (test-equal "Resolves parameters"
'("foo") '("foo")
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref> "x"))) (lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Splits parameter results" (test-equal "Splits parameter results"
'("foo" "bar") '("foo" "bar")
(expand-word (make-test-env '(("x" . "foo bar"))) (with-variables '(("x" . "foo bar"))
'(<sh-ref> "x"))) (lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Resolves quoted parameters" (test-equal "Resolves quoted parameters"
'("foo") '("foo")
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-quote> (<sh-ref> "x")))) (lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
(test-equal "Ignores spaces in quoted parameters" (test-equal "Ignores spaces in quoted parameters"
'("foo bar") '("foo bar")
(expand-word (make-test-env '(("x" . "foo bar"))) (with-variables '(("x" . "foo bar"))
'(<sh-quote> (<sh-ref> "x")))) (lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
(test-equal "Treats empty variables as nothing" (test-equal "Treats empty variables as nothing"
'() '()
(expand-word (make-test-env '(("x" . ""))) (with-variables '(("x" . ""))
'(<sh-ref> "x"))) (lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Treats unset variables as nothing" (test-equal "Treats unset variables as nothing"
'() '()
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref> "x"))) (lambda ()
(expand-word '(<sh-ref> "x")))))
(test-equal "Preserves empty variables when quoted" (test-equal "Preserves empty variables when quoted"
'("") '("")
(expand-word (make-test-env '(("x" . ""))) (with-variables '(("x" . ""))
'(<sh-quote> (<sh-ref> "x")))) (lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
(test-equal "Preserves unset variables when quoted" (test-equal "Preserves unset variables when quoted"
'("") '("")
(expand-word (make-test-env '()) (with-variables '()
'(<sh-quote> (<sh-ref> "x")))) (lambda ()
(expand-word '(<sh-quote> (<sh-ref> "x"))))))
;;; Parameter operations. ;;; Parameter operations.
@ -168,103 +165,120 @@ the `set' built-in for details on these options.)"
(test-equal "Handles 'or' when parameter is set" (test-equal "Handles 'or' when parameter is set"
'("foo") '("foo")
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref-or> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-or> "x" "bar")))))
(test-equal "Handles 'or' when parameter is set and empty" (test-equal "Handles 'or' when parameter is set and empty"
'() '()
(expand-word (make-test-env '(("x" . ""))) (with-variables '(("x" . ""))
'(<sh-ref-or> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-or> "x" "bar")))))
(test-equal "Handles 'or' when parameter is unset" (test-equal "Handles 'or' when parameter is unset"
'("bar") '("bar")
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref-or> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-or> "x" "bar")))))
(test-equal "Handles 'or' fall-through without default" (test-equal "Handles 'or' fall-through without default"
'() '()
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref-or> "x" #f))) (lambda ()
(expand-word '(<sh-ref-or> "x" #f)))))
;;; or* ;;; or*
(test-equal "Handles 'or*' when parameter is set" (test-equal "Handles 'or*' when parameter is set"
'("foo") '("foo")
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref-or*> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-or*> "x" "bar")))))
(test-equal "Handles 'or*' when parameter is set and empty" (test-equal "Handles 'or*' when parameter is set and empty"
'("bar") '("bar")
(expand-word (make-test-env '(("x" . ""))) (with-variables '(("x" . ""))
'(<sh-ref-or*> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-or*> "x" "bar")))))
(test-equal "Handles 'or*' when parameter is unset" (test-equal "Handles 'or*' when parameter is unset"
'("bar") '("bar")
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref-or*> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-or*> "x" "bar")))))
(test-equal "Handles 'or*' fall-through without default" (test-equal "Handles 'or*' fall-through without default"
'() '()
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref-or*> "x" #f))) (lambda ()
(expand-word '(<sh-ref-or*> "x" #f)))))
;;; or! ;;; or!
(test-equal "Handles 'or!' when parameter is set" (test-equal "Handles 'or!' when parameter is set"
'(("foo") "foo") '(("foo") "foo")
(let ((env (make-test-env '(("x" . "foo"))))) (with-variables '(("x" . "foo"))
(list (expand-word env '(<sh-ref-or!> "x" "bar")) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!' when parameter is set and empty" (test-equal "Handles 'or!' when parameter is set and empty"
'(() "") '(() "")
(let ((env (make-test-env '(("x" . ""))))) (with-variables '(("x" . ""))
(list (expand-word env '(<sh-ref-or!> "x" "bar")) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!' when parameter is unset" (test-equal "Handles 'or!' when parameter is unset"
'(("bar") "bar") '(("bar") "bar")
(let ((env (make-test-env '()))) (with-variables '()
(list (expand-word env '(<sh-ref-or!> "x" "bar")) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!' fall-through without default" (test-equal "Handles 'or!' fall-through without default"
'(() "") '(() "")
(let ((env (make-test-env '()))) (with-variables '()
(list (expand-word env '(<sh-ref-or!> "x" #f)) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!> "x" #f))
(getvar "x")))))
;;; or!* ;;; or!*
(test-equal "Handles 'or!*' when parameter is set" (test-equal "Handles 'or!*' when parameter is set"
'(("foo") "foo") '(("foo") "foo")
(let ((env (make-test-env '(("x" . "foo"))))) (with-variables '(("x" . "foo"))
(list (expand-word env '(<sh-ref-or!*> "x" "bar")) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!*> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!*' when parameter is set and empty" (test-equal "Handles 'or!*' when parameter is set and empty"
'(("bar") "bar") '(("bar") "bar")
(let ((env (make-test-env '(("x" . ""))))) (with-variables '(("x" . ""))
(list (expand-word env '(<sh-ref-or!*> "x" "bar")) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!*> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!*' when parameter is unset" (test-equal "Handles 'or!*' when parameter is unset"
'(("bar") "bar") '(("bar") "bar")
(let ((env (make-test-env '()))) (with-variables '()
(list (expand-word env '(<sh-ref-or!*> "x" "bar")) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!*> "x" "bar"))
(getvar "x")))))
(test-equal "Handles 'or!*' fall-through without default" (test-equal "Handles 'or!*' fall-through without default"
'(() "") '(() "")
(let ((env (make-test-env '()))) (with-variables '()
(list (expand-word env '(<sh-ref-or!*> "x" #f)) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!*> "x" #f))
(getvar "x")))))
(test-equal "Does not split fields on assignment" (test-equal "Does not split fields on assignment"
'(("foo" "bar") "foo bar") '(("foo" "bar") "foo bar")
(let ((env (make-test-env '(("y" . "foo bar"))))) (with-variables '(("y" . "foo bar"))
(list (expand-word env '(<sh-ref-or!*> "x" (<sh-ref> "y"))) (lambda ()
(var-ref env "x")))) (list (expand-word '(<sh-ref-or!*> "x" (<sh-ref> "y")))
(getvar "x")))))
;;; FIXME: Test 'assert'. ;;; FIXME: Test 'assert'.
@ -272,57 +286,67 @@ the `set' built-in for details on these options.)"
(test-equal "Handles 'and' when parameter is set" (test-equal "Handles 'and' when parameter is set"
'("bar") '("bar")
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref-and> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-and> "x" "bar")))))
(test-equal "Handles 'and' when parameter is set and empty" (test-equal "Handles 'and' when parameter is set and empty"
'() '()
(expand-word (make-test-env '(("x" . ""))) (with-variables '(("x" . ""))
'(<sh-ref-and> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-and> "x" "bar")))))
(test-equal "Handles 'and' when parameter is unset" (test-equal "Handles 'and' when parameter is unset"
'() '()
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref-and> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-and> "x" "bar")))))
(test-equal "Handles 'and' fall-through without default" (test-equal "Handles 'and' fall-through without default"
'() '()
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref-and> "x" #f))) (lambda ()
(expand-word '(<sh-ref-and> "x" #f)))))
;;; and* ;;; and*
(test-equal "Handles 'and*' when parameter is set" (test-equal "Handles 'and*' when parameter is set"
'("bar") '("bar")
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref-and*> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-and*> "x" "bar")))))
(test-equal "Handles 'and*' when parameter is set and empty" (test-equal "Handles 'and*' when parameter is set and empty"
'("bar") '("bar")
(expand-word (make-test-env '(("x" . ""))) (with-variables '(("x" . ""))
'(<sh-ref-and*> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-and*> "x" "bar")))))
(test-equal "Handles 'and*' when parameter is unset" (test-equal "Handles 'and*' when parameter is unset"
'() '()
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref-and*> "x" "bar"))) (lambda ()
(expand-word '(<sh-ref-and*> "x" "bar")))))
(test-equal "Handles 'and*' fall-through without default" (test-equal "Handles 'and*' fall-through without default"
'() '()
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref-and*> "x" #f))) (lambda ()
(expand-word '(<sh-ref-and*> "x" #f)))))
;;; length ;;; length
(test-equal "Handles 'length' when parameter is set" (test-equal "Handles 'length' when parameter is set"
'("3") '("3")
(expand-word (make-test-env '(("x" . "foo"))) (with-variables '(("x" . "foo"))
'(<sh-ref-length> "x"))) (lambda ()
(expand-word '(<sh-ref-length> "x")))))
(test-equal "Handles 'length' when parameter is unset" (test-equal "Handles 'length' when parameter is unset"
'("0") '("0")
(expand-word (make-test-env '()) (with-variables '()
'(<sh-ref-length> "x"))) (lambda ()
(expand-word '(<sh-ref-length> "x")))))
;;; Command substition. ;;; Command substition.
@ -330,22 +354,22 @@ the `set' built-in for details on these options.)"
(test-equal "Resolves commands" (test-equal "Resolves commands"
'("foo") '("foo")
(parameterize ((eval-cmd-sub identity)) (parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-cmd-sub> "foo")))) (expand-word '(<sh-cmd-sub> "foo"))))
(test-equal "Splits command results" (test-equal "Splits command results"
'("foo" "bar") '("foo" "bar")
(parameterize ((eval-cmd-sub identity)) (parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-cmd-sub> "foo bar")))) (expand-word '(<sh-cmd-sub> "foo bar"))))
(test-equal "Resolves quoted commands" (test-equal "Resolves quoted commands"
'("foo") '("foo")
(parameterize ((eval-cmd-sub identity)) (parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-quote> (<sh-cmd-sub> "foo"))))) (expand-word '(<sh-quote> (<sh-cmd-sub> "foo")))))
(test-equal "Ignores spaces in quoted commands" (test-equal "Ignores spaces in quoted commands"
'("foo bar") '("foo bar")
(parameterize ((eval-cmd-sub identity)) (parameterize ((eval-cmd-sub identity))
(expand-word #f '(<sh-quote> (<sh-cmd-sub> "foo bar"))))) (expand-word '(<sh-quote> (<sh-cmd-sub> "foo bar")))))
;;; Arithmetic expansion. ;;; Arithmetic expansion.
@ -362,42 +386,50 @@ the `set' built-in for details on these options.)"
(test-equal "Respects IFS value" (test-equal "Respects IFS value"
'("foo" "bar") '("foo" "bar")
(let ((env (make-test-env '(("IFS" . "-"))))) (with-variables '(("IFS" . "-"))
(expand-word env '("foo-bar")))) (lambda ()
(expand-word '("foo-bar")))))
(test-equal "Combines multiple whitespace separators" (test-equal "Combines multiple whitespace separators"
'("foo" "bar") '("foo" "bar")
(let ((env (make-test-env '(("IFS" . " "))))) (with-variables '(("IFS" . " "))
(expand-word env '("foo bar")))) (lambda ()
(expand-word '("foo bar")))))
(test-equal "Keeps multiple non-whitespace separators" (test-equal "Keeps multiple non-whitespace separators"
'("foo" "" "bar") '("foo" "" "bar")
(let ((env (make-test-env '(("IFS" . "-"))))) (with-variables '(("IFS" . "-"))
(expand-word env '("foo--bar")))) (lambda ()
(expand-word '("foo--bar")))))
(test-equal "Combines whitespace separators with a non-whitespace separator" (test-equal "Combines whitespace separators with a non-whitespace separator"
'("foo" "bar") '("foo" "bar")
(let ((env (make-test-env '(("IFS" . "- "))))) (with-variables '(("IFS" . "- "))
(expand-word env '("foo - bar")))) (lambda ()
(expand-word '("foo - bar")))))
(test-equal "Keeps multiple non-whitespace separators with whitespace" (test-equal "Keeps multiple non-whitespace separators with whitespace"
'("foo" "" "bar") '("foo" "" "bar")
(let ((env (make-test-env '(("IFS" . "- "))))) (with-variables '(("IFS" . "- "))
(expand-word env '("foo - - bar")))) (lambda ()
(expand-word '("foo - - bar")))))
(test-equal "Splits on leading non-whitespace separator" (test-equal "Splits on leading non-whitespace separator"
'("" "foo") '("" "foo")
(let ((env (make-test-env '(("IFS" . "-"))))) (with-variables '(("IFS" . "-"))
(expand-word env '("-foo")))) (lambda ()
(expand-word '("-foo")))))
(test-equal "Does not split on trailing non-whitespace separator" (test-equal "Does not split on trailing non-whitespace separator"
'("foo") '("foo")
(let ((env (make-test-env '(("IFS" . "-"))))) (with-variables '(("IFS" . "-"))
(expand-word env '("foo-")))) (lambda ()
(expand-word '("foo-")))))
(test-equal "Makes one field for single non-whitespace separator" (test-equal "Makes one field for single non-whitespace separator"
'("") '("")
(let ((env (make-test-env '(("IFS" . "-"))))) (with-variables '(("IFS" . "-"))
(expand-word env '("-")))) (lambda ()
(expand-word '("-")))))
(test-end) (test-end)