From 4ef69078515a2715a75265bcfabf4bf0f42ace5f Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Sun, 25 Nov 2018 00:47:09 -0500 Subject: [PATCH] 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. --- .dir-locals.el | 14 +- Makefile.am | 1 - geesh/built-ins/break.scm | 8 +- geesh/built-ins/continue.scm | 8 +- geesh/built-ins/echo.scm | 2 +- geesh/built-ins/export.scm | 4 +- geesh/built-ins/false.scm | 2 +- geesh/built-ins/read.scm | 4 +- geesh/built-ins/readonly.scm | 4 +- geesh/built-ins/set.scm | 5 +- geesh/built-ins/true.scm | 2 +- geesh/built-ins/unset.scm | 6 +- geesh/environment.scm | 402 ++++++++++++++++++++++------------- geesh/eval.scm | 124 ++++++----- geesh/repl.scm | 9 +- geesh/shell.scm | 201 +++++++----------- geesh/word.scm | 73 +++---- tests/environment.scm | 111 ---------- tests/shell.scm | 221 +++++++++---------- tests/word.scm | 284 ++++++++++++++----------- 20 files changed, 719 insertions(+), 766 deletions(-) delete mode 100644 tests/environment.scm diff --git a/.dir-locals.el b/.dir-locals.el index 8140372..2aa4e8f 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -9,8 +9,12 @@ (eval . (put ' '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 'sh:for 'scheme-indent-function 2)) - (eval . (put 'sh:subshell 'scheme-indent-function 1)) - (eval . (put 'sh:substitute-command 'scheme-indent-function 1)) - (eval . (put 'sh:with-redirects 'scheme-indent-function 2)) - (eval . (put 'with-environment-arguments 'scheme-indent-function 2))))) + (eval . (put 'sh:for 'scheme-indent-function 1)) + (eval . (put 'sh:subshell 'scheme-indent-function 0)) + (eval . (put 'sh:substitute-command 'scheme-indent-function 0)) + (eval . (put 'sh:with-redirects 'scheme-indent-function 1)) + (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))))) diff --git a/Makefile.am b/Makefile.am index 1efbaa0..34e1042 100644 --- a/Makefile.am +++ b/Makefile.am @@ -66,7 +66,6 @@ bin_SCRIPTS = \ scripts/geesh TESTS = \ - tests/environment.scm \ tests/lexer.scm \ tests/parser.scm \ tests/pattern.scm \ diff --git a/geesh/built-ins/break.scm b/geesh/built-ins/break.scm index 1990dac..1ff8426 100644 --- a/geesh/built-ins/break.scm +++ b/geesh/built-ins/break.scm @@ -25,12 +25,12 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) (let* ((arg (and (pair? args) (car args))) (n (string->number (or arg "1")))) (if (and arg (or (not n) (not (exact-integer? n)) (< n 1))) 1 - (let ((break-prompt (environment-break-prompt env))) + (begin ;; Since we do not return, we have to set the status here. - (set-environment-status! env 0) - (abort-to-prompt break-prompt (1- n)))))) + (set-status! 0) + (break (1- n)))))) diff --git a/geesh/built-ins/continue.scm b/geesh/built-ins/continue.scm index ce7c3eb..e221453 100644 --- a/geesh/built-ins/continue.scm +++ b/geesh/built-ins/continue.scm @@ -25,12 +25,12 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) (let* ((arg (and (pair? args) (car args))) (n (string->number (or arg "1")))) (if (and arg (or (not n) (not (exact-integer? n)) (< n 1))) 1 - (let ((continue-prompt (environment-continue-prompt env))) + (begin ;; Since we do not return, we have to set the status here. - (set-environment-status! env 0) - (abort-to-prompt continue-prompt (1- n)))))) + (set-status! 0) + (continue (1- n)))))) diff --git a/geesh/built-ins/echo.scm b/geesh/built-ins/echo.scm index 6f15d07..0328ceb 100644 --- a/geesh/built-ins/echo.scm +++ b/geesh/built-ins/echo.scm @@ -25,7 +25,7 @@ ;;; ;;; Code: -(define (echo env . args) +(define (echo . args) (let* ((n? (and (pair? args) (string=? (car args) "-n"))) (args (if n? (cdr args) args))) (display (string-join args " ")) diff --git a/geesh/built-ins/export.scm b/geesh/built-ins/export.scm index cd06378..37b9673 100644 --- a/geesh/built-ins/export.scm +++ b/geesh/built-ins/export.scm @@ -27,12 +27,12 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) (match args (("-p") (throw 'not-implemented "export -p")) (_ (for-each (lambda (assignment) (call-with-values (lambda () (split-assignment assignment)) (lambda (name value) - (set-var-export! env name value)))) + (set-exported! name value)))) args) 0))) diff --git a/geesh/built-ins/false.scm b/geesh/built-ins/false.scm index 3742bf8..e21f21c 100644 --- a/geesh/built-ins/false.scm +++ b/geesh/built-ins/false.scm @@ -24,5 +24,5 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) 1) diff --git a/geesh/built-ins/read.scm b/geesh/built-ins/read.scm index 1a1d88f..357aec7 100644 --- a/geesh/built-ins/read.scm +++ b/geesh/built-ins/read.scm @@ -27,8 +27,8 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) (match (read-line (current-input-port)) ((? eof-object?) 1) - (str (set-var! env (car args) str) + (str (setvar! (car args) str) 0))) diff --git a/geesh/built-ins/readonly.scm b/geesh/built-ins/readonly.scm index 5a7f3e6..0781505 100644 --- a/geesh/built-ins/readonly.scm +++ b/geesh/built-ins/readonly.scm @@ -27,12 +27,12 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) (match args (("-p") (throw 'not-implemented "readonly -p")) (_ (for-each (lambda (assignment) (call-with-values (lambda () (split-assignment assignment)) (lambda (name value) - (set-var-read-only! env name value)))) + (set-read-only! name value)))) args) 0))) diff --git a/geesh/built-ins/set.scm b/geesh/built-ins/set.scm index 2d721f5..2745d95 100644 --- a/geesh/built-ins/set.scm +++ b/geesh/built-ins/set.scm @@ -27,7 +27,8 @@ ;;; Code: -(define (main env . args) +(define (main . 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)))))) diff --git a/geesh/built-ins/true.scm b/geesh/built-ins/true.scm index 4c0f05b..74f754e 100644 --- a/geesh/built-ins/true.scm +++ b/geesh/built-ins/true.scm @@ -24,5 +24,5 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) 0) diff --git a/geesh/built-ins/unset.scm b/geesh/built-ins/unset.scm index 2301799..21f0f31 100644 --- a/geesh/built-ins/unset.scm +++ b/geesh/built-ins/unset.scm @@ -26,12 +26,12 @@ ;;; ;;; Code: -(define (main env . args) +(define (main . args) (match args (("-f" . names) - (delete-environment-functions! env names) + (for-each unsetfun! names) 0) ((or ("-v" . names) names) - (delete-environment-vars! env names) + (for-each unsetvar! names) 0))) diff --git a/geesh/environment.scm b/geesh/environment.scm index 637c3f6..6063d56 100644 --- a/geesh/environment.scm +++ b/geesh/environment.scm @@ -17,176 +17,286 @@ ;;; along with Geesh. If not, see . (define-module (geesh environment) + #:use-module (ice-9 hash-table) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) - #:export ( - make-environment - environment? - var-ref - var-ref* - set-var! - set-var-export! - set-var-read-only! - delete-environment-vars! - environment->environ - environ->alist - environment-status - set-environment-status! - environment-function-ref - define-environment-function! - delete-environment-functions! - environment-arguments - set-environment-arguments! - with-environment-arguments - environment-break-prompt - environment-continue-prompt)) + #:export (get-status + set-status! + getvar + setvar! + unsetvar! + exported? + set-exported! + read-only? + set-read-only! + with-variables + get-environ + with-environ + getfun + defun! + unsetfun! + with-arguments + call-with-continue + continue + call-with-break + break + *fd-count* + fd->current-port)) ;;; Commentary: ;;; -;;; This module contains data structures and functions for the +;;; This module contains functions to inspect and manipulate the ;;; environment of the Shell language. ;;; ;;; Code: -(define-record-type - (make-variable value export? read-only?) - variable? - (value variable-value) - (export? variable-exported?) - (read-only? variable-read-only?)) + +;;; Status. -(define-record-type - (%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 *status* 0) -(define* (make-environment vars #:optional (arguments '())) - ;; In order to insure that each pair in the 'vars' alist is mutable, - ;; we copy each one into a new list. - (%make-environment (map (match-lambda - ((key . val) - (cons key (make-variable val #t #f)))) - vars) - '() - arguments - 0 - (make-prompt-tag) - (make-prompt-tag))) +(define (get-status) + "Return the current status." + *status*) -(define (var-ref env name) - "Get the value of the variable @var{name} in @var{env}. If -@var{name} is unset, return @code{#f}." - (and=> (assoc-ref (environment-vars env) name) - (match-lambda - (($ value _ _) value)))) +(define (set-status! n) + "Set the current status." + (set! *status* n)) -(define (var-ref* env name) - "Get the value of the variable @var{name} in @var{env}. If -@var{name} is unset return @code{\"\"}." - (or (var-ref env name) "")) + +;;; Variables. -(define (set-var! env name val) - "Set the variable @var{name} to @var{val} in @var{env}." - (match (assoc-ref (environment-vars env) name) - (#f (set-environment-vars! - env (acons name (make-variable val #f #f) - (environment-vars env)))) - (($ _ 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)))) - (($ 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)))) - (($ 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 . ($ 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 (environ->alist env) + "Convert @var{environ} (a value of the type returned by +@code{environ}) to an alist." (define (string-split-1 str char_pred) (and=> (string-index str char_pred) (lambda (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) - "Get the function named @var{name} in @var{env}. If there is no -such function, return @code{#f}." - (assoc-ref (environment-functions env) name)) +(define *variables* + (alist->hash-table + (map (match-lambda + ((name . value) `(,name . ,(vector value #t #f)))) + (environ->alist (environ))))) -(define (define-environment-function! env name proc) - "Make @var{name} refer to @var{proc} in @var{env}." - (set-environment-functions! env (acons name proc - (environment-functions env)))) +(define (exported? name) + "Check if the variable @var{name} has been exported." + (match (hash-ref *variables* name) + (#(_ exported? _) exported?) + (_ #f))) -(define (delete-environment-functions! env . names) - (set-environment-functions! env (remove (match-lambda - ((key . _) (member key names))) - (environment-functions env)))) +(define* (set-exported! name #:optional value) + "Export the variable @var{name}. 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 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) - "Call @var{thunk} with the arguments in @var{env} set to -@var{arguments}." - (let ((saved-arguments #f)) +(define (read-only? name) + "Check if the variable @var{name} has been marked read-only." + (match (hash-ref *variables* name) + (#(_ _ 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 (lambda () - (set! saved-arguments (environment-arguments env)) - (set-environment-arguments! env arguments)) + (set! outside-variables *variables*) + (set! *variables* inside-variables)) thunk (lambda () - (let ((tmp saved-arguments)) - (set! saved-arguments (environment-arguments env)) - (set-environment-arguments! env tmp)))))) + (set! inside-variables *variables*) + (set! outside-variables *variables*))))) + +(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)))) diff --git a/geesh/eval.scm b/geesh/eval.scm index 5d6f1f3..1aac9e0 100644 --- a/geesh/eval.scm +++ b/geesh/eval.scm @@ -31,17 +31,17 @@ ;;; ;;; 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) - (sh:substitute-command env + (sh:substitute-command (lambda () - (for-each (cut eval-sh env <>) exps)))))) - (expand-word env word #:output output #:rhs-tildes? rhs-tildes?))) + (for-each eval-sh exps)))))) + (expand-word word #:output output #:rhs-tildes? rhs-tildes?))) -(define (eval-redir env redir) - "Evaluate the redirect @var{redir} in environment @var{env}." +(define (eval-redir redir) + "Evaluate the redirect @var{redir}." (match-let* (((op fd word) redir) - (field (eval-word env word #:output 'string))) + (field (eval-word word #:output 'string))) (match op ((or '>& '<&) (let ((n (string->number field))) @@ -51,127 +51,123 @@ (else (throw 'bad-dup))))) (_ `(,op ,fd ,field))))) -(define (exp->thunk env exp) - (lambda () (eval-sh env exp))) +(define (exp->thunk exp) + (lambda () (eval-sh exp))) -(define (exps->thunk env exps) - (lambda () (eval-sh env `( ,@exps)))) +(define (exps->thunk exps) + (lambda () (eval-sh `( ,@exps)))) -(define (eval-sh env exp) - "Evaluate the Shell expression @var{exp} in the context of the Shell -environment @var{env}." +(define (eval-sh exp) + "Evaluate the Shell expression @var{exp}." (match exp ((' exp1 exp2) - (sh:and env (exp->thunk env exp1) (exp->thunk env exp2))) + (sh:and (exp->thunk exp1) (exp->thunk exp2))) ((' . sub-exps) - (for-each (cut eval-sh env <>) sub-exps)) + (for-each eval-sh sub-exps)) ((' word (pattern-lists . sub-exp-lists) ...) - (let ((value (eval-word env word #:output 'string))) - (apply sh:case env value + (let ((value (eval-word word #:output 'string))) + (apply sh:case value (map (lambda (patterns sub-exps) - `(,(map (cut eval-word env <> #:output 'pattern) + `(,(map (cut eval-word <> #:output 'pattern) patterns) - ,(exps->thunk env sub-exps))) + ,(exps->thunk sub-exps))) pattern-lists sub-exp-lists)))) ((' (test-exps . sub-exp-lists) ..1) - (apply sh:cond env + (apply sh:cond (map (lambda (test-exp sub-exps) `(,(match test-exp (' #t) - (exp (exp->thunk env exp))) - ,(exps->thunk env sub-exps))) + (exp (exp->thunk exp))) + ,(exps->thunk sub-exps))) test-exps sub-exp-lists))) ((' name . sub-exps) - (let ((proc (lambda (env . args) - (eval-sh env `( ,@sub-exps))))) - (define-environment-function! env name proc))) + (let ((proc (lambda args + (eval-sh `( ,@sub-exps))))) + (defun! name proc))) ((' words ..1) - (let ((args (append-map (cut eval-word env <>) words))) + (let ((args (append-map eval-word words))) (match args - ((name . args) (apply sh:exec env name args)) + ((name . args) (apply sh:exec name args)) (() #f)))) ((' ((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) - `(,name . ,(eval-word env word + `(,name . ,(eval-word word #:output 'string #:rhs-tildes? #t))) names var-words))) (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 - ((name . value) (set-var! env name value))) + ((name . value) (setvar! name value))) bindings))))) ((' (name (words ...)) . sub-exps) - (sh:for env `(,name ,(append-map (cut eval-word env <>) words)) - (exps->thunk env sub-exps))) + (sh:for `(,name ,(append-map eval-word words)) + (exps->thunk sub-exps))) ((' exp) - (sh:not env (exp->thunk env exp))) + (sh:not (exp->thunk exp))) ((' exp1 exp2) - (sh:or env (exp->thunk env exp1) (exp->thunk env exp2))) + (sh:or (exp->thunk exp1) (exp->thunk exp2))) ((' cmd*s ..1) - (apply sh:pipeline env (map (cut exp->thunk env <>) cmd*s))) + (apply sh:pipeline (map exp->thunk cmd*s))) ((' (names words) ..1) (for-each (lambda (name word) - (set-var! env name (eval-word env word - #:output 'string - #:rhs-tildes? #t))) + (setvar! name (eval-word word + #:output 'string + #:rhs-tildes? #t))) names words)) ((' . sub-exps) - (sh:subshell env (exps->thunk env sub-exps))) + (sh:subshell (exps->thunk sub-exps))) ((' 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))) ((' (redirs ..1) sub-exp) (match sub-exp ;; For "simple commands" we have to observe a special order of ;; evaluation: first command words, then redirects, and finally ;; assignment words. ((' words ..1) - (let ((args (append-map (cut eval-word env <>) words))) - (match (false-if-exception - (map (cut eval-redir env <>) redirs)) - (#f (set-environment-status! env 1)) + (let ((args (append-map eval-word words))) + (match (false-if-exception (map eval-redir redirs)) + (#f (set-status! 1)) (redirs (match args ;; This built-in, called with no arguments, is a very ;; special case. We need to treat the redirects ;; directly rather than pass them to ;; 'sh:with-redirects'. - (("exec") (sh:set-redirects env redirs)) + (("exec") (sh:set-redirects redirs)) ((name . args) - (sh:with-redirects env redirs + (sh:with-redirects redirs (lambda () - (apply sh:exec env name args)))) + (apply sh:exec name args)))) (() #f)))))) ((' ((names var-words) ..1) cmd-words ..1) - (let ((args (append-map (cut eval-word env <>) cmd-words))) - (match (false-if-exception - (map (cut eval-redir env <>) redirs)) - (#f (set-environment-status! env 1)) + (let ((args (append-map eval-word cmd-words))) + (match (false-if-exception (map eval-redir redirs)) + (#f (set-status! 1)) (redirs (let ((bindings (map (lambda (name word) - `(,name . ,(eval-word env word + `(,name . ,(eval-word word #:output 'string #:rhs-tildes? #t))) names var-words))) (match args ;; See the '' case for why this built-in is ;; treated specially. - (("exec") (sh:set-redirects env redirs)) + (("exec") (sh:set-redirects redirs)) ((name . args) - (sh:with-redirects env redirs + (sh:with-redirects redirs (lambda () - (apply sh:exec-let env bindings name args)))) + (apply sh:exec-let bindings name args)))) (() (for-each (match-lambda - ((name . value) (set-var! env name value))) + ((name . value) (setvar! name value))) bindings)))))))) - (_ (match (false-if-exception - (map (cut eval-redir env <>) redirs)) - (#f (set-environment-status! env 1)) + (_ (match (false-if-exception (map eval-redir redirs)) + (#f (set-status! 1)) (redirs - (sh:with-redirects env redirs - (exp->thunk env sub-exp))))))) + (sh:with-redirects redirs + (exp->thunk sub-exp))))))) ((' 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))))) diff --git a/geesh/repl.scm b/geesh/repl.scm index d52daa9..310a7e9 100644 --- a/geesh/repl.scm +++ b/geesh/repl.scm @@ -30,10 +30,9 @@ ;;; Code: (define (run-repl) - (let loop ((env (make-environment (environ->alist (environ)))) - (exp (read-sh (current-input-port)))) + (let loop ((exp (read-sh (current-input-port)))) (if (eof-object? exp) - (environment-status env) + (get-status) (begin - (eval-sh env exp) - (loop env (read-sh (current-input-port))))))) + (eval-sh exp) + (loop (read-sh (current-input-port))))))) diff --git a/geesh/shell.scm b/geesh/shell.scm index 8cd29d0..2abe35d 100644 --- a/geesh/shell.scm +++ b/geesh/shell.scm @@ -29,31 +29,6 @@ ;;; ;;; 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!) "Install all current ports into their usual file descriptors. For example, if @code{current-input-port} is a @code{file-port?}, make the @@ -73,12 +48,11 @@ to @file{/dev/null}." (_ #t))) (iota *fd-count*))) -(define (exec-utility env bindings path name args) - "Execute @var{path} as a subprocess with environment @var{env} and -extra environment variables @var{bindings}. The first argument given -to the new process will be @var{name}, and the rest of the arguments -will be @var{args}." - (let ((utility-env (environment->environ env bindings))) +(define (exec-utility bindings path name args) + "Execute @var{path} as a subprocess with extra environment variables +@var{bindings}. The first argument given to the new process will be +@var{name}, and the rest of the arguments will be @var{args}." + (let ((utility-env (get-environ bindings))) ;; We need to flush all ports here to ensure the proper sequence ;; of output. Without flushing, output that we have written could ;; stay in a buffer while the utility (which does not know about @@ -88,7 +62,7 @@ will be @var{args}." (0 (install-current-ports!) (apply execle path utility-env name args)) (pid (match-let (((pid . status) (waitpid pid))) - (set-environment-status! env (status:exit-val status))))))) + (set-status! (status:exit-val status))))))) (define (slashless? s) "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}." (if (string-null? s) '() (string-split s #\:))) -(define (find-utility env name) - "Search for the path of the utility @var{name} using @var{env}. If +(define (find-utility name) + "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}." - (let loop ((prefixes (split-search-path (var-ref* env "PATH")))) + (let loop ((prefixes (split-search-path (getvar "PATH" "")))) (and (pair? prefixes) (let* ((prefix (car prefixes)) (path (if (string-suffix? "/" prefix) @@ -111,43 +86,42 @@ it cannot be found, return @code{#f}." path (loop (cdr prefixes))))))) -(define (sh:exec-let env bindings name . args) - "Find and execute @var{name} with arguments @var{args}, environment -@var{env}, and extra environment variable bindings @var{bindings}." +(define (sh:exec-let bindings name . args) + "Find and execute @var{name} with arguments @var{args} and extra +environment variable bindings @var{bindings}." (if (slashless? name) (or (and=> (search-special-built-ins name) (lambda (proc) (for-each (match-lambda ((name . value) - (set-var! env name value))) + (setvar! name value))) bindings) - (let ((exit-val (apply proc env args))) - (set-environment-status! env exit-val)))) - (and=> (environment-function-ref env name) + (let ((exit-val (apply proc args))) + (set-status! exit-val)))) + (and=> (getfun name) (lambda (proc) - (with-environment-arguments env args + (with-arguments (cons (car (program-arguments)) args) (lambda () - (apply proc env args))))) + (apply proc args))))) (and=> (search-built-ins name) (lambda (proc) ;; TODO: Use 'bindings' here. - (let ((exit-val (apply proc env args))) - (set-environment-status! env exit-val)))) - (and=> (find-utility env name) + (let ((exit-val (apply proc args))) + (set-status! exit-val)))) + (and=> (find-utility name) (lambda (path) - (exec-utility env bindings path name args))) + (exec-utility bindings path name args))) (error "Command not found.")) - (exec-utility env bindings name name args))) + (exec-utility bindings name name args))) -(define (sh:exec env name . args) - "Find and execute @var{name} with arguments @var{args} and -environment @var{env}." - (apply sh:exec-let env '() name args)) +(define (sh:exec name . args) + "Find and execute @var{name} with arguments @var{args}." + (apply sh:exec-let '() name args)) ;;; Redirects. -(define (redir->parameter+port env redir) +(define (redir->parameter+port redir) "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 @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) (make-parameter+port fd port))))) -(define (sh:set-redirects env redirs) +(define (sh:set-redirects redirs) "Put the redirects @var{redirs} into effect." (let loop ((redirs redirs)) (match redirs (() #t) ((redir . rest) (match (false-if-exception - (redir->parameter+port env redir)) - (#f (set-environment-status! env 1)) + (redir->parameter+port redir)) + (#f (set-status! 1)) ((parameter . port) (parameter port) (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." ;; This may be too clever! We need to parameterize a variable ;; 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) (lambda () (match (false-if-exception - (redir->parameter+port env redir)) - (#f (set-environment-status! env 1)) + (redir->parameter+port redir)) + (#f (set-status! 1)) ((parameter . port) (parameterize ((parameter port)) (thunk)) @@ -233,13 +207,13 @@ process." (primitive-exit)) (pid pid))) -(define (sh:subshell env thunk) +(define (sh:subshell thunk) "Run @var{thunk} in a subshell environment." (match-let* ((pid (%subshell thunk)) ((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 a string." (match-let* (((sink . source) (pipe)) @@ -250,7 +224,7 @@ a string." (close-port source) (match-let ((result (string-trim-right (get-string-all sink) #\newline)) ((pid . status) (waitpid pid))) - (set-environment-status! env (status:exit-val status)) + (set-status! (status:exit-val status)) 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)))) (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 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 @@ -296,93 +270,76 @@ is left unchanged." (when out (close-port out)) pid)) -(define (sh:pipeline env . thunks) +(define (sh:pipeline . thunks) "Run each thunk in @var{thunks} in its own process with the output of each thunk sent to the input of the next thunk." (let ((pids (map (match-lambda ((thunk . (source . sink)) - (plumb env source sink thunk))) + (plumb source sink thunk))) (make-pipes thunks)))) (unless (null? pids) (match-let* ((pid (last pids)) ((pid . status) (waitpid pid))) - (set-environment-status! env (status:exit-val status)))))) + (set-status! (status:exit-val status)))))) ;;; Boolean expressions. -(define (sh:and env thunk1 thunk2) - "Run @var{thunk1} then, if the @code{$?} variable is zero in @var{env}, -run @var{thunk2}." +(define (sh:and thunk1 thunk2) + "Run @var{thunk1} and if it exits with status zero, run +@var{thunk2}." (thunk1) - (when (= (environment-status env) 0) + (when (= (get-status) 0) (thunk2))) -(define (sh:or env thunk1 thunk2) - "Run @var{thunk1} then, if the @code{$?} variable is nonzero in -@var{env}, run @var{thunk2}." +(define (sh:or thunk1 thunk2) + "Run @var{thunk1} and if it exits with a nonzero status, run +@var{thunk2}." (thunk1) - (unless (= (environment-status env) 0) + (unless (= (get-status) 0) (thunk2))) -(define (sh:not env thunk) - "Run @var{thunk} and then invert the @code{$?} variable in @var{env}." +(define (sh:not thunk) + "Run @var{thunk}, inverting its exit status." (thunk) - (let ((inverted-status (if (= (environment-status env) 0) 1 0))) - (set-environment-status! env inverted-status))) + (let ((inverted-status (if (= (get-status) 0) 1 0))) + (set-status! inverted-status))) ;;; Loops. -(define (sh:for env bindings thunk) +(define (sh:for bindings thunk) "Run @var{thunk} for each binding in @var{bindings}. The value of @var{bindings} have the form @code{(@var{name} (@var{value} ...))}." - (set-environment-status! env 0) - (match-let ((break-prompt (environment-break-prompt env)) - (continue-prompt (environment-continue-prompt env)) - ((name (values ...)) bindings)) - (call-with-prompt break-prompt + (set-status! 0) + (match-let (((name (values ...)) bindings)) + (call-with-break (lambda () (for-each (lambda (value) - (set-var! env name value) - (call-with-prompt continue-prompt - thunk - (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)))))))) + (setvar! name value) + (call-with-continue thunk)) + values))))) -(define (sh:while env test-thunk thunk) - (let ((break-prompt (environment-break-prompt env)) - (continue-prompt (environment-continue-prompt env))) - (call-with-prompt break-prompt - (lambda () - (let loop ((last-status 0)) - (test-thunk) - (cond - ((= (environment-status env) 0) - (thunk) - (loop (environment-status env))) - (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:while test-thunk thunk) + (call-with-break + (lambda () + (let loop ((last-status 0)) + (test-thunk) + (cond + ((= (get-status) 0) + (thunk) + (loop (get-status))) + (else + (set-status! last-status))))))) -(define (sh:until env test-thunk thunk) - (sh:while env (lambda () (sh:not env test-thunk)) thunk)) +(define (sh:until test-thunk thunk) + (sh:while (lambda () (sh:not test-thunk)) thunk)) ;;; Conditionals. -(define (sh:case env value . cases) - (set-environment-status! env 0) +(define (sh:case value . cases) + (set-status! 0) (let loop ((cases cases)) (match cases (() #t) @@ -391,8 +348,8 @@ run @var{thunk2}." (thunk) (loop tail)))))) -(define (sh:cond env . cases) - (set-environment-status! env 0) +(define (sh:cond . cases) + (set-status! 0) (let loop ((cases cases)) (match cases (() #t) @@ -400,6 +357,6 @@ run @var{thunk2}." (thunk)) (((test-thunk thunk) . tail) (test-thunk) - (if (= (environment-status env) 0) + (if (= (get-status) 0) (thunk) (loop tail)))))) diff --git a/geesh/word.scm b/geesh/word.scm index 9044389..ca44d98 100644 --- a/geesh/word.scm +++ b/geesh/word.scm @@ -218,84 +218,77 @@ string, the separator is derived from @var{ifs} using "Check if @var{str} is a non-null string." (and (string? str) (not (string-null? str)))) -(define (parameter-ref env name) - "Get the value of the variable or special parameter @var{name} in -@var{env}. If @var{name} is unset, return @code{#f}." +(define* (parameter-ref name #:optional dflt) + "Get the value of the variable or special parameter @var{name} from +the environment. If @var{name} is unset, return @code{#f}." (match name - ("@" `( ,(environment-arguments env))) - ("*" (let* ((ifs (or (var-ref env "IFS") + ("@" `( ,(cdr (program-arguments)))) + ("*" (let* ((ifs (or (getvar "IFS") (string #\space #\tab #\newline))) (sep (argument-separator ifs))) - (string-join (environment-arguments env) sep))) - ("?" (number->string (environment-status env))) - (_ (var-ref env name)))) + (string-join (cdr (program-arguments)) sep))) + ("?" (number->string (get-status))) + (_ (getvar name dflt)))) -(define (parameter-ref* env name) - "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) +(define (word->qword word) "Convert @var{word} into a qword by resolving all parameter, command, -and arithmetic substitions using the environment @var{env}." +and arithmetic substitions." (match word ((? string?) word) ((' quoted-word) - `( ,(word->qword env quoted-word))) + `( ,(word->qword quoted-word))) ((' . exps) ((eval-cmd-sub) exps)) ((' name) - (parameter-ref* env name)) + (parameter-ref name "")) ((' name default) - (or (parameter-ref env name) - (word->qword env (or default "")))) + (or (parameter-ref name) + (word->qword (or default "")))) ((' name default) - (let ((value (parameter-ref env name))) + (let ((value (parameter-ref name))) (if (string-not-null? value) value - (word->qword env (or default ""))))) + (word->qword (or default ""))))) ((' name default) - (or (parameter-ref env name) - (let ((new-value (expand-word env (or default "") + (or (parameter-ref name) + (let ((new-value (expand-word (or default "") #:output 'string #:rhs-tildes? #t))) - (set-var! env name new-value) + (setvar! name new-value) new-value))) ((' name default) - (let ((value (parameter-ref env name))) + (let ((value (parameter-ref name))) (if (string-not-null? value) value - (let ((new-value (expand-word env (or default "") + (let ((new-value (expand-word (or default "") #:output 'string #:rhs-tildes? #t))) - (set-var! env name new-value) + (setvar! name new-value) new-value)))) ((' name message) (error "Not implemented")) ((' name message) (error "Not implemented")) ((' name value) - (if (string-not-null? (parameter-ref env name)) - (word->qword env (or value "")) + (if (string-not-null? (parameter-ref name)) + (word->qword (or value "")) "")) ((' name value) - (or (and (parameter-ref env name) - (word->qword env (or value ""))) + (or (and (parameter-ref name) + (word->qword (or value ""))) "")) ((' name pattern) (error "Not implemented")) ((' name pattern) (error "Not implemented")) ((' name pattern) (error "Not implemented")) ((' name pattern) (error "Not implemented")) ((' name) - (number->string (string-length (parameter-ref* env name)))) - (_ (map (cut word->qword env <>) word)))) + (number->string (string-length (parameter-ref name "")))) + (_ (map word->qword word)))) -(define* (expand-word env word #:key (output 'fields) (rhs-tildes? #f)) - "Expand @var{word} into a list of fields using the environment -@var{env}." +(define* (expand-word word #:key (output 'fields) (rhs-tildes? #f)) + "Expand @var{word} into a list of fields." ;; The value of '$IFS' may depend on side-effects performed during ;; 'word->qword', so use 'let*' here. - (let* ((qword (word->qword env word)) - (ifs (or (and env (var-ref env "IFS")) - (string #\space #\tab #\newline))) - (pwd (and env (var-ref env "PWD")))) + (let* ((qword (word->qword word)) + (ifs (getvar "IFS" (string #\space #\tab #\newline))) + (pwd (getvar "PWD"))) (match output ('fields (if pwd (append-map (cut expand-pathnames <> pwd ifs) diff --git a/tests/environment.scm b/tests/environment.scm deleted file mode 100644 index 24d281f..0000000 --- a/tests/environment.scm +++ /dev/null @@ -1,111 +0,0 @@ -;;; The Geesh Shell Interpreter -;;; Copyright 2018 Timothy Sample -;;; -;;; 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 . - -(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) diff --git a/tests/shell.scm b/tests/shell.scm index 9150e2d..372fac2 100644 --- a/tests/shell.scm +++ b/tests/shell.scm @@ -85,47 +85,46 @@ (call-with-temporary-directory (lambda (directory) (let ((utility (string-append directory "/utility")) - (sentinal (string-append directory "/sentinal.txt")) - (env (make-environment '()))) + (sentinal (string-append directory "/sentinal.txt"))) (make-script utility (with-output-to-file ,sentinal (lambda () (display "x")))) - (sh:exec env utility) + (sh:exec utility) (file-exists? sentinal))))) (test-assert "Executes a utility by searching PATH" (call-with-temporary-directory (lambda (directory) (let ((utility (string-append directory "/utility")) - (sentinal (string-append directory "/sentinal.txt")) - (env (make-environment `(("PATH" . ,directory))))) + (sentinal (string-append directory "/sentinal.txt"))) (make-script utility (with-output-to-file ,sentinal (lambda () (display "x")))) - (sh:exec env "utility") + (with-variables `(("PATH" . ,directory)) + (lambda () (sh:exec "utility"))) (file-exists? sentinal))))) (test-assert "Throws error if a utility cannot be found" (call-with-temporary-directory (lambda (directory) - (let ((env (make-environment `(("PATH" . ,directory))))) - (catch #t - (lambda () - (sh:exec env "utility") - #f) - (lambda args - (match args - (('misc-error _ _ ("Command not found.") _) #t) - (_ #f)))))))) + (with-variables `(("PATH" . ,directory)) + (lambda () + (catch #t + (lambda () + (sh:exec "utility") + #f) + (lambda args + (match args + (('misc-error _ _ ("Command not found.") _) #t) + (_ #f))))))))) (test-equal "Executes regular built-ins" "foo bar\n" - (let ((env (make-environment '()))) - (with-output-to-string - (lambda () - (sh:exec env "echo" "foo" "bar"))))) + (with-output-to-string + (lambda () + (sh:exec "echo" "foo" "bar")))) ;;; Redirects. @@ -136,9 +135,8 @@ "foo\n" (call-with-temporary-directory (lambda (directory) - (let ((foo (string-append directory "/foo.txt")) - (env (make-environment '()))) - (sh:with-redirects env `((> 1 ,foo)) + (let ((foo (string-append directory "/foo.txt"))) + (sh:with-redirects `((> 1 ,foo)) (lambda () (display "foo") (newline))) @@ -148,9 +146,8 @@ "foo\n" (call-with-temporary-directory (lambda (directory) - (let ((foo (string-append directory "/foo.txt")) - (env (make-environment '()))) - (sh:with-redirects env `((> 2 ,foo)) + (let ((foo (string-append directory "/foo.txt"))) + (sh:with-redirects `((> 2 ,foo)) (lambda () (display "foo" (current-error-port)) (newline (current-error-port)))) @@ -161,14 +158,13 @@ (call-with-temporary-directory (lambda (directory) (let ((utility (string-append directory "/utility")) - (foo (string-append directory "/foo.txt")) - (env (make-environment '()))) + (foo (string-append directory "/foo.txt"))) (make-script utility (display "foo") (newline)) - (sh:with-redirects env `((> 1 ,foo)) + (sh:with-redirects `((> 1 ,foo)) (lambda () - (sh:exec env utility))) + (sh:exec utility))) (call-with-input-file foo get-string-all))))) (test-equal "Redirects external standard error to file" @@ -176,14 +172,13 @@ (call-with-temporary-directory (lambda (directory) (let ((utility (string-append directory "/utility")) - (foo (string-append directory "/foo.txt")) - (env (make-environment '()))) + (foo (string-append directory "/foo.txt"))) (make-script utility (display "foo" (current-error-port)) (newline (current-error-port))) - (sh:with-redirects env `((> 2 ,foo)) + (sh:with-redirects `((> 2 ,foo)) (lambda () - (sh:exec env utility))) + (sh:exec utility))) (call-with-input-file foo get-string-all))))) (test-equal "Redirects built-in standard input from file" @@ -191,13 +186,12 @@ (call-with-temporary-directory (lambda (directory) (let ((foo (string-append directory "/foo.txt")) - (output (string-append directory "/output.txt")) - (env (make-environment '()))) + (output (string-append directory "/output.txt"))) (with-output-to-file foo (lambda () (display "foo") (newline))) - (sh:with-redirects env `((< 0 ,foo)) + (sh:with-redirects `((< 0 ,foo)) (lambda () (with-output-to-file output (lambda () @@ -210,8 +204,7 @@ (lambda (directory) (let ((utility (string-append directory "/utility")) (foo (string-append directory "/foo.txt")) - (output (string-append directory "/output.txt")) - (env (make-environment '()))) + (output (string-append directory "/output.txt"))) (with-output-to-file foo (lambda () (display "foo") @@ -221,9 +214,9 @@ (with-output-to-file ,output (lambda () (display (get-string-all (current-input-port)))))) - (sh:with-redirects env `((< 0 ,foo)) + (sh:with-redirects `((< 0 ,foo)) (lambda () - (sh:exec env utility))) + (sh:exec utility))) (call-with-input-file output get-string-all))))) ;; 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" (call-with-temporary-directory (lambda (directory) - (let ((foo (string-append directory "/foo.txt")) - (env (make-environment '()))) - (sh:with-redirects env `((> 1 ,foo) (>& 2 1)) + (let ((foo (string-append directory "/foo.txt"))) + (sh:with-redirects `((> 1 ,foo) (>& 2 1)) (lambda () (display "foo") (newline) @@ -250,16 +242,15 @@ (call-with-temporary-directory (lambda (directory) (let ((utility (string-append directory "/utility")) - (foo (string-append directory "/foo.txt")) - (env (make-environment '()))) + (foo (string-append directory "/foo.txt"))) (make-script utility (display "foo") (newline) (display "bar" (current-error-port)) (newline (current-error-port))) - (sh:with-redirects env `((> 1 ,foo) (>& 2 1)) + (sh:with-redirects `((> 1 ,foo) (>& 2 1)) (lambda () - (sh:exec env utility))) + (sh:exec utility))) (let ((result (call-with-input-file foo get-string-all))) (or (string=? result "foo\nbar\n") (string=? result "bar\nfoo\n"))))))) @@ -268,13 +259,12 @@ "foo\nbar\n" (call-with-temporary-directory (lambda (directory) - (let ((foo (string-append directory "/foo.txt")) - (env (make-environment '()))) + (let ((foo (string-append directory "/foo.txt"))) (with-output-to-file foo (lambda () (display "foo") (newline))) - (sh:with-redirects env `((>> 1 ,foo)) + (sh:with-redirects `((>> 1 ,foo)) (lambda () (display "bar") (newline))) @@ -282,31 +272,28 @@ (test-equal "Redirects here-document to standard input" "foo\n" - (let ((env (make-environment '()))) - (with-output-to-string - (lambda () - (sh:with-redirects env '((<< 0 "foo\n")) - (lambda () - (display (get-string-all (current-input-port))))))))) + (with-output-to-string + (lambda () + (sh:with-redirects '((<< 0 "foo\n")) + (lambda () + (display (get-string-all (current-input-port)))))))) (test-equal "Redirects work with string ports" "foo\n" - (let ((env (make-environment '()))) - (with-input-from-string "bar\n" - (lambda () - (setvbuf (current-input-port) 'none) - (with-output-to-string - (lambda () - (sh:with-redirects env '((<< 0 "foo\n")) - (lambda () - (display (get-string-all (current-input-port))))))))))) + (with-input-from-string "bar\n" + (lambda () + (setvbuf (current-input-port) 'none) + (with-output-to-string + (lambda () + (sh:with-redirects '((<< 0 "foo\n")) + (lambda () + (display (get-string-all (current-input-port)))))))))) (test-equal "Does not use buffered input from current-input-port" "foo\n" (call-with-temporary-directory (lambda (directory) - (let ((bar-baz (string-append directory "/bar-baz.txt")) - (env (make-environment '()))) + (let ((bar-baz (string-append directory "/bar-baz.txt"))) (with-output-to-file bar-baz (lambda () (display "bar\nbaz\n"))) @@ -316,7 +303,7 @@ (get-line (current-input-port)) (with-output-to-string (lambda () - (sh:with-redirects env '((<< 0 "foo\n")) + (sh:with-redirects '((<< 0 "foo\n")) (lambda () (display (get-string-all (current-input-port))))))))))))) @@ -324,21 +311,19 @@ "foo\n" (call-with-temporary-directory (lambda (directory) - (let ((foo (string-append directory "/foo.txt")) - (env (make-environment '()))) - (sh:with-redirects env `((> 1 ,foo) (<< 0 "foo\n")) + (let ((foo (string-append directory "/foo.txt"))) + (sh:with-redirects `((> 1 ,foo) (<< 0 "foo\n")) (lambda () (display (get-string-all (current-input-port))))) (call-with-input-file foo get-string-all))))) (test-equal "Uses last here-document specified" "foo\n" - (let ((env (make-environment '()))) - (with-output-to-string - (lambda () - (sh:with-redirects env '((<< 0 "bar\n") (<< 0 "foo\n")) - (lambda () - (display (get-string-all (current-input-port))))))))) + (with-output-to-string + (lambda () + (sh:with-redirects '((<< 0 "bar\n") (<< 0 "foo\n")) + (lambda () + (display (get-string-all (current-input-port)))))))) ;; TODO: Read-write tests, closing tests, clobbering tests. @@ -347,11 +332,12 @@ (test-equal "Subshells cannot change variables" "foo" - (let ((env (make-environment '(("x" . "foo"))))) - (sh:subshell env - (lambda () - (set-var! env "x" "bar"))) - (var-ref env "x"))) + (with-variables '(("x" . "foo")) + (lambda () + (sh:subshell + (lambda () + (setvar! "x" "bar"))) + (getvar "x")))) ;; TODO: Test other means of manipulating the environment and exit ;; statuses. @@ -361,45 +347,40 @@ (test-equal "Substitutes output from built-in" "foo" - (let ((env (make-environment '()))) - (sh:substitute-command env - (lambda () - (display "foo"))))) + (sh:substitute-command + (lambda () + (display "foo")))) (test-equal "Substitutes output from external utilities" "foo" (call-with-temporary-directory (lambda (directory) - (let ((utility (string-append directory "/utility")) - (env (make-environment '()))) + (let ((utility (string-append directory "/utility"))) (make-script utility (display "foo")) - (sh:substitute-command env + (sh:substitute-command (lambda () - (sh:exec env utility))))))) + (sh:exec utility))))))) (test-equal "Trailing newlines are trimmed from substitutions" "foo" - (let ((env (make-environment '()))) - (sh:substitute-command env - (lambda () - (display "foo") - (newline))))) + (sh:substitute-command + (lambda () + (display "foo") + (newline)))) (test-equal "Non-trailing newlines are preserved in substitutions" "\nfoo\nbar" - (let ((env (make-environment '()))) - (sh:substitute-command env - (lambda () - (newline) - (display "foo") - (newline) - (display "bar"))))) + (sh:substitute-command + (lambda () + (newline) + (display "foo") + (newline) + (display "bar")))) (test-equal "Empty substitutions produce empty strings" "" - (let ((env (make-environment '()))) - (sh:substitute-command env noop))) + (sh:substitute-command noop)) ;; Pipelines. @@ -408,10 +389,8 @@ "foo" (call-with-temporary-directory (lambda (directory) - (let ((foo (string-append directory "/foo.txt")) - (env (make-environment '()))) - (sh:pipeline env - (lambda () + (let ((foo (string-append directory "/foo.txt"))) + (sh:pipeline (lambda () (display "foo\n")) (lambda () (with-output-to-file foo @@ -425,8 +404,7 @@ (lambda (directory) (let ((utility1 (string-append directory "utility1")) (utility2 (string-append directory "utility2")) - (foo (string-append directory "/foo.txt")) - (env (make-environment '()))) + (foo (string-append directory "/foo.txt"))) (make-script utility1 (display "foo\n")) (make-script utility2 @@ -434,11 +412,10 @@ (with-output-to-file ,foo (lambda () (display (get-line (current-input-port)))))) - (sh:pipeline env + (sh:pipeline (lambda () + (sh:exec utility1)) (lambda () - (sh:exec env utility1)) - (lambda () - (sh:exec env utility2))) + (sh:exec utility2))) (call-with-input-file foo get-string-all))))) (test-equal "Externals and built-ins are connected by pipelines" @@ -446,13 +423,11 @@ (call-with-temporary-directory (lambda (directory) (let ((utility (string-append directory "/utility")) - (foo (string-append directory "/foo.txt")) - (env (make-environment '()))) + (foo (string-append directory "/foo.txt"))) (make-script utility (display "foo\n")) - (sh:pipeline env - (lambda () - (sh:exec env utility)) + (sh:pipeline (lambda () + (sh:exec utility)) (lambda () (with-output-to-file foo (lambda () @@ -464,18 +439,16 @@ (call-with-temporary-directory (lambda (directory) (let ((utility (string-append directory "/utility")) - (foo (string-append directory "/foo.txt")) - (env (make-environment '()))) + (foo (string-append directory "/foo.txt"))) (make-script utility (use-modules (ice-9 textual-ports)) (with-output-to-file ,foo (lambda () (display (get-line (current-input-port)))))) - (sh:pipeline env - (lambda () + (sh:pipeline (lambda () (display "foo\n")) (lambda () - (sh:exec env utility))) + (sh:exec utility))) (call-with-input-file foo get-string-all))))) (test-end) diff --git a/tests/word.scm b/tests/word.scm index e80aba2..8193aba 100644 --- a/tests/word.scm +++ b/tests/word.scm @@ -28,17 +28,6 @@ ;;; ;;; 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") @@ -46,70 +35,70 @@ the `set' built-in for details on these options.)" (test-equal "Converts a simple word (string) to a single field" '("foo") - (expand-word #f "foo")) + (expand-word "foo")) (test-equal "Converts a simple word (list) to a single field" '("foo") - (expand-word #f '("foo"))) + (expand-word '("foo"))) (test-equal "Concatenates contiguous parts into a single field" '("foobar") - (expand-word #f '("foo" "bar"))) + (expand-word '("foo" "bar"))) (test-equal "Splits a word along unquoted spaces" '("foo" "bar") - (expand-word #f '("foo bar"))) + (expand-word '("foo bar"))) (test-equal "Splits a word on leading space" '("foo" "bar") - (expand-word #f '("foo" " bar"))) + (expand-word '("foo" " bar"))) (test-equal "Splits a word on trailing space" '("foo" "bar") - (expand-word #f '("foo " "bar"))) + (expand-word '("foo " "bar"))) (test-equal "Ignores leading spaces" '("foo") - (expand-word #f '(" foo"))) + (expand-word '(" foo"))) (test-equal "Ignores trailing spaces" '("foo") - (expand-word #f '("foo "))) + (expand-word '("foo "))) (test-equal "Treats multiple spaces as a single space" '("foo" "bar") - (expand-word #f '("foo bar"))) + (expand-word '("foo bar"))) (test-equal "Handles multiple joins and splits" '("hi_how" "are_you") - (expand-word #f '("hi_" "how are" "_you"))) + (expand-word '("hi_" "how are" "_you"))) (test-equal "Handles nested lists" '("foo") - (expand-word #f '("f" ("oo")))) + (expand-word '("f" ("oo")))) ;;; Quotes. (test-equal "Ignores spaces in quotes" '("foo bar") - (expand-word #f '( "foo bar"))) + (expand-word '( "foo bar"))) (test-equal "Concatenates strings and quotes" '("foo bar") - (expand-word #f '("foo" ( " bar")))) + (expand-word '("foo" ( " bar")))) (test-equal "Concatenates quotes" '("foo bar") - (expand-word #f '(( "foo") ( " bar")))) + (expand-word '(( "foo") ( " bar")))) (test-equal "Handles nested quotes" '("foo bar") - (expand-word #f '( ( "foo bar")))) + (expand-word '( ( "foo bar")))) (test-equal "Splits and concatenates words and quotes" '("foo" "bar") - (expand-word #f '(( "foo") " " ( "bar")))) + (expand-word '(( "foo") " " ( "bar")))) ;;; Tildes. @@ -123,43 +112,51 @@ the `set' built-in for details on these options.)" (test-equal "Resolves parameters" '("foo") - (expand-word (make-test-env '(("x" . "foo"))) - '( "x"))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x"))))) (test-equal "Splits parameter results" '("foo" "bar") - (expand-word (make-test-env '(("x" . "foo bar"))) - '( "x"))) + (with-variables '(("x" . "foo bar")) + (lambda () + (expand-word '( "x"))))) (test-equal "Resolves quoted parameters" '("foo") - (expand-word (make-test-env '(("x" . "foo"))) - '( ( "x")))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( ( "x")))))) (test-equal "Ignores spaces in quoted parameters" '("foo bar") - (expand-word (make-test-env '(("x" . "foo bar"))) - '( ( "x")))) + (with-variables '(("x" . "foo bar")) + (lambda () + (expand-word '( ( "x")))))) (test-equal "Treats empty variables as nothing" '() - (expand-word (make-test-env '(("x" . ""))) - '( "x"))) + (with-variables '(("x" . "")) + (lambda () + (expand-word '( "x"))))) (test-equal "Treats unset variables as nothing" '() - (expand-word (make-test-env '()) - '( "x"))) + (with-variables '() + (lambda () + (expand-word '( "x"))))) (test-equal "Preserves empty variables when quoted" '("") - (expand-word (make-test-env '(("x" . ""))) - '( ( "x")))) + (with-variables '(("x" . "")) + (lambda () + (expand-word '( ( "x")))))) (test-equal "Preserves unset variables when quoted" '("") - (expand-word (make-test-env '()) - '( ( "x")))) + (with-variables '() + (lambda () + (expand-word '( ( "x")))))) ;;; Parameter operations. @@ -168,103 +165,120 @@ the `set' built-in for details on these options.)" (test-equal "Handles 'or' when parameter is set" '("foo") - (expand-word (make-test-env '(("x" . "foo"))) - '( "x" "bar"))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'or' when parameter is set and empty" '() - (expand-word (make-test-env '(("x" . ""))) - '( "x" "bar"))) + (with-variables '(("x" . "")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'or' when parameter is unset" '("bar") - (expand-word (make-test-env '()) - '( "x" "bar"))) + (with-variables '() + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'or' fall-through without default" '() - (expand-word (make-test-env '()) - '( "x" #f))) + (with-variables '() + (lambda () + (expand-word '( "x" #f))))) ;;; or* (test-equal "Handles 'or*' when parameter is set" '("foo") - (expand-word (make-test-env '(("x" . "foo"))) - '( "x" "bar"))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'or*' when parameter is set and empty" '("bar") - (expand-word (make-test-env '(("x" . ""))) - '( "x" "bar"))) + (with-variables '(("x" . "")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'or*' when parameter is unset" '("bar") - (expand-word (make-test-env '()) - '( "x" "bar"))) + (with-variables '() + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'or*' fall-through without default" '() - (expand-word (make-test-env '()) - '( "x" #f))) + (with-variables '() + (lambda () + (expand-word '( "x" #f))))) ;;; or! (test-equal "Handles 'or!' when parameter is set" '(("foo") "foo") - (let ((env (make-test-env '(("x" . "foo"))))) - (list (expand-word env '( "x" "bar")) - (var-ref env "x")))) + (with-variables '(("x" . "foo")) + (lambda () + (list (expand-word '( "x" "bar")) + (getvar "x"))))) (test-equal "Handles 'or!' when parameter is set and empty" '(() "") - (let ((env (make-test-env '(("x" . ""))))) - (list (expand-word env '( "x" "bar")) - (var-ref env "x")))) + (with-variables '(("x" . "")) + (lambda () + (list (expand-word '( "x" "bar")) + (getvar "x"))))) (test-equal "Handles 'or!' when parameter is unset" '(("bar") "bar") - (let ((env (make-test-env '()))) - (list (expand-word env '( "x" "bar")) - (var-ref env "x")))) + (with-variables '() + (lambda () + (list (expand-word '( "x" "bar")) + (getvar "x"))))) (test-equal "Handles 'or!' fall-through without default" '(() "") - (let ((env (make-test-env '()))) - (list (expand-word env '( "x" #f)) - (var-ref env "x")))) + (with-variables '() + (lambda () + (list (expand-word '( "x" #f)) + (getvar "x"))))) ;;; or!* (test-equal "Handles 'or!*' when parameter is set" '(("foo") "foo") - (let ((env (make-test-env '(("x" . "foo"))))) - (list (expand-word env '( "x" "bar")) - (var-ref env "x")))) + (with-variables '(("x" . "foo")) + (lambda () + (list (expand-word '( "x" "bar")) + (getvar "x"))))) (test-equal "Handles 'or!*' when parameter is set and empty" '(("bar") "bar") - (let ((env (make-test-env '(("x" . ""))))) - (list (expand-word env '( "x" "bar")) - (var-ref env "x")))) + (with-variables '(("x" . "")) + (lambda () + (list (expand-word '( "x" "bar")) + (getvar "x"))))) (test-equal "Handles 'or!*' when parameter is unset" '(("bar") "bar") - (let ((env (make-test-env '()))) - (list (expand-word env '( "x" "bar")) - (var-ref env "x")))) + (with-variables '() + (lambda () + (list (expand-word '( "x" "bar")) + (getvar "x"))))) (test-equal "Handles 'or!*' fall-through without default" '(() "") - (let ((env (make-test-env '()))) - (list (expand-word env '( "x" #f)) - (var-ref env "x")))) + (with-variables '() + (lambda () + (list (expand-word '( "x" #f)) + (getvar "x"))))) (test-equal "Does not split fields on assignment" '(("foo" "bar") "foo bar") - (let ((env (make-test-env '(("y" . "foo bar"))))) - (list (expand-word env '( "x" ( "y"))) - (var-ref env "x")))) + (with-variables '(("y" . "foo bar")) + (lambda () + (list (expand-word '( "x" ( "y"))) + (getvar "x"))))) ;;; FIXME: Test 'assert'. @@ -272,57 +286,67 @@ the `set' built-in for details on these options.)" (test-equal "Handles 'and' when parameter is set" '("bar") - (expand-word (make-test-env '(("x" . "foo"))) - '( "x" "bar"))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'and' when parameter is set and empty" '() - (expand-word (make-test-env '(("x" . ""))) - '( "x" "bar"))) + (with-variables '(("x" . "")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'and' when parameter is unset" '() - (expand-word (make-test-env '()) - '( "x" "bar"))) + (with-variables '() + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'and' fall-through without default" '() - (expand-word (make-test-env '(("x" . "foo"))) - '( "x" #f))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x" #f))))) ;;; and* (test-equal "Handles 'and*' when parameter is set" '("bar") - (expand-word (make-test-env '(("x" . "foo"))) - '( "x" "bar"))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'and*' when parameter is set and empty" '("bar") - (expand-word (make-test-env '(("x" . ""))) - '( "x" "bar"))) + (with-variables '(("x" . "")) + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'and*' when parameter is unset" '() - (expand-word (make-test-env '()) - '( "x" "bar"))) + (with-variables '() + (lambda () + (expand-word '( "x" "bar"))))) (test-equal "Handles 'and*' fall-through without default" '() - (expand-word (make-test-env '(("x" . "foo"))) - '( "x" #f))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x" #f))))) ;;; length (test-equal "Handles 'length' when parameter is set" '("3") - (expand-word (make-test-env '(("x" . "foo"))) - '( "x"))) + (with-variables '(("x" . "foo")) + (lambda () + (expand-word '( "x"))))) (test-equal "Handles 'length' when parameter is unset" '("0") - (expand-word (make-test-env '()) - '( "x"))) + (with-variables '() + (lambda () + (expand-word '( "x"))))) ;;; Command substition. @@ -330,22 +354,22 @@ the `set' built-in for details on these options.)" (test-equal "Resolves commands" '("foo") (parameterize ((eval-cmd-sub identity)) - (expand-word #f '( "foo")))) + (expand-word '( "foo")))) (test-equal "Splits command results" '("foo" "bar") (parameterize ((eval-cmd-sub identity)) - (expand-word #f '( "foo bar")))) + (expand-word '( "foo bar")))) (test-equal "Resolves quoted commands" '("foo") (parameterize ((eval-cmd-sub identity)) - (expand-word #f '( ( "foo"))))) + (expand-word '( ( "foo"))))) (test-equal "Ignores spaces in quoted commands" '("foo bar") (parameterize ((eval-cmd-sub identity)) - (expand-word #f '( ( "foo bar"))))) + (expand-word '( ( "foo bar"))))) ;;; Arithmetic expansion. @@ -362,42 +386,50 @@ the `set' built-in for details on these options.)" (test-equal "Respects IFS value" '("foo" "bar") - (let ((env (make-test-env '(("IFS" . "-"))))) - (expand-word env '("foo-bar")))) + (with-variables '(("IFS" . "-")) + (lambda () + (expand-word '("foo-bar"))))) (test-equal "Combines multiple whitespace separators" '("foo" "bar") - (let ((env (make-test-env '(("IFS" . " "))))) - (expand-word env '("foo bar")))) + (with-variables '(("IFS" . " ")) + (lambda () + (expand-word '("foo bar"))))) (test-equal "Keeps multiple non-whitespace separators" '("foo" "" "bar") - (let ((env (make-test-env '(("IFS" . "-"))))) - (expand-word env '("foo--bar")))) + (with-variables '(("IFS" . "-")) + (lambda () + (expand-word '("foo--bar"))))) (test-equal "Combines whitespace separators with a non-whitespace separator" '("foo" "bar") - (let ((env (make-test-env '(("IFS" . "- "))))) - (expand-word env '("foo - bar")))) + (with-variables '(("IFS" . "- ")) + (lambda () + (expand-word '("foo - bar"))))) (test-equal "Keeps multiple non-whitespace separators with whitespace" '("foo" "" "bar") - (let ((env (make-test-env '(("IFS" . "- "))))) - (expand-word env '("foo - - bar")))) + (with-variables '(("IFS" . "- ")) + (lambda () + (expand-word '("foo - - bar"))))) (test-equal "Splits on leading non-whitespace separator" '("" "foo") - (let ((env (make-test-env '(("IFS" . "-"))))) - (expand-word env '("-foo")))) + (with-variables '(("IFS" . "-")) + (lambda () + (expand-word '("-foo"))))) (test-equal "Does not split on trailing non-whitespace separator" '("foo") - (let ((env (make-test-env '(("IFS" . "-"))))) - (expand-word env '("foo-")))) + (with-variables '(("IFS" . "-")) + (lambda () + (expand-word '("foo-"))))) (test-equal "Makes one field for single non-whitespace separator" '("") - (let ((env (make-test-env '(("IFS" . "-"))))) - (expand-word env '("-")))) + (with-variables '(("IFS" . "-")) + (lambda () + (expand-word '("-"))))) (test-end)