Compare commits

...

82 Commits
v0.1 ... master

Author SHA1 Message Date
Timothy Sample a3123ab02a Update NEWS for 0.3.0.
* NEWS (release 0.3.0): New section.
2022-02-11 11:18:55 -05:00
Timothy Sample ec009a89bb Update ChangeLog copyright years.
* ChangeLog: Update copyright years for Timothy Sample.
2022-02-11 10:43:58 -05:00
Timothy Sample d0d90d0956 Support Guile 3.0.
* configure.ac (GUILE_PKG): Add '3.0'.
* guix.scm: Use 'guile-3.0' for the Gash package.
2022-02-11 10:22:19 -05:00
Timothy Sample eae0953f31 parser: Simplify default port handling.
* gash/parser.scm (read-sh, read-sh-all): Set the default value for
the 'port' argument in the usual way (rather than doing it
manually).
2021-06-23 14:27:40 -04:00
Timothy Sample 57d21182e2 parser: Fix port name typo.
* gash/parser.scm (read-sh): Read from 'current-input-port' instead
of 'current-output-port'.
2021-06-23 14:19:20 -04:00
Timothy Sample 87229e4b3a Add arithmetic expansion.
* gash/arithmetic.scm: New file.
* Makefile.am (SOURCES): Add it.
* gash/lexer.scm (get-arithmetic-expansion): New procedure.
(get-expansion): Check for "$((" and use the new procedure to read an
arithmetic expansion.
* gash/eval.scm (word->qword): Handle '<sh-arithmetic>'.
* tests/unit/eval.scm: Add tests.
* tests/spec/Makefile.am (TESTS): Add 'arith'.
* tests/spec/oil.scm: Patch seven of its tests and filter out fifteen
others.
* doc/gash.texi, doc/syntax.txt: Add '<sh-arithmetic>' syntax.
2021-05-26 13:16:50 -04:00
Timothy Sample d3244e0ec0 Move evaluation code from 'word' to 'eval'.
This adjustment paves the way for writing a compiler.

* gash/word.scm (eval-cmd-sub, string-not-null?, word->qword,
expand-word): Move these...
* gash/eval.scm: ...to this module.
* tests/unit/word.scm: Adjust qword tests to use 'expand-qword', and
move non-qword (evaluation) tests to...
* tests/unit/eval.scm: ...this new file, adjusting them to use
'eval-word'.
* Makefile.am (UNIT_TESTS): Add the new file.
2021-04-19 15:11:27 -04:00
Timothy Sample 2bce1ea07b Add an 'expand-qword' procedure.
* gash/word.scm (expand-qword): New procedure.
(expand-word): Rewrite in terms of 'expand-qword'.
2021-04-19 15:09:16 -04:00
Timothy Sample 1e88c314d6 Fix long lines in the examples in the manual.
* doc/gash.texi (Internal representation examples): Fix long lines
in examples.
2021-04-16 21:35:42 -04:00
Timothy Sample 18ecd7d142 Correct ice cream parsing example in the manual.
* doc/gash.texi (Internal representation examples): In the section
on pipelines, change a redirect in the result to "ice-cream.txt" to
match its input.
2021-04-16 21:31:45 -04:00
Timothy Sample 1e752e54bf Remove asynchronous commands as a missing feature.
* doc/gash.texi (Missing features): Remove asynchronous commands
from the list.
2020-08-21 16:15:17 -04:00
Timothy Sample 9f9a866b19 List variable operators as working in the manual.
* doc/gash.texi (Using Gash): Specify that all the variable
operators work.
(Missing features): Remove the bullet point about variable
operators.
2020-08-21 16:07:16 -04:00
Stephen J. Scheck 8f9b973264 Add a language specification.
* language/sh/spec.scm: New file.
* Makefile.am (SOURCES): Add it.
* doc/gash.texi (Using Gash from the Guile REPL): New section.
2020-08-21 15:49:24 -04:00
Timothy Sample 8cbb4803c8 Reset status on empty commands.
* gash/eval.scm (exp->thunk, exps->thunk): When the expression has
value '#f', reset the status.
2020-03-30 23:36:42 -04:00
Timothy Sample f22bc57996 Respect noclobber when redirecting.
* gash/shell.scm (process-redir): Respect the noclobber option.
* tests/redirects.org: Add a test.
2020-03-22 11:57:17 -04:00
Timothy Sample 01204cb807 Support printing the current umask.
* gash/built-ins/umask.scm (umask->octal-string): New procedure.
(main): Handle the no argument case.
2020-03-22 11:49:41 -04:00
Timothy Sample 855e15f928 Add the wait built-in.
* gash/built-ins/wait.scm: New file.
* Makefile.scm (SOURCES): Add it.
* geesh/built-ins.scm (*built-ins*): Add 'wait'.
2020-03-17 17:57:01 -04:00
Timothy Sample a0b6189cf3 Add basic support for asynchronous commands.
* gash/environment.scm (*last-job*): New variable.
(get-last-job): New procedure.
(set-last-job!): New procedure.
(reap-child-processes!): New procedure.
* gash/eval.scm (eval-sh): Handle '<sh-async>'.
* gash/gash.scm (main): Reap child processes.
* gash/repl.scm (run-repl): Likewise.
* gash/shell.scm (sh:async): New procedure.
* gash/word.scm (parameter-ref): Handle "!".
2020-03-17 17:15:36 -04:00
Timothy Sample 82c45abed6 Install Git in the CI environment.
* build-aux/gitlab-ci.yml (before_script): Install 'git'.
2020-02-06 21:04:50 -05:00
Timothy Sample 25cd5ac5af Use the configured system shell in tests.
* Makefile.am (AM_TESTS_ENVIRONMENT): New variable.
* tests/redirects.org (Files opened for redirect can be executed
immediately): Use an environment variable instead of hard-coding
'/bin/sh'.
2020-02-06 20:26:57 -05:00
Timothy Sample b8c29ebe6c Restore 'guix build -f guix.scm'.
This broke when we started building the 'version.texi' file
reproducibly (cf. 6f598de23a).

* guix.scm: Make sure 'make-select' includes the '.git' directory;
add 'git-minimal' to the main package's 'native-inputs'.
2020-02-06 20:21:52 -05:00
Timothy Sample 917cbf2aba Speed up getting non-whitespace IFS characters.
* gash/word.scm (split-fields): Compute 'char-set:ifs/nw' using
'string-delete' instead of 'char-set-difference'.
2020-02-04 23:19:27 -05:00
Timothy Sample b2faf08ed4 Mark 'next-char' as inlinable.
* gash/lexer.scm (next-char): Mark as inlinable.
2020-02-04 23:19:22 -05:00
Timothy Sample 9ba534ebff Speed up checking for operators.
* gash/lexer.scm (operator-prefix-char?): Compute the list of prefix
characters ahead of time.
2020-02-04 21:20:49 -05:00
Timothy Sample de485819ca Update the NEWS file.
NEWS: Update for release 0.2.0.
2019-12-15 21:56:31 -05:00
Timothy Sample b7c2153785 Make the bootstrap test work with current Guix.
* tests/bootstrap/bash-without-bash.scm (%boot0-inputs): Call the
upstream '%boot0-inputs' to get the list of packages.
2019-12-15 21:56:31 -05:00
Timothy Sample 6f598de23a Generate 'version.texi' reproducibly.
* Makefile.am ($(srcdir)/doc/version.texi): New rule (overriding one
provided by Automake).
2019-12-10 14:53:51 -05:00
Timothy Sample 98b60c0d68 Add janneke to the ChangeLog copyright notice. 2019-12-09 14:04:13 -05:00
Jan Nieuwenhuizen 45223e7d86 Allow 'make dist' in a Git worktree.
* Makefile.am (dist-hook, gen-ChangeLog): Test for mere existence of
.git instead of asserting a directory.

Co-authored-by: Timothy Sample <samplet@ngyro.com>
2019-12-09 14:01:24 -05:00
Timothy Sample a4cfff0641 Generate the ChangeLog reproducibly.
* build-aux/gitlog-to-changelog-repro.patch: New file.
* Makefile.am (EXTRA_DIST): Add it.
(build-aux/gitlog-to-changelog-repro): New rule.
(gen-ChangeLog): Use 'gitlog-to-changelog-repro'.
(DISTCLEANFILES): Add 'build-aux/gitlog-to-changelog-repro'.
2019-12-09 13:57:15 -05:00
Jan Nieuwenhuizen fda97e32ef Generate reproducible source tarballs.
* Makefile.am (dist-hook): Generate a '.tarball-timestamp' file.
(GZIP_ENV): Override, adding '--no-name'.
(am__tar): Override, adding flags to create reproducible source
tarballs.

Co-authored-by: Timothy Sample <samplet@ngyro.com>
2019-12-09 13:57:15 -05:00
Timothy Sample 82b6769285 Allow running 'make dist' from extracted tarball.
* Makefile (dist-hook): Check for '.git' before generating
'.tarball-manifest'.
2019-12-09 13:57:15 -05:00
Timothy Sample f005b1acbc Generate ChangeLog from Git.
* ChangeLog: Update Git log URL and add a copyright notice.
* Makefile.am (gen-ChangeLog): Use 'gitlog-to-changelog' to generate
the ChangeLog.
2019-12-09 13:57:15 -05:00
Jan Nieuwenhuizen 6f81266e2b gash compat textual-ports: Add put-char.
* gash/compat/textual-ports.scm: Add put-char.
2019-12-09 13:57:15 -05:00
Timothy Sample d905679e9a Initialize the current locale on Guile 2.0.
* gash/gash.scm: Initialize the current locale on Guile 2.0.
2019-12-09 13:57:09 -05:00
Timothy Sample 2d41b4ae5a Allow one-armed 'if-guile-version-below'.
* gash/compat.scm: Allow one-armed 'if-guile-version-below' syntax and
use it to simplify the conditional definitions throughout.
2019-12-09 13:53:55 -05:00
Timothy Sample 4f90afcd3d Use bindings with regular built-ins.
* gash/shell.scm (sh:exec-let): Save and set variables according to
'bindings' before executing a regular built-in.
2019-12-09 13:53:44 -05:00
Timothy Sample 8a440f35f6 Reap every process in a pipeline.
* gash/shell.scm (waitpid/any): New procedure.
(sh:pipeline): Use it to reap every process spawned while executing a
pipeline.
2019-12-09 13:36:41 -05:00
Timothy Sample d600f82f7f Do not leak ports into pipeline processes.
* gash/shell.scm (swap-and-shift-pairs): Remove procedure.
(make-pipes): Remove procedure.
(plumb): Accept another port as an argument and close it when setting
up the child process.
(sh:pipeline): Do not use 'make-pipes' to create all the pipe ports
upfront, but rather create them as needed and give them directly to
'plumb'.
2019-12-09 13:36:41 -05:00
Jan Nieuwenhuizen 7eacf52807 Test executing redirect-created files immediately.
* tests/redirects.org (Files opened for redirect can be executed
immediately): New test.

Co-authored-by: Timothy Sample <samplet@ngyro.com>
2019-12-09 13:36:41 -05:00
Timothy Sample 121d9cb435 Close ports opened for redirects.
* gash/shell.scm (redir->parameter+port): Rename this...
(process-redirect): ...to this, and make it return a list with the
third element being a boolean indicating if the port was opened by us.
(sh:with-redirects): Close ports when the new boolean is set.
2019-12-09 13:36:41 -05:00
Timothy Sample 22205a00a3 Enable 'glob' specification test
* tests/spec/Makefile.am (TESTS): Add 'glob'.
* tests/spec/oil.scm: Patch one of its tests and filter out eleven
others.
2019-12-09 13:36:41 -05:00
Timothy Sample 168f422955 Respect the 'noglob' option.
* gash/word.scm (expand-pathnames): Do not expand pathnames if the
'noglob' option is set.
2019-12-09 13:35:01 -05:00
Timothy Sample 3d3375e066 Fix pathname expansion.
The old implementation had several bugs, prompting this complete
rewrite.

* gash/compat/srfi-43.scm (vector-empty?): New procedure.
* gash/pattern.scm (pattern-null?): New procedure.
* gash/word.scm (qword->pattern-string): New procedure.
(qword->pattern): Rewrite using 'qword->pattern-string'.
(find-files): New procedure.
(expand-pathnames): Rewrite using 'find-files' and add a docstring.
* tests/unit/word.scm: Add tests.
(mock): New syntax.
(make-pure-scandir): New procedure.
(with-mocked-files): New syntax.
2019-12-09 13:23:54 -05:00
Timothy Sample 7687552149 Simplify the 'pattern' data structure.
* gash/pattern.scm (<pattern>): Remove the 'start-anchored?' and
'end-anchored?' fields.
(parse-pattern): Replace the fields with empty parts at the start or
end of the parts list.
(pattern-plain?): Instead of checking the fields, just check the
number of parts.
(pattern-match?, pattern-drop, pattern-drop-right): Do not worry about
the fields, because the empty parts ensure the right thing happens.
2019-12-09 13:04:20 -05:00
Timothy Sample cf6a886f61 Swap semantics of ':+' and '+'.
These were mixed up, with ':+' behaving like '+' and vice versa.

* gash/word.scm (word->qword): Swap implementations of '<sh-ref-and>'
and '<sh-ref-and*>'.
* tests/unit/word.scm: Swap tests.
2019-12-09 13:04:20 -05:00
Timothy Sample 4acbd303a9 Enable 'command-sub' specification test
* tests/spec/Makefile.am (TESTS): Add 'command-sub'.
* tests/spec/oil.scm: Patch four of its tests and filter out another.
2019-12-09 13:04:20 -05:00
Timothy Sample 49ac5e74d3 Fix case statements in '$(...)' substitutions.
* gash/parser.scm (make-parser): Fix the 'pattern!' rule so that it
gets reduced before reading an 'RPAREN' token.
2019-12-09 13:04:20 -05:00
Timothy Sample 66685b6219 Add test for backquoted commands in heredocs.
* tests/unit/parser.scm: Add test.
2019-12-09 13:04:20 -05:00
Timothy Sample 7deaa94bd5 Correctly parse double-quoted backquoted commands.
* gash/lexer.scm (read-backquoted-command): Make the default procedure
accept a 'quoted?' keyword.
(get-backquoted-command): Accept a 'quoted?' keyword and pass it on to
'read-backquoted-command'.
(get-expansion): Accept a 'quoted?' keyword and pass it on to
'get-backquoted-command'.
(get-double-quotation): Set the 'quoted?' keyword when calling
'get-expansion'.
* tests/unit/lexer.scm: Add tests.
* gash/parser.scm (call-with-backquoted-input-port): Accept a
'quoted?' keyword which, if set, adds the double quote character to
the set of escapable characters.
(read-sh/backquoted): Accept a 'quoted?' keyword and pass it on to
'call-with-backquoted-input-port'.
* tests/unit/parser.scm: Add tests.
2019-12-09 13:04:18 -05:00
Timothy Sample 8135e19904 Implement asserting references.
* gash/word.scm (word->qword): Add an implementation for the
'<sh-ref-assert>' and '<sh-ref-assert*>' cases.
* tests/variable-operators.org: New file.
* Makefile.am (FULL_TESTS): Add it.
2019-12-08 12:18:31 -05:00
Timothy Sample 7fee72f5c7 Reset exit status on assignment.
* gash/eval.scm (eval-word): Add 'on-command-substitution' keyword.
(eval-sh): On '<sh-set!>' reset the exit status unless a command
substitution has occurred.
* tests/assignments.org: Add tests.
2019-12-08 12:18:31 -05:00
Timothy Sample 9d98405821 Initialize the 'IFS' variable.
* gash/environment.scm (initial-variables): Initialize 'IFS'.
2019-12-08 12:18:31 -05:00
Timothy Sample d6a582f1bd Only throw for specific special built-in errors.
* gash/shell.scm (sh:exec-let): Do not throw on special built-in
errors.
* gash/built-ins/break.scm (main),
gash/built-ins/continue.scm (main),
gash/built-ins/return.scm (main),
gash/built-ins/shift.scm (main): Throw on error.
2019-12-08 12:18:31 -05:00
Timothy Sample 6990d656bc Make 'trap' handle a numerical action.
* gash/built-ins/utils.scm (string->nonnegative-integer): New procedure.
* gash/built-ins/trap.scm (main): If the first argument is a number,
treat it as if the action were '-'.
2019-12-08 12:18:31 -05:00
Timothy Sample 38001cb76d Fix 'string->positive-integer' docstring typo.
* gash/built-ins/utils.scm (string->positive-integer): Fix a typo in
the docstring.
2019-12-08 12:18:31 -05:00
Timothy Sample 804b6cbe05 Make 'read' handle logical lines.
* gash/built-ins/read.scm (read-logical-line): New procedure.
(main): Use it unless given the '-r' option.
* tests/read.org: Add tests.
2019-12-08 12:18:31 -05:00
Timothy Sample 5fed1b0d87 Make 'read' handle input field splitting.
* gash/built-ins/read.scm (split-fields): New procedure.
(main): Use it to split the input into fields and assign each field to
its corresponding variable.
* tests/read.org: New file.
* Makefile.am (FULL_TESTS): Add it.
2019-12-08 12:18:18 -05:00
Timothy Sample 7a0f4fbae2 Handle nested lists when removing quotes.
* gash/word.scm (remove-quotes): Handle nested lists.
(split-fields) <wedge-apart-quote>: Likewise.
* tests/unit/word.scm: Add test.
2019-11-24 17:40:05 -05:00
Timothy Sample 16ba8ca016 Use temporary assignments when calling functions.
* gash/environment.scm (save-variables-excursion): New procedure.
* gash/shell.scm (sh:exec-let): Use it to set up temporary assignments
during the extent of a function.
* tests/temporary-assignments.org: New file.
* Makefile.am (TESTS): Add it.
2019-11-24 17:13:54 -05:00
Timothy Sample b41ae32106 Delay bracket expression errors in patterns.
* gash/pattern.scm (parse-matching-bracket-expression): Do not
report errors until a full bracket expression has been parsed.
* tests/unit/pattern.scm: Add test.
2019-11-24 17:13:54 -05:00
Timothy Sample 3c7693ece6 Use '(gash compat)' in '(gash built-ins utils)'.
This was omitted from ffe9fc1f47.

* gash/built-ins/utils.scm: Use the '(gash compat)' module.
2019-11-24 17:13:54 -05:00
Timothy Sample 5450e19094 Enable 'var-op-strip' specification test
* tests/spec/Makefile.am (TESTS): Add 'var-op-strip'.
* tests/spec/oil.scm: Patch two of its tests and filter out four
others.
2019-11-24 17:13:54 -05:00
Timothy Sample 1b41a34ce2 Use UTF-8 when processing specification tests.
* tests/spec/oil.scm: Set the encoding on the input and output ports
to UTF-8.
2019-11-24 17:13:54 -05:00
Timothy Sample 5a27fd59cc Implement pattern-based variable operators.
This commit adds an implementation for the '#', '##', '%', and '%%'
variable operators.

* gash/word.scm (word->qword): Add an implementation for the
'<sh-ref-except-min>', '<sh-ref-except-max>', '<sh-ref-skip-min>',
and '<sh-ref-skip-max>' cases.
2019-11-24 17:13:54 -05:00
Timothy Sample 5c1602d5f2 Fix docstring for 'parameter-ref'.
* gash/word.scm (parameter-ref): Fix docstring.
2019-11-24 17:13:54 -05:00
Timothy Sample 223e8d2635 Remove tests for the '/' variable operator.
This is a Bash-specific feature, which means that it is out of scope
for now.

* tests/variable-patterns.org (slash, slash-string,
slash-string-slash): Delete tests.
2019-11-24 17:13:54 -05:00
Timothy Sample e029c4cbab Add pattern dropping procedures.
* gash/pattern.scm (string-contains-part-right): New procedure.
(pattern-drop): New procedure.
(pattern-drop-right): New procedure.
* tests/unit/pattern.scm: Test the dropping procedures.
2019-11-24 17:13:54 -05:00
Timothy Sample 7c8ddd7a43 Use a record type for patterns.
* gash/compat/srfi-43.scm: New file.
* Makefile.am: Add it.
* gash/pattern.scm (<pattern>): New record type.
(parse-part): New procedure.
(parse-pattern): Return a '<pattern>'.
(pattern-plain?, pattern-match?): Accept a '<pattern>'.
(string-starts-with-part, string-ends-with-part,
string-contains-part): Treat 'part' as a vector.
2019-11-24 17:13:54 -05:00
Timothy Sample a009118efb Add tests for 'pattern-plain?'.
* tests/unit/pattern.scm: Add tests for 'pattern-plain?'.
2019-11-24 17:13:54 -05:00
Timothy Sample dd215ee926 Do not test Bash with the specification tests.
* tests/spec/oil.scm: Disable testing Bash in 'spec.sh'.
2019-11-24 17:13:54 -05:00
Timothy Sample 0b49934a0b Remove extra import from 'run-test-suite'.
The '(ice-9 textual-ports)' module is not needed, and using it breaks
the test suite on Guile 2.0.

* tests/run-test-suite.in: Do not use '(ice-9 textual-ports)'.
2019-08-20 11:38:11 -04:00
Timothy Sample 9639f5eff7 Add missing '(gash compat)' import.
This was omitted from ffe9fc1f47.

* gash/shell.scm: Use the '(gash compat)' module.
2019-08-02 20:19:52 -04:00
Timothy Sample fdd835842a Use the 'site' Guile directories when installing.
Thanks to Ludovic Courtès <ludo@gnu.org> for patching this in the Guix
package definition.

* build-aux/guile.am (moddir, ccachedir): Use the 'site' directories.
2019-08-01 09:21:34 -04:00
Timothy Sample d9122d7b68 Use 'sh:exit' for 'errexit'.
* gash/shell.scm (errexit): Exit using 'sh:exit'.
* tests/unit/shell.scm: Make sure exit handlers are called on
'errexit'.
2019-08-01 09:12:35 -04:00
Timothy Sample da9a05d500 Do not use 'with-continuation-barrier'.
It turns out that 'with-continuation-barrier' allows delimited
continuations (i.e., prompts) to get through.

* gash/shell.scm (%subshell): Replace 'with-continuation-barrier' with
'dynamic-wind', making sure to preserve exit statuses that were leaked
through before.
* tests/unit/shell.scm (call-with-temporary-directory): Replace
'with-continuation-barrier' with 'dynamic-wind'.
* tests/spec/oil.scm: Enable previously failing tests.
2019-08-01 09:10:38 -04:00
Timothy Sample 6228064801 Fix top-level 'break', 'continue', and 'return'.
* gash/environment.scm (sh:break, sh:continue, sh:return): Wrap
'abort-to-prompt' with 'false-if-exception'.
* gash/built-ins/break.scm (main): Print warning and continue if
'sh:break' returns.
* gash/built-ins/continue.scm (main): Likewise, but for 'sh:continue'.
* gash/built-ins/return.scm (main): Likewise, but for 'sh:return'.
* tests/functions.org (Top-level return): New test.
* tests/spec/oil.scm: Enable previously failing test.
2019-08-01 09:02:05 -04:00
Timothy Sample 150c6eac53 Handle 'return' errors.
* gash/built-ins/utils.scm (string->exit-status): New procedure.
* gash/built-ins/return.scm (main): Use it to simplify argument
checking; check for too many arguments; and print messages on
errors.
* tests/functions.org (Too many arguments to return): New test.
2019-06-14 20:58:23 -04:00
Timothy Sample ffe9fc1f47 Handle 'break' and 'continue' errors.
* gash/built-ins/utils.scm (string->positive-integer): New function.
* gash/built-ins/break.scm (main): Use it to simplify argument
checking; check for too many arguments; and print messages on errors.
* gash/built-ins/continue.scm (main): Ditto.
* gash/shell.scm (sh:exec-let): Throw an error if a special built-in
fails.
* tests/spec/oil.scm: Enable and adjust previously failing tests.
2019-06-14 20:46:57 -04:00
Timothy Sample 7d2298d15b Aggregate tests into test suites.
This is a big change, but it is conceptually quite simple.  In the old
system, the tests were specified each by multiple files ('.sh', '.exit',
'.stdout', and '.stderr'), and run with the 'test.sh' script.  In the
new system there are multiple tests per file ('.org') and these test
suite files are run with the 'tests/run-test-suite' script.

* tests/00-exit-0.sh,
tests/00-exit-1.exit,
tests/00-exit-1.sh,
tests/00-exit-2.exit,
tests/00-exit-2.sh,
tests/00-exit-error.exit,
tests/00-exit-error.sh,
tests/00-exit-var.exit,
tests/00-exit-var.sh,
tests/00-exit.sh: Delete files, moving their contents...
* tests/exiting.org: ...here.
* tests/01-script-arg-0.sh,
tests/01-script-arg-length.sh,
tests/01-script-arg-length.stdout,
tests/01-script-arg-list.sh,
tests/01-script-arg-list.stdout,
tests/01-script-backslash-space.sh,
tests/01-script-backslash-twice.exit,
tests/01-script-backslash-twice.sh,
tests/01-script-backslash.exit,
tests/01-script-backslash.sh,
tests/01-script-newline.exit,
tests/01-script-newline.sh,
tests/01-script-semi.exit,
tests/01-script-semi.sh,
tests/01-script-shift.sh,
tests/01-script-shift.stdout: Delete files, moving their contents...
* tests/arguments.org: ...here.
* tests/03-echo-brace.sh,
tests/03-echo-brace.stdout,
tests/03-echo-doublequotes.sh,
tests/03-echo-doublequotes.stdout,
tests/03-echo-escaped-doublequotes.sh,
tests/03-echo-escaped-doublequotes.stdout,
tests/03-echo-nesting.sh,
tests/03-echo-nesting.stdout,
tests/03-echo-quoted-doublequotes.sh,
tests/03-echo-quoted-doublequotes.stdout,
tests/03-echo.sh: Delete files, moving their contents...
* tests/words.org: ...here.
* tests/04-echo-equal.sh,
tests/04-echo-equal.stdout,
tests/04-echo-var.sh,
tests/04-echo-word-at-word.sh,
tests/04-echo-word-at-word.stdout,
tests/04-echo-word-at.sh,
tests/04-echo-word-at.stdout: Delete files, moving their contents...
* tests/variable-words.org: ...here.
* tests/05-assignment-backtick.sh,
tests/05-assignment-backtick.stdout,
tests/05-assignment-double-quote.sh,
tests/05-assignment-doublequoted-doublequotes.sh,
tests/05-assignment-doublequoted-doublequotes.stdout,
tests/05-assignment-echo.sh,
tests/05-assignment-echo.stdout,
tests/05-assignment-empty.sh,
tests/05-assignment-empty.stdout,
tests/05-assignment-singlequote.sh,
tests/05-assignment-variable-word.sh,
tests/05-assignment-variable-word.stdout,
tests/05-assignment-word-variable.sh,
tests/05-assignment-word-variable.stdout,
tests/05-assignment.sh: Delete files, moving their contents...
* tests/assignments.org: ...here.
* tests/06-command-compound-word.sh,
tests/06-command-compound-word.stdout,
tests/06-compound-word.sh,
tests/06-compound-word.stdout: Delete files, moving their contents...
* tests/compound-words.org: ...here.
* tests/07-variable-not-or.sh,
tests/07-variable-not-or.stdout,
tests/07-variable-or-doublequote.sh,
tests/07-variable-or-doublequote.stdout,
tests/07-variable-or-empty.sh,
tests/07-variable-or-empty.stdout,
tests/07-variable-or-slash.sh,
tests/07-variable-or-variable.sh,
tests/07-variable-or-variable.stdout,
tests/07-variable-or.sh,
tests/07-variable-or.stdout: Delete files, moving their contents...
* tests/variable-or.org: ...here.
* tests/08-variable-and.sh,
tests/08-variable-and.stdout,
tests/08-variable-not-and.sh,
tests/08-variable-not-and.stdout: Delete files, moving their contents...
* tests/variable-and.org: ...here.
* tests/10-else-multiple.sh,
tests/10-else.multiple.stdout,
tests/10-if-bracket-false.sh,
tests/10-if-bracket.sh,
tests/10-if-elif.sh,
tests/10-if-else.sh,
tests/10-if-false.sh,
tests/10-if-line.sh,
tests/10-if-multiple.sh,
tests/10-if-multiple.stdout,
tests/10-if-redirect.sh,
tests/10-if-test-false.sh,
tests/10-if-test.sh,
tests/10-if-word-variable.sh,
tests/10-if.sh: Delete files, moving their contents...
* tests/conditionals.org: ...here.
* tests/11-for-done-subshell.sh,
tests/11-for-done-subshell.stdout,
tests/11-for-split-sequence.sh,
tests/11-for-split-sequence.stdout,
tests/11-for.sh,
tests/11-for.stdout: Delete files, moving their contents...
* tests/loops.org: ...here.
* tests/20-and.exit,
tests/20-and.sh,
tests/20-exec.sh,
tests/20-or.sh,
tests/20-pipe-exit-0.sh,
tests/20-pipe-exit-1.exit,
tests/20-pipe-exit-1.sh,
tests/20-pipe-sed-cat.sh,
tests/20-pipe-sed-cat.stdout,
tests/20-pipe-sed.sh,
tests/20-pipe-sed.stdout,
tests/20-semi.exit,
tests/20-semi.sh: Delete files, moving their contents...
* tests/pipes-and-booleans.org: ...here.
* tests/30-for-substitution.sh,
tests/30-for-substitution.stdout,
tests/30-substitution-assignment-at.sh,
tests/30-substitution-assignment-at.stdout,
tests/30-substitution-assignment.sh,
tests/30-substitution-assignment.stdout,
tests/30-substitution-backtick.sh,
tests/30-substitution-backtick.stdout,
tests/30-substitution-redirect.sh,
tests/30-substitution-redirect.stdout,
tests/30-substitution-word.sh,
tests/30-substitution-word.stdout,
tests/30-substitution.sh,
tests/30-substitution.stdout: Delete files, moving their contents...
* tests/command-substitution.org: ...here.
* tests/40-assignment-eval-echo.sh,
tests/40-assignment-eval-echo.stdout,
tests/40-eval-echo-variable.sh,
tests/40-eval-echo-variable.stdout,
tests/40-eval.sh,
tests/40-eval.stdout: Delete files, moving their contents...
* tests/eval.org: ...here.
* tests/41-dot.sh,
tests/41-dot.stdout: Delete files, moving their contents...
* tests/dot.org: ...here.
* tests/42-export-new.sh,
tests/42-export-new.stdout,
tests/42-sh-export-new.sh,
tests/42-sh-export-new.stdout,
tests/42-sh-export.sh,
tests/42-sh-export.stdout,
tests/42-sh.sh,
tests/42-sh.stdout: Delete files, moving their contents...
* tests/exporting.org: ...here.
* tests/data/42-export-new.sh: New file (copied from
'tests/42-export-new.sh').
* tests/43-trap-subshell.sh,
tests/43-trap-subshell.stdout: Delete files, moving their contents...
* tests/signals.org: ...here.
* tests/50-iohere-builtin.sh,
tests/50-iohere.sh,
tests/50-iohere.stdout,
tests/50-redirect-append.sh,
tests/50-redirect-append.stdout,
tests/50-redirect-clobber.sh,
tests/50-redirect-clobber.stdout,
tests/50-redirect-in-out.sh,
tests/50-redirect-in-out.stdout,
tests/50-redirect-in.sh,
tests/50-redirect-merge.sh,
tests/50-redirect-merge.stdout,
tests/50-redirect-pipe.sh,
tests/50-redirect-pipe.stdout,
tests/50-redirect-sed.sh,
tests/50-redirect-sed.stdout,
tests/50-redirect-space.sh,
tests/50-redirect-space.stdout,
tests/50-redirect.sh,
tests/50-redirect.stdout: Delete files, moving their contents...
* tests/redirects.org: ...here.
* tests/60-function-at.sh,
tests/60-function-at.stdout,
tests/60-function.sh,
tests/60-function.stdout,
tests/60-subst.sh: Delete files, moving their contents...
* tests/functions.org: ...here.
* tests/70-hash-hash.sh,
tests/70-hash-hash.stdout,
tests/70-hash.sh,
tests/70-hash.stdout,
tests/70-percent-percent.sh,
tests/70-percent-percent.stdout,
tests/70-percent-space.sh,
tests/70-percent-space.stdout,
tests/70-percent.sh,
tests/70-percent.stdout,
tests/70-slash-string-slash.sh,
tests/70-slash-string.sh,
tests/70-slash-string.stdout,
tests/70-slash.sh,
tests/70-slash.stdout: Delete files, moving their contents...
* tests/variable-patterns.org: ...here.
* tests/100-bracket-file.sh,
tests/100-cd-foo.exit,
tests/100-cd-foo.sh,
tests/100-cd.sh,
tests/100-cd.stdout,
tests/100-test-false.sh,
tests/100-test-file.sh,
tests/100-test.sh: Delete files.
* tests/README: Move this...
* tests/data/README: ...here and adapt to the new directory.
* test.sh: Delete file.
* tests/run-test-suite.in: New file.
* configure.ac: Configure it.
* Makefile.am (TEST_EXTENSIONS): Replace '.sh' with '.org'.
(SH_LOG_COMPILER): Delete variable.
(ORG_LOG_COMPILER): New variable.
(FULL_TESTS, XFAIL_TESTS): Replace '.sh' tests with '.org' tests.
(BROKEN_TESTS): Delete variable.
(TEST_DATA_FILES): Remove '.exit' and '.stdout' files; add
tests/data/42-export-new.sh.
(EXTRA_DIST): Add tests/data/README; remove tests/README,
BROKEN_TESTS, and test.sh.
* .gitignore: Adjust accordingly.
2019-06-14 20:27:33 -04:00
Timothy Sample 375752301c Update the specification tests.
* tests/spec/oil.scm: Update to the latest commit and filter out some
new failing tests.
2019-06-07 10:01:42 -04:00
Timothy Sample 945c54f8b2 Fix a typo in NEWS.
* NEWS: Fix a typo.
2019-06-03 21:56:52 -04:00
262 changed files with 4609 additions and 1671 deletions

4
.gitignore vendored
View File

@ -9,6 +9,7 @@
!/build-aux/git-version-gen
!/build-aux/gitlab-ci.yml
!/build-aux/gitlog-to-changelog
!/build-aux/gitlog-to-changelog-repro.patch
!/build-aux/guile.am
!/build-aux/pre-inst-env.in
/config.log
@ -22,8 +23,7 @@
/lcov.info
/pre-inst-env
/scripts/gash
/tests/*.1
/tests/*.2
/tests/run-test-suite
/tests/spec/oil
/tests/spec/oil-link
/tests/unit/config.scm

View File

@ -1,4 +1,16 @@
Normally a ChangeLog is generated at "make dist" time and available in
source tarballs.
If not, see the Git commit log at <https://git.ngyro.com/gash>.
If not, see the Git commit log:
<https://git.savannah.nongnu.org/cgit/gash.git/log/>.
The following notice will be appended to the generated ChangeLog.
Copyright © 2019-2022 Timothy Sample <samplet@ngyro.com>
Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
notice and this notice are preserved. This file is offered as-is,
without any warranty.

View File

@ -27,13 +27,15 @@ EXTRA_DIST += \
build-aux/git-version-gen \
build-aux/gitlab-ci.yml \
build-aux/gitlog-to-changelog \
build-aux/gitlog-to-changelog-repro.patch \
guix.scm \
tests/README
tests/data/README
# Modules and scripts
#####################
SOURCES = \
gash/arithmetic.scm \
gash/built-ins/break.scm \
gash/built-ins/cd.scm \
gash/built-ins/colon.scm \
@ -58,8 +60,10 @@ SOURCES = \
gash/built-ins/umask.scm \
gash/built-ins/unset.scm \
gash/built-ins/utils.scm \
gash/built-ins/wait.scm \
gash/built-ins.scm \
gash/compat/hash-table.scm \
gash/compat/srfi-43.scm \
gash/compat/textual-ports.scm \
gash/compat.scm \
gash/config.scm \
@ -72,7 +76,8 @@ SOURCES = \
gash/readline.scm \
gash/repl.scm \
gash/shell.scm \
gash/word.scm
gash/word.scm \
language/sh/spec.scm
bin_SCRIPTS = \
scripts/gash
@ -100,13 +105,31 @@ EXTRA_DIST += \
$(gash_TEXINFOS) \
doc/syntax.txt
# Generate 'version.texi' reproducibly using metadata from Git rather
# than using metadata from the filesystem.
override $(srcdir)/doc/version.texi:
$(AM_V_GEN)set -e \
LC_ALL=C; export LC_ALL; \
TZ=UTC0; export TZ; \
timestamp=$$(git log --pretty=format:%ct -- doc/gash.texi \
| sort -n -r | head -n 1); \
dmy=$$(date --date="@$$timestamp" "+%-d %B %Y"); \
my=$$(date --date="@$$timestamp" "+%B %Y"); \
{ echo "@set UPDATED $$dmy"; \
echo "@set UPDATED-MONTH $$my"; \
echo "@set EDITION $(VERSION)"; \
echo "@set VERSION $(VERSION)"; } > $@-t; \
mv $@-t $@
# Tests
#######
TEST_EXTENSIONS = .scm .sh
AM_TESTS_ENVIRONMENT = SYSTEM_SHELL='$(SHELL)'; export SYSTEM_SHELL;
TEST_EXTENSIONS = .scm .org
SCM_LOG_COMPILER = $(top_builddir)/pre-inst-env $(GUILE)
AM_SCM_LOG_FLAGS = --no-auto-compile
SH_LOG_COMPILER = $(top_builddir)/pre-inst-env $(top_srcdir)/test.sh
ORG_LOG_COMPILER = $(top_builddir)/pre-inst-env \
$(top_builddir)/tests/run-test-suite
.PHONY: check-spec
check-spec:
@ -121,6 +144,7 @@ check-gash:
SHELL=gash $(top_builddir)/pre-inst-env $(top_builddir)/check.sh
UNIT_TESTS = \
tests/unit/eval.scm \
tests/unit/lexer.scm \
tests/unit/parser.scm \
tests/unit/pattern.scm \
@ -128,234 +152,47 @@ UNIT_TESTS = \
tests/unit/word.scm
FULL_TESTS = \
tests/00-exit.sh \
tests/00-exit-0.sh \
tests/00-exit-1.sh \
tests/00-exit-2.sh \
tests/00-exit-error.sh \
tests/00-exit-var.sh \
tests/01-script-newline.sh \
tests/01-script-semi.sh \
tests/01-script-backslash.sh \
tests/01-script-backslash-space.sh \
tests/01-script-backslash-twice.sh \
tests/01-script-arg-0.sh \
tests/01-script-arg-length.sh \
tests/01-script-arg-list.sh \
tests/01-script-shift.sh \
tests/03-echo.sh \
tests/03-echo-doublequotes.sh \
tests/03-echo-nesting.sh \
tests/03-echo-escaped-doublequotes.sh \
tests/03-echo-quoted-doublequotes.sh \
tests/03-echo-brace.sh \
tests/04-echo-var.sh \
tests/04-echo-equal.sh \
tests/04-echo-word-at.sh \
tests/04-echo-word-at-word.sh \
tests/05-assignment.sh \
tests/05-assignment-backtick.sh \
tests/05-assignment-echo.sh \
tests/05-assignment-empty.sh \
tests/05-assignment-singlequote.sh \
tests/05-assignment-double-quote.sh \
tests/05-assignment-variable-word.sh \
tests/05-assignment-word-variable.sh \
tests/05-assignment-doublequoted-doublequotes.sh \
tests/06-compound-word.sh \
tests/06-command-compound-word.sh \
tests/07-variable-or.sh \
tests/07-variable-not-or.sh \
tests/07-variable-or-slash.sh \
tests/07-variable-or-variable.sh \
tests/07-variable-or-doublequote.sh \
tests/07-variable-or-empty.sh \
tests/08-variable-and.sh \
tests/08-variable-not-and.sh \
tests/10-if.sh \
tests/10-if-false.sh \
tests/10-if-word-variable.sh \
tests/10-if-line.sh \
tests/10-if-multiple.sh \
tests/10-if-else.sh \
tests/10-else-multiple.sh \
tests/10-if-elif.sh \
tests/10-if-redirect.sh \
tests/10-if-test.sh \
tests/10-if-test-false.sh \
tests/10-if-bracket.sh \
tests/10-if-bracket-false.sh \
tests/11-for.sh \
tests/11-for-split-sequence.sh \
tests/11-for-done-subshell.sh \
tests/20-semi.sh \
tests/20-or.sh \
tests/20-and.sh \
tests/20-pipe-exit-0.sh \
tests/20-pipe-exit-1.sh \
tests/20-pipe-sed.sh \
tests/20-pipe-sed-cat.sh \
tests/20-exec.sh \
tests/30-substitution.sh \
tests/30-substitution-word.sh \
tests/30-substitution-backtick.sh \
tests/30-substitution-assignment.sh \
tests/30-for-substitution.sh \
tests/30-substitution-assignment.sh \
tests/30-substitution-assignment-at.sh \
tests/30-substitution-redirect.sh \
tests/40-eval.sh \
tests/40-eval-echo-variable.sh \
tests/40-assignment-eval-echo.sh \
tests/41-dot.sh \
tests/42-sh.sh \
tests/42-sh-export.sh \
tests/42-export-new.sh \
tests/42-sh-export-new.sh \
tests/43-trap-subshell.sh \
tests/50-iohere.sh \
tests/50-iohere-builtin.sh \
tests/50-redirect.sh \
tests/50-redirect-in.sh \
tests/50-redirect-append.sh \
tests/50-redirect-pipe.sh \
tests/50-redirect-sed.sh \
tests/50-redirect-space.sh \
tests/50-redirect-in-out.sh \
tests/50-redirect-clobber.sh \
tests/60-function.sh \
tests/60-function-at.sh \
tests/60-subst.sh \
tests/70-hash.sh \
tests/70-hash-hash.sh \
tests/70-percent.sh \
tests/70-percent-percent.sh \
tests/70-percent-space.sh \
tests/70-slash.sh \
tests/70-slash-string.sh \
tests/70-slash-string-slash.sh \
tests/100-cd.sh \
tests/100-cd-foo.sh \
tests/100-test.sh \
tests/100-test-false.sh \
tests/100-test-file.sh \
tests/100-bracket-file.sh
tests/arguments.org \
tests/assignments.org \
tests/command-substitution.org \
tests/compound-words.org \
tests/conditionals.org \
tests/dot.org \
tests/eval.org \
tests/exiting.org \
tests/exporting.org \
tests/functions.org \
tests/loops.org \
tests/pipes-and-booleans.org \
tests/read.org \
tests/redirects.org \
tests/signals.org \
tests/temporary-assignments.org \
tests/variable-and.org \
tests/variable-operators.org \
tests/variable-or.org \
tests/variable-patterns.org \
tests/variable-words.org \
tests/words.org
TESTS = $(UNIT_TESTS) $(FULL_TESTS)
XFAIL_TESTS = \
tests/70-hash.sh \
tests/70-hash-hash.sh \
tests/70-percent.sh \
tests/70-percent-percent.sh \
tests/70-percent-space.sh \
tests/70-slash.sh \
tests/70-slash-string.sh \
tests/70-slash-string-slash.sh
# These tests will not be run. Put tests here
# that pass or fail based on environmental
# factors.
BROKEN_TESTS = \
tests/50-redirect-merge.sh
TEST_DATA_FILES = \
tests/00-exit-1.exit \
tests/00-exit-2.exit \
tests/00-exit-error.exit \
tests/00-exit-var.exit \
tests/01-script-arg-length.stdout \
tests/01-script-arg-list.stdout \
tests/01-script-backslash-twice.exit \
tests/01-script-backslash.exit \
tests/01-script-newline.exit \
tests/01-script-semi.exit \
tests/01-script-shift.stdout \
tests/03-echo-brace.stdout \
tests/03-echo-doublequotes.stdout \
tests/03-echo-escaped-doublequotes.stdout \
tests/03-echo-nesting.stdout \
tests/03-echo-quoted-doublequotes.stdout \
tests/04-echo-equal.stdout \
tests/04-echo-word-at-word.stdout \
tests/04-echo-word-at.stdout \
tests/05-assignment-backtick.stdout \
tests/05-assignment-doublequoted-doublequotes.stdout \
tests/05-assignment-echo.stdout \
tests/05-assignment-empty.stdout \
tests/05-assignment-variable-word.stdout \
tests/05-assignment-word-variable.stdout \
tests/06-command-compound-word.stdout \
tests/06-compound-word.stdout \
tests/07-variable-not-or.stdout \
tests/07-variable-or-doublequote.stdout \
tests/07-variable-or-empty.stdout \
tests/07-variable-or-variable.stdout \
tests/07-variable-or.stdout \
tests/08-variable-and.stdout \
tests/08-variable-not-and.stdout \
tests/10-else.multiple.stdout \
tests/10-if-multiple.stdout \
tests/11-for-done-subshell.stdout \
tests/11-for-split-sequence.stdout \
tests/11-for.stdout \
tests/20-and.exit \
tests/20-pipe-exit-1.exit \
tests/20-pipe-sed-cat.stdout \
tests/20-pipe-sed.stdout \
tests/20-semi.exit \
tests/30-for-substitution.stdout \
tests/30-substitution-assignment-at.stdout \
tests/30-substitution-assignment.stdout \
tests/30-substitution-backtick.stdout \
tests/30-substitution-redirect.stdout \
tests/30-substitution-word.stdout \
tests/30-substitution.stdout \
tests/40-assignment-eval-echo.stdout \
tests/40-eval-echo-variable.stdout \
tests/40-eval.stdout \
tests/41-dot.stdout \
tests/42-export-new.stdout \
tests/42-sh-export-new.stdout \
tests/42-sh-export.stdout \
tests/42-sh.stdout \
tests/43-trap-subshell.stdout \
tests/50-iohere.stdout \
tests/50-redirect-append.stdout \
tests/50-redirect-clobber.stdout \
tests/50-redirect-in-out.stdout \
tests/50-redirect-merge.stdout \
tests/50-redirect-pipe.stdout \
tests/50-redirect-sed.stdout \
tests/50-redirect-space.stdout \
tests/50-redirect.stdout \
tests/60-function-at.stdout \
tests/60-function.stdout \
tests/70-hash-hash.stdout \
tests/70-hash.stdout \
tests/70-percent-percent.stdout \
tests/70-percent-space.stdout \
tests/70-percent.stdout \
tests/70-slash-string.stdout \
tests/70-slash.stdout \
tests/100-cd-foo.exit \
tests/100-cd.stdout \
tests/data/star/2 \
tests/data/star/3 \
tests/data/star/0 \
tests/data/star/1 \
tests/data/foo \
tests/data/diff.scm \
tests/data/script.sh
tests/data/script.sh \
tests/data/42-export-new.sh
.PHONY: test-list
test-list: ; @echo $(TESTS)
EXTRA_DIST += \
$(TESTS) \
$(BROKEN_TESTS) \
$(TEST_DATA_FILES) \
test.sh \
tests/unit/automake.scm \
tests/spec/check-spec \
tests/spec/Makefile.am \
@ -381,18 +218,42 @@ endif # HAVE_GENHTML
dist-hook: gen-ChangeLog
echo $(VERSION) > $(distdir)/.tarball-version
git ls-tree -r --name-only HEAD > $(distdir)/.tarball-manifest
if test -e .git; then \
git ls-tree -r --name-only HEAD \
> $(distdir)/.tarball-manifest; \
git show HEAD --format=%ct --no-patch 2>/dev/null \
> $(distdir)/.tarball-timestamp; \
else \
cp $(srcdir)/.tarball-manifest $(distdir)/.tarball-manifest; \
cp $(srcdir)/.tarball-timestamp $(distdir)/.tarball-timestamp; \
fi
build-aux/gitlog-to-changelog-repro: \
$(srcdir)/build-aux/gitlog-to-changelog \
$(srcdir)/build-aux/gitlog-to-changelog-repro.patch
$(AM_V_GEN){ mkdir -p $$(dirname $@) && \
patch -t --output=$@ $? && \
chmod a+x $@; }
.PHONY: gen-ChangeLog
gen-ChangeLog:
echo "This is the first release, so there are no changes yet!" \
> $(distdir)/ChangeLog-t
# Once we release a first version we can generate the ChangeLog from
# Git and have it only include changes since the first release.
# $(top_srcdir)/build-aux/gitlog-to-changelog \
# > $(distdir)/ChangeLog-t
rm -f $(distdir)/ChangeLog
mv $(distdir)/ChangeLog-t $(distdir)/ChangeLog
gen-ChangeLog: build-aux/gitlog-to-changelog-repro
$(AM_V_GEN)if test -e .git; then \
{ ./build-aux/gitlog-to-changelog-repro \
--format='%s%n%n%b%n' -- v0.1.. && \
echo && \
sed -n -e '/^Copyright/,$$p' < $(top_srcdir)/ChangeLog; \
} > $(distdir)/ChangeLog-t && \
{ rm -f $(distdir)/ChangeLog && \
mv $(distdir)/ChangeLog-t $(distdir)/ChangeLog; } \
fi
# Reproducible tarball
# Be friendly to Debian; avoid using EPOCH
override GZIP_ENV = "--best --no-name"
am__tar = $${TAR-tar} -chof - --sort=name \
--mtime=@$$(cat "$$tardir"/.tarball-timestamp) \
--owner=0 --group=0 --numeric-owner \
--mode=go=rX,u+rw,a-s "$$tardir"
distcheck-hook:
set -e; \
@ -413,13 +274,13 @@ distcheck-hook:
CLEANFILES += \
$(bin_SCRIPTS) \
$(FULL_TESTS:tests/%.sh=tests/%.log) \
$(FULL_TESTS:tests/%.sh=tests/%.trs) \
$(FULL_TESTS:tests/%.sh=tests/%.1) \
$(FULL_TESTS:tests/%.sh=tests/%.2) \
$(FULL_TESTS:tests/%.org=tests/%.log) \
$(FULL_TESTS:tests/%.org=tests/%.trs) \
$(UNIT_TESTS:tests/%.scm=tests/%.log) \
$(UNIT_TESTS:tests/%.scm=tests/%.trs)
DISTCLEANFILES = build-aux/gitlog-to-changelog-repro
clean-local:
$(MAKE) $(AM_MAKEFLAGS) -L -C tests/spec clean

72
NEWS
View File

@ -1,6 +1,76 @@
All The Latest Gash News
************************
Noteworthy changes in release 0.3.0 (2022-02-11)
================================================
New features
- Arithmetic expansion.
- Simple asynchronous commands.
- A language specification is now provided, allowing you to use the
evaluator from the Guile REPL by typing ",L sh".
- Redirects now honor the 'noclobber' option.
- The 'wait' built-in.
- The 'umask' built-in can now display the current umask.
Bug fixes
- An empty command will now reset the status.
- The 'read-sh' procedure now reads from 'current-input-port' by
default (before it used 'current-output-port').
Miscellaneous improvements
- Various performance improvements.
- Word expansion has been split into two steps, paving the way for a
compiler.
- Guile 3.0 is now explicitly supported.
Noteworthy changes in release 0.2.0 (2019-12-15)
================================================
New features
- Pattern-based and asserting variable operators ('#', '##', '%',
'%%', and '?') are now supported.
- Errors are now handled in the 'break', 'continue', and 'return'
special built-ins.
- Temporary variable assignments are now passed into function calls
and invocations of regular built-ins.
- The 'read' special built-in now supports field splitting and
logical lines.
- The IFS variable is now initialized with a value.
- The 'trap' special built-in now uses '-' if no action is given.
- The 'noglob' option can be used to turn off globbing.
Bug fixes
- Subshells no longer continue executing code from the parent shell.
- The 'exit' special built-in now runs the exit handler.
- Patterns can now contain malformed, unterminated bracket
expressions (e.g., '[-foo').
- Nested variable references that are interpreted as strings now
work (e.g., 'x=${y+${z+foo}}').
- Backtick command substitutions in double quotes are now parsed
"correctly" (i.e., in the same bizarre way as other shells).
- Case statements that have unbalanced parentheses and are nested
inside of command substitutions are now parsed correctly.
- The behavior of the '+' and ':+' variable operators are no longer
reversed.
- Pathname expansion now works for absolute paths, paths with quoted
slashes, paths with repeated slashes, and paths with dot and
dot-dot components.
- Files opened for redirect are now closed immediately after they
are used.
- Processes spawned for pipelines are now reaped.
Miscellaneous improvements
- Gash is now installed into Guile's 'site' directories.
- The source tarball can now be generated reproducibly from a Git
checkout.
Noteworthy features of release 0.1 (2019-06-01)
===============================================
@ -8,7 +78,7 @@ Features of the shell
- Sophisticated enough to be used to build Bash.
- Has a nice colorized prompt.
- Includes all of the POSIX-specified "special" built-ins expect for
- Includes all of the POSIX-specified "special" built-ins except for
'times'.
- Includes about half of the POSIX-specified "regular" built-ins
(see 'gash/built-ins.scm' for details).

View File

@ -22,6 +22,7 @@ before_script:
- apt-get update -qq && apt-get install -y -qq
autoconf
automake
git
guile-${TEST_GUILE_VERSION}-dev
make
pkg-config

View File

@ -0,0 +1,16 @@
This patch adjusts the 'gitlog-to-changelog' script from Gnulib so
that its output is reproducible.
diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog
index deddef2..6fec950 100755
--- a/build-aux/gitlog-to-changelog
+++ b/build-aux/gitlog-to-changelog
@@ -345,7 +345,7 @@ sub git_dir_option($)
? ' (tiny change)' : '');
my $date_line = sprintf "%s %s$tiny\n",
- strftime ("%Y-%m-%d", localtime ($1)), $2;
+ strftime ("%Y-%m-%d", gmtime ($1)), $2;
my @coauthors = grep /^Co-authored-by:.*$/, @line;
# Omit meta-data lines we've already interpreted.

View File

@ -31,9 +31,9 @@ GUILE_WARNINGS = \
-Warity-mismatch \
-Wformat
moddir = $(datadir)/guile/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
moddir = $(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION)/$(modpath)
nobase_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES)
ccachedir = $(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/ccache/$(modpath)
ccachedir = $(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache/$(modpath)
nobase_ccache_DATA = $(GOBJECTS)
EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES)

View File

@ -25,7 +25,7 @@ AC_CONFIG_AUX_DIR([build-aux])
AM_INIT_AUTOMAKE([color-tests silent-rules -Wall -Werror])
AM_SILENT_RULES([yes])
GUILE_PKG([2.2 2.0])
GUILE_PKG([3.0 2.2 2.0])
GUILE_PROGS
AC_ARG_VAR([GUILD], [guild (Guile compiler) command])
@ -41,6 +41,7 @@ AC_CONFIG_FILES([Makefile])
AC_CONFIG_FILES([gash/config.scm])
AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
[chmod +x pre-inst-env])
AC_CONFIG_FILES([tests/run-test-suite], [chmod +x tests/run-test-suite])
AC_CONFIG_FILES([tests/unit/config.scm])
AC_CONFIG_FILES([tests/spec/Makefile])
AC_CONFIG_FILES([tools/coverage], [chmod +x tools/coverage])

View File

@ -203,8 +203,8 @@ exceptional cases, like @code{"$@@"} and when @code{$IFS} is
manipulated.
You can set variables and mark them read-only or exported. Many
special variables are available, and about half of the variable
operators (like @code{$@{VARIABLE+alternate@}}) work.
special variables are available, and all of the variable operators
(like @code{$@{VARIABLE+alternate@}}) work.
Both types of command substitution work (that is, @code{$(...)} and
@code{`...`}), and can even be nested.
@ -247,6 +247,22 @@ Print each command that is executed.
@end table
@node Using Gash from the Guile REPL
@section Using Gash from the Guile REPL
Gash defines a language specification that extends Guile, allowing you
to use shell syntax from the REPL. This is accomplished by using the
@code{language} REPL command:
@example
scheme@atchar{}(guile-user)> ,language sh
Happy hacking with Guile as Shell! To switch back, type `,L scheme'.
sh@atchar{}(guile-user)> echo "Hello Gash!"
Hello Gash!
$1 = 0
@end example
@node Missing features
@section Missing features
@ -258,10 +274,7 @@ exhaustive, but covers the most glaring omissions.
@itemize @bullet
@item
Arithmetic substitution.
@item
Asynchronous commands and job control.
Job control.
@item
Alias creation and substitution.
@ -275,11 +288,6 @@ the prompt variables (@code{$PS*}).
@item
Tilde expansion.
@item
Variable pattern operators and assertion operators. This means that
@code{$@{FOO%pattern@}} and the like do not work, and neither does
@code{$@{FOO?@}}.
@item
Multi-line commands from the readline interface. If you press
@key{Enter} in the middle of a command (e.g., from within an
@ -442,7 +450,8 @@ cat <<EOF > hello.scm
(display "Hello world!\n")
EOF
@result{}
(<sh-with-redirects> ((<< 0 (<sh-quote> "(display \"Hello world!\\n\")\n"))
(<sh-with-redirects> ((<< 0 (<sh-quote>
"(display \"Hello world!\\n\")\n"))
(> 1 "hello.scm"))
(<sh-exec> "cat"))
@ -451,7 +460,8 @@ hi=Howdy; echo $hi world!
EOF
@result{}
(<sh-with-redirects> ((<< 0 (<sh-quote>
("hi=Howdy; echo " (<sh-ref> "hi") " world!\n")))
("hi=Howdy; echo " (<sh-ref> "hi")
" world!\n")))
(> 1 "hello.sh"))
(<sh-exec> "cat"))
@ -583,7 +593,7 @@ cut -d ' ' -f 4 < ice-cream.txt \
| sed 's/mint/peanut butter/g'
@result{}
(<sh-pipeline>
(<sh-with-redirects> ((< 0 "flavors.txt"))
(<sh-with-redirects> ((< 0 "ice-cream.txt"))
(<sh-exec> "cut" "-d" (<sh-quote> " ") "-f" "4"))
(<sh-exec> "grep" "chocolate")
(<sh-exec> "sed" (<sh-quote> "s/mint/peanut butter/g")))
@ -730,6 +740,7 @@ word ::= string
| (word ...)
| ('<sh-quote> word)
| ('<sh-cmd-sub> sync ...)
| ('<sh-arithmetic> word)
| ('<sh-ref> var)
| ('<sh-ref-or> var [word])
| ('<sh-ref-or*> var [word])

View File

@ -48,6 +48,7 @@ word ::= string
| (word ...)
| ('<sh-quote> word)
| ('<sh-cmd-sub> sync ...)
| ('<sh-arithmetic> word)
| ('<sh-ref> var)
| ('<sh-ref-or> var [word])
| ('<sh-ref-or*> var [word])

268
gash/arithmetic.scm Normal file
View File

@ -0,0 +1,268 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2020, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash arithmetic)
#:use-module (ice-9 i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (system base lalr)
#:export (read-arithmetic))
;;; Commentary:
;;;
;;; This module contains the lexer and parser for reading arithmetic
;;; expansions.
;;;
;;; Code:
(define nonzero-digit?
(let ((nonzero-digits (string->char-set "123456789")))
(lambda (chr)
"Check if @var{chr} is a nonzero digit."
(char-set-contains? nonzero-digits chr))))
(define* (lex-number str #:optional (start 0) (end (string-length str)))
"Read a number token from @var{str} and return two values: the token
and its length. If a number cannot be read, then the resulting token
will be @code{#f} and the length will be zero."
(define (->token offset base)
(let ((str* (substring str (+ start offset) end)))
(receive (n count) (locale-string->integer str* base)
(if n
(values (make-lexical-token 'NUMBER #f n) (+ offset count))
(values #f 0)))))
(match (string-ref str start)
(#\0 (match (and (< (1+ start) end) (string-ref str (1+ start)))
((or #\x #\X) (->token 2 16))
(_ (->token 0 8))))
((? nonzero-digit?) (->token 0 10))
(_ (values #f 0))))
(define *operators*
`(("(" . LPAREN)
(")" . RPAREN)
("~" . BITNOT)
("!" . LOGNOT)
("*" . *)
("/" . /)
("%" . %)
("+" . +)
("-" . -)
("<<" . <<)
(">>" . >>)
("<" . <)
("<=" . <=)
(">" . >)
(">=" . >=)
("==" . ==)
("!=" . !=)
("&" . BITAND)
("^" . BITXOR)
("|" . BITIOR)
("&&" . LOGAND)
("||" . LOGIOR)
("?" . ?)
(":" . :)
("=" . =)
("*=" . *=)
("/=" . /=)
("%=" . %=)
("+=" . +=)
("-=" . -=)
("<<=" . <<=)
(">>=" . >>=)
("&=" . BITAND-ASSIGN)
("^=" . BITXOR-ASSIGN)
("|=" . BITIOR-ASSIGN)))
(define* (operator-prefix? str #:optional (start 0) (end (string-length str)))
"Check if @var{str} is a prefix of an arithmetic operator."
(any (cut string-prefix? str <> start end)
(map car *operators*)))
(define* (lex-operator str #:optional (start 0) (end (string-length str)))
"Read an operator token from @var{str} and return two values: the
token and its length. If an operator cannot be read, then the resulting
token will be @code{#f} and the length will be zero."
(define (->token op)
(if (string-null? op)
(values #f 0)
(values (make-lexical-token (assoc-ref *operators* op) #f op)
(string-length op))))
(let loop ((k start) (acc ""))
(if (< k end)
(let ((next (string-append acc (string (string-ref str k)))))
(if (operator-prefix? next)
(loop (1+ k) next)
(->token acc)))
(->token acc))))
(define name-start-char?
(let ((char-set:name-start
(char-set-intersection char-set:ascii
(char-set-union char-set:letter
(char-set #\_)))))
(lambda (chr)
"Check if @var{chr} is a valid first character for a name."
(and (char? chr)
(char-set-contains? char-set:name-start chr)))))
(define name-char?
(let ((char-set:name
(char-set-intersection char-set:ascii
(char-set-union char-set:letter+digit
(char-set #\_)))))
(lambda (chr)
"Check if @var{chr} is a valid character for a name."
(and (char? chr)
(char-set-contains? char-set:name chr)))))
(define* (lex-name str #:optional (start 0) (end (string-length str)))
"Read a name token from @var{str} and return two values: the token and
its length. If a name cannot be read, then the resulting token will be
@code{#f} and the length will be zero."
(match (string-ref str start)
((? name-start-char? ch)
(let loop ((k (1+ start)) (acc (list ch)))
(match (and (< k end) (string-ref str k))
((? name-char? ch) (loop (1+ k) (cons ch acc)))
(_ (let ((result (reverse-list->string acc)))
(values (make-lexical-token 'NAME #f result)
(string-length result)))))))
(_ (values #f 0))))
(define (make-lexer str)
"Return a lexer that reads tokens from @var{str}. This lexer is a
stateful thunk that returns the next token each time it is called. It
is suitable to be used with an @code{lalr-parser}."
(define %lexers (list lex-number lex-operator lex-name))
(define idx 0)
(lambda ()
(set! idx (string-index str char-set:graphic idx))
(if (and idx (< idx (string-length str)))
(let loop ((lexers %lexers))
(match lexers
(() (error "could not read arithmetic substitution" str idx))
((lex . rest)
(receive (token count) (lex str idx)
(if token
(begin
(set! idx (+ idx count))
token)
(loop rest))))))
'*eoi*)))
(define (make-ref name)
"Return a Scheme expression that looks up @var{name} in the current
Gash environment, returning zero if @var{name} is not set."
`(or (string->number (getvar ,name "0")) 0))
(define* (make-assign name expr #:optional make-expr)
"Return a Scheme expression that sets @var{name} to the result of
@var{expr} in the current Gash environment. Optionally, @var{make-expr}
can be used to adjust the result of @var{expr} while setting
@var{name}."
`(let ((result ,(match make-expr
((? symbol?) `(,make-expr ,(make-ref name) ,expr))
((? procedure?) (make-expr (make-ref name) expr))
(#f expr))))
(setvar! ,name (number->string result))
result))
(define (make-bool expr)
"Return a Scheme expression that converts the Boolean expression
@var{expr} into a number (one for true, zero for false)."
`(if ,expr 1 0))
(define (nonzero? expr)
"Return a Scheme expression that checks if @var{expr} is an expression
that returns a nonzero number."
`(not (zero? ,expr)))
(define (make-parser)
"Create a parser that reads arithmetic expansion expressions and
returns equivalent Scheme expressions."
(lalr-parser
(NAME
NUMBER
LPAREN
RPAREN
(right: = *= /= %= += -= <<= >>=
BITAND-ASSIGN BITXOR-ASSIGN BITIOR-ASSIGN)
(right: ? :)
(left: LOGIOR)
(left: LOGAND)
(left: BITIOR)
(left: BITXOR)
(left: BITAND)
(left: == !=)
(left: < <= > >=)
(left: << >>)
(left: + -)
(left: * / %)
(nonassoc: LOGNOT)
(nonassoc: BITNOT)
(nonassoc: unary-)
(nonassoc: unary+))
(expr
(NAME) : (make-ref $1)
(NUMBER) : $1
(LPAREN expr RPAREN) : $2
(+ expr (prec: unary+)) : `(+ ,$2)
(- expr (prec: unary-)) : `(- ,$2)
(BITNOT expr) : `(lognot ,$2)
(LOGNOT expr) : (make-bool `(zero? ,$2))
(expr * expr) : `(* ,$1 ,$3)
(expr / expr) : `(quotient ,$1 ,$3)
(expr % expr) : `(modulo ,$1 ,$3)
(expr + expr) : `(+ ,$1 ,$3)
(expr - expr) : `(- ,$1 ,$3)
(expr << expr) : `(ash ,$1 ,$3)
(expr >> expr) : `(ash ,$1 (- ,$3))
(expr < expr) : (make-bool `(< ,$1 ,$3))
(expr <= expr) : (make-bool `(<= ,$1 ,$3))
(expr > expr) : (make-bool `(> ,$1 ,$3))
(expr >= expr) : (make-bool `(>= ,$1 ,$3))
(expr == expr) : (make-bool `(= ,$1 ,$3))
(expr != expr) : (make-bool `(not (= ,$1 ,$3)))
(expr BITAND expr) : `(logand ,$1 ,$3)
(expr BITXOR expr) : `(logxor ,$1 ,$3)
(expr BITIOR expr) : `(logior ,$1 ,$3)
(expr LOGAND expr) : (make-bool `(and ,(nonzero? $1) ,(nonzero? $3)))
(expr LOGIOR expr) : (make-bool `(or ,(nonzero? $1) ,(nonzero? $3)))
(expr ? expr : expr) : `(if ,(nonzero? $1) ,$3 ,$5)
(NAME = expr) : (make-assign $1 $3)
(NAME *= expr) : (make-assign $1 $3 '*)
(NAME /= expr) : (make-assign $1 $3 'quotient)
(NAME %= expr) : (make-assign $1 $3 'modulo)
(NAME += expr) : (make-assign $1 $3 '+)
(NAME -= expr) : (make-assign $1 $3 '-)
(NAME <<= expr) : (make-assign $1 $3 'ash)
(NAME >>= expr) : (make-assign $1 $3 (lambda (x y) `(ash ,x (- ,y))))
(NAME BITAND-ASSIGN expr) : (make-assign $1 $3 'logand)
(NAME BITXOR-ASSIGN expr) : (make-assign $1 $3 'logxor)
(NAME BITIOR-ASSIGN expr) : (make-assign $1 $3 'logior))))
(define (read-arithmetic str)
"Read @var{str} as an arithmetic expansion expression and return an
equivalent Scheme expression."
(let ((lexer (make-lexer str))
(parser (make-parser)))
(parser lexer error)))

View File

@ -69,7 +69,7 @@
("type" . ,(@@ (gash built-ins type) main))
("umask" . ,(@@ (gash built-ins umask) main))
("unalias" . ,undefined)
("wait" . ,undefined)
("wait" . ,(@@ (gash built-ins wait) main))
;; Other built-ins.
("echo" . ,(@@ (gash built-ins echo) main))))

View File

@ -17,8 +17,10 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash built-ins break)
#:use-module (gash built-ins utils)
#:use-module (gash compat)
#:use-module (gash environment))
#:use-module (gash environment)
#:use-module (ice-9 match))
;;; Commentary:
;;;
@ -27,11 +29,18 @@
;;; Code:
(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
(begin
;; Since we do not return, we have to set the status here.
(set-status! 0)
(sh:break (1- n))))))
(match args
(() (main "1"))
((arg)
(match (string->positive-integer arg)
(#f (format (current-error-port)
"gash: break: argument must be a positive integer~%")
(throw 'shell-error))
(n (set-status! 0)
(sh:break (1- n))
(format (current-error-port)
"gash: break: no loop to break from~%")
EXIT_SUCCESS)))
(_ (format (current-error-port)
"gash: break: too many arguments~%")
(throw 'shell-error))))

View File

@ -17,8 +17,10 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash built-ins continue)
#:use-module (gash built-ins utils)
#:use-module (gash compat)
#:use-module (gash environment))
#:use-module (gash environment)
#:use-module (ice-9 match))
;;; Commentary:
;;;
@ -27,11 +29,18 @@
;;; Code:
(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
(begin
;; Since we do not return, we have to set the status here.
(set-status! 0)
(sh:continue (1- n))))))
(match args
(() (main "1"))
((arg)
(match (string->positive-integer arg)
(#f (format (current-error-port)
"gash: continue: argument must be a positive integer~%")
(throw 'shell-error))
(n (set-status! 0)
(sh:continue (1- n))
(format (current-error-port)
"gash: continue: no loop to continue from~%")
EXIT_SUCCESS)))
(_ (format (current-error-port)
"gash: continue: too many arguments~%")
(throw 'shell-error))))

View File

@ -1,5 +1,5 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
@ -17,9 +17,13 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash built-ins read)
#:use-module (gash compat)
#:use-module (gash compat textual-ports)
#:use-module (gash environment)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim))
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26))
;;; Commentary:
;;;
@ -27,8 +31,78 @@
;;;
;;; Code:
(define* (read-logical-line #:optional (port (current-input-port)))
"Return a ``logical'' line from @var{port} if specified, otherwise
from the value returned by @code{(current-input-port)}. A logical
line allows ignoring a newline character by prefixing it with a
backslash."
(let loop ((acc '()))
(match (get-char port)
((? eof-object? eof) (cons (reverse-list->string acc) eof))
(#\newline (cons (reverse-list->string acc) #\newline))
(#\\ (match (get-char port)
((? eof-object? eof) (cons (reverse-list->string acc) eof))
(#\newline (loop acc))
(chr (loop (cons chr acc)))))
(chr (loop (cons chr acc))))))
;; The '(gash word)' module already has a 'split-fields' procedure.
;; However, we need to be able to specify a maximum number of fields,
;; which it cannot do. We could extend it, but it has to deal with
;; quotes, which we do not here. It is simpler to write a specialized
;; version that can deal with 'max' without quotes than it is to
;; extend the more general version.
(define* (split-fields str max hard-delims soft-delims
#:optional (start 0) (end (string-length str)))
"Split @var{str} into at most @var{max} fields. Each individual
occurrence of a character in the set @var{hard-delims} delimits a
field, while contiguous sequences of characters from the set
@var{soft-delims} are treated as a single delimiter."
(define non-soft-delims (char-set-complement soft-delims))
(define all-delims (char-set-union hard-delims soft-delims))
(define* (field+next-index str i)
(let* ((end* (or (string-index str all-delims i end) end))
(start* (string-index str non-soft-delims end* end)))
(values (substring str i end*)
(if (and start*
(char-set-contains? hard-delims
(string-ref str start*)))
(or (string-index str non-soft-delims (1+ start*) end) end)
start*))))
(cond
((string-index str non-soft-delims start end)
=> (lambda (start*)
(let loop ((i start*) (count 0) (acc '()))
(if (>= count (1- max))
(reverse! (cons (string-trim-right str soft-delims i end) acc))
(call-with-values (lambda () (field+next-index str i))
(lambda (field i*)
(if i*
(loop i* (1+ count) (cons field acc))
(reverse! (cons field acc)))))))))
(else '())))
(define (main . args)
(match (read-line (current-input-port))
((? eof-object?) 1)
(str (setvar! (car args) str)
0)))
(match-let* (((vars . get-line)
(match args
(("-r" vars ...)
(cons vars (cut read-line (current-input-port) 'split)))
((vars ...)
(cons vars read-logical-line))))
(limit (length vars))
((line . delimiter) (get-line))
(dflt (string #\space #\tab #\newline))
(ifs (string->char-set (getvar "IFS" dflt)))
(ifs/w (char-set-intersection ifs char-set:whitespace))
(ifs/nw (char-set-difference ifs char-set:whitespace))
(fields (split-fields line limit ifs/nw ifs/w)))
(for-each (lambda (var field)
;; XXX: Verify that VAR is a valid variable name.
(setvar! var field))
vars
(append fields (circular-list "")))
(if (eof-object? delimiter)
EXIT_FAILURE
EXIT_SUCCESS)))

View File

@ -17,8 +17,10 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash built-ins return)
#:use-module (gash built-ins utils)
#:use-module (gash compat)
#:use-module (gash environment))
#:use-module (gash environment)
#:use-module (ice-9 match))
;;; Commentary:
;;;
@ -27,16 +29,18 @@
;;; Code:
(define (main . args)
(let* ((arg (or (and (pair? args)
(car (last-pair args)))
(number->string (get-status))
"0"))
(number (string->number arg))
(status (or (and (exact-integer? number)
(>= number 0)
(<= number 256)
number)
;; If the above is not true, the exit status is
;; undefined.
EXIT_FAILURE)))
(sh:return status)))
(match args
(() (main (number->string (get-status))))
((arg)
(match (string->exit-status arg)
(#f (format (current-error-port)
"gash: return: argument must be a number from 0 to 255~%")
(throw 'shell-error))
(n (sh:return n)
(format (current-error-port)
(string-append "gash: return: no function "
"or sourced script to return from~%"))
EXIT_SUCCESS)))
(_ (format (current-error-port)
"gash: return: too many arguments~%")
(throw 'shell-error))))

View File

@ -44,8 +44,8 @@
(format (current-error-port)
"~a: shift: Invalid option ~s.~%"
(car (program-arguments)) n-string)
EXIT_FAILURE))))
(throw 'shell-error)))))
(_ (format (current-error-port)
"~a: shift: Invalid options ~s.~%"
(car (program-arguments)) args)
EXIT_FAILURE)))
(throw 'shell-error))))

View File

@ -17,6 +17,7 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash built-ins trap)
#:use-module (gash built-ins utils)
#:use-module (gash compat)
#:use-module (gash environment)
#:use-module (ice-9 match))
@ -54,6 +55,8 @@
(match args
(() "print")
(("--" . args) (main args))
(((? string->nonnegative-integer n) conditions ...)
(apply main (cons "-" args)))
((action conditions ..1)
(let ((handler (action->handler action)))
(for-each (lambda (condition)

View File

@ -1,5 +1,5 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018, 2020 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
@ -26,8 +26,17 @@
;;;
;;; Code:
(define (umask->octal-string mask)
(let* ((octal (number->string mask 8))
(pad-count (- 4 (string-length octal)))
(pad (make-string pad-count #\0)))
(string-append pad octal)))
(define (main . args)
(match args
(()
(format #t "~a~%" (umask->octal-string (umask)))
EXIT_SUCCESS)
((mask)
(let ((n (string->number mask 8)))
(cond

View File

@ -17,10 +17,14 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash built-ins utils)
#:use-module (gash compat)
#:use-module (ice-9 match)
#:export (get-evaluator
built-in?
split-assignment))
split-assignment
string->positive-integer
string->nonnegative-integer
string->exit-status))
;;; Commentary:
;;;
@ -53,3 +57,30 @@
(match (substring assignment (1+ index))
((? string-null?) (values name #f))
(value (values name value)))))))
(define char-set:ascii-digit
(char-set-intersection char-set:ascii char-set:digit))
(define (string->positive-integer s)
"Return the positive integer represented by the string @var{s}. If
@var{s} does not represent a positive, decimal integer return
@code{#f}."
(and=> (and (string-every char-set:ascii-digit s) (string->number s))
(lambda (n)
(and (exact-integer? n) (> n 0) n))))
(define (string->nonnegative-integer s)
"Return the nonnegative integer represented by the string @var{s}.
If @var{s} does not represent a nonnegative, decimal integer return
@code{#f}."
(and=> (and (string-every char-set:ascii-digit s) (string->number s))
(lambda (n)
(and (exact-integer? n) (>= n 0) n))))
(define (string->exit-status s)
"Return the exit status represented by the string @var{s}. If
@var{s} does not represent an exit status (a decimal integer from 0 to
255) return @code{#f}."
(and=> (and (string-every char-set:ascii-digit s) (string->number s))
(lambda (n)
(and (exact-integer? n) (>= n 0) (<= n 255) n))))

40
gash/built-ins/wait.scm Normal file
View File

@ -0,0 +1,40 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash built-ins wait)
#:use-module (gash built-ins utils)
#:use-module (gash compat)
#:use-module (ice-9 match))
;;; Commentary:
;;;
;;; The 'wait' utility.
;;;
;;; Code:
(define (main . args)
(let ((pids (map string->nonnegative-integer args)))
(match pids
((pid)
(match (false-if-exception (waitpid pid))
(#f 127)
((_ . status) (status:exit-val status))))
(_ (format (current-error-port)
"~a: wait: Invalid arguments."
(car (program-arguments)))
EXIT_FAILURE))))

View File

@ -46,7 +46,11 @@
(syntax->datum #'min)
(syntax->datum #'mic))
#'consequent
#'alternate)))))
#'alternate))
((_ (maj min mic) consequent)
#'(if-guile-version-below (maj min mic)
consequent
(if #f #t))))))
(if-guile-version-below (2 0 10)
(begin
@ -55,8 +59,7 @@
(define-public EXIT_FAILURE 1)
(define-public (exact-integer? x)
(and (integer? x) (exact? x))))
#f)
(and (integer? x) (exact? x)))))
(if-guile-version-below (2 2 0)
(begin
@ -66,5 +69,4 @@
('line _IOLBF)
('block _IOFBF))))
((@ (guile) setvbuf) port mode size)))
(export! setvbuf))
#f)
(export! setvbuf)))

41
gash/compat/srfi-43.scm Normal file
View File

@ -0,0 +1,41 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash compat srfi-43)
#:use-module (gash compat))
;;; Commentary:
;;;
;;; The '(srfi srfi-43)' module was introduced into Guile in version
;;; 2.0.10, so we provide a shim.
;;;
;;; Code:
(if-guile-version-below (2 0 10)
(begin
(define-public (vector-empty? vec)
(zero? (vector-length vec)))
;; We only need the single vector version.
(define-public (vector-every pred? vec)
(let loop ((i 0) (value #t))
(if (< i (vector-length vec))
(and value (loop (1+ i) (pred? (vector-ref vec i))))
value))))
(begin
(use-modules (srfi srfi-43))
(re-export vector-empty? vector-every)))

View File

@ -1,5 +1,6 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of Gash.
;;;
@ -32,6 +33,7 @@
(re-export get-char
get-line
get-string-all
put-char
lookahead-char)
(define-public (unget-char port char)
(unread-char char port)))
@ -41,4 +43,5 @@
get-line
get-string-all
lookahead-char
put-char
unget-char)))

View File

@ -33,6 +33,7 @@
read-only?
set-read-only!
with-variables
save-variables-excursion
get-environ
with-environ
getfun
@ -52,7 +53,10 @@
set-atexit!
sh:exit
*fd-count*
fd->current-port))
fd->current-port
get-last-job
set-last-job!
reap-child-processes!))
;;; Commentary:
;;;
@ -114,7 +118,8 @@
(alist->hash-table
(map (match-lambda
((name . value) `(,name . ,(vector value #t #f))))
(append `(("PWD" . ,(initial-pwd env))
(append `(("IFS" . " \t\n")
("PWD" . ,(initial-pwd env))
("SHELL" . ,(car (command-line)))
("SHELLOPTS" . ""))
env)))))
@ -202,6 +207,26 @@ extent of @var{thunk}."
(set! inside-variables *variables*)
(set! outside-variables *variables*)))))
(define (save-variables-excursion names thunk)
"Save the variables listed in @var{names}, and call @var{thunk}. When
@var{thunk}'s dynamic extent is left, restore the variables to their
saved state."
(let ((saved-variables #f))
(dynamic-wind
(lambda ()
(set! saved-variables
(map (lambda (name)
(match (hash-ref *variables* name)
((? vector? vec) (cons name (vector-copy vec)))
(x (cons name x))))
names)))
thunk
(lambda ()
(for-each (match-lambda
((name . #f) (hash-remove! *variables* name))
((name . value) (hash-set! *variables* name value)))
saved-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,
@ -334,8 +359,9 @@ exit the dynamic extent of @var{thunk}."
(define* (sh: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))
@var{n} is set, exit to the @math{n + 1}th closest invocation. If not
called from within @code{call-with-continue}, return @code{#f}."
(false-if-exception (abort-to-prompt *continue-tag* n)))
(define *break-tag* (make-prompt-tag))
@ -351,8 +377,9 @@ exit the dynamic extent of @var{thunk}."
(define* (sh: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))
@var{n} is set, exit to the @math{n + 1}th closest invocation. If not
called from within @code{call-with-break}, return @code{#f}."
(false-if-exception (abort-to-prompt *break-tag* n)))
(define *return-tag* (make-prompt-tag))
@ -367,8 +394,9 @@ exit the dynamic extent of @var{thunk}."
(define* (sh:return #:optional (status (get-status)))
"Exit to the closest invocation of @code{call-with-return} setting
status to @var{status}. If @var{status} is not set, keep the current
status."
(abort-to-prompt *return-tag* status))
status. If not called from within @code{call-with-return}, return
@code{#f}."
(false-if-exception (abort-to-prompt *return-tag* status)))
(define *atexit* #f)
(define *exiting?* #f)
@ -413,3 +441,21 @@ status."
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))))
;;; Jobs.
(define *last-job* #f)
(define (get-last-job)
*last-job*)
(define (set-last-job! pid)
(set! *last-job* pid))
(define (reap-child-processes!)
(let loop ()
(match (false-if-exception (waitpid WAIT_ANY WNOHANG))
(#f #t)
((0 . _) #t)
((pid . status) (loop)))))

View File

@ -18,14 +18,17 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash eval)
#:use-module (gash arithmetic)
#:use-module (gash compat)
#:use-module (gash environment)
#:use-module (gash pattern)
#:use-module (gash shell)
#:use-module (gash word)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (eval-sh))
#:export (eval-word
eval-sh))
;;; Commentary:
;;;
@ -33,8 +36,95 @@
;;;
;;; Code:
(define* (eval-word word #:key (output 'fields) (rhs-tildes? #f))
(define eval-cmd-sub
(make-parameter (lambda (exps) (throw 'eval-cmd-sub-unset))))
(define (string-not-null? str)
"Check if @var{str} is a non-null string."
(and (string? str) (not (string-null? str))))
(define (word->qword word)
"Convert @var{word} into a qword by resolving all parameter, command,
and arithmetic substitions."
(match word
((? string?)
word)
(('<sh-quote> quoted-word)
`(<sh-quote> ,(word->qword quoted-word)))
(('<sh-cmd-sub> . exps)
((eval-cmd-sub) exps))
(('<sh-arithmetic> word)
(let* ((arithmetic (expand-word word #:output 'string))
(expr `(begin (use-modules (gash environment))
(number->string ,(read-arithmetic arithmetic)))))
(eval expr (interaction-environment))))
(('<sh-ref> name)
(parameter-ref name ""))
(('<sh-ref-or> name default)
(or (parameter-ref name)
(word->qword (or default ""))))
(('<sh-ref-or*> name default)
(let ((value (parameter-ref name)))
(if (string-not-null? value)
value
(word->qword (or default "")))))
(('<sh-ref-or!> name default)
(or (parameter-ref name)
(let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t)))
(setvar! name new-value)
new-value)))
(('<sh-ref-or!*> name default)
(let ((value (parameter-ref name)))
(if (string-not-null? value)
value
(let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t)))
(setvar! name new-value)
new-value))))
(('<sh-ref-assert> name message)
(or (parameter-ref name)
(let ((message* (expand-word message #:output 'string)))
(throw 'shell-error (format #f "~a: ~a" name message*)))))
(('<sh-ref-assert*> name message)
(let ((value (parameter-ref name)))
(if (string-not-null? value)
value
(let ((message* (expand-word message #:output 'string)))
(throw 'shell-error (format #f "~a: ~a" name message*))))))
(('<sh-ref-and> name value)
(or (and (parameter-ref name)
(word->qword (or value "")))
""))
(('<sh-ref-and*> name value)
(if (string-not-null? (parameter-ref name))
(word->qword (or value ""))
""))
(('<sh-ref-except-min> name pattern-word)
(let ((pattern (expand-word pattern-word #:output 'pattern)))
(pattern-drop-right pattern (parameter-ref name ""))))
(('<sh-ref-except-max> name pattern-word)
(let ((pattern (expand-word pattern-word #:output 'pattern)))
(pattern-drop-right pattern (parameter-ref name "") #:greedy? #t)))
(('<sh-ref-skip-min> name pattern-word)
(let ((pattern (expand-word pattern-word #:output 'pattern)))
(pattern-drop pattern (parameter-ref name ""))))
(('<sh-ref-skip-max> name pattern-word)
(let ((pattern (expand-word pattern-word #:output 'pattern)))
(pattern-drop pattern (parameter-ref name "") #:greedy? #t)))
(('<sh-ref-length> name)
(number->string (string-length (parameter-ref name ""))))
(_ (map word->qword word))))
(define* (expand-word word #:key (output 'fields) (rhs-tildes? #f))
"Expand @var{word} into a list of fields."
(let ((qword (word->qword word)))
(expand-qword qword #:output output #:rhs-tildes? rhs-tildes?)))
(define* (eval-word word #:key (output 'fields) (rhs-tildes? #f)
(on-command-substitution noop))
(parameterize ((eval-cmd-sub (lambda (exps)
(on-command-substitution)
(sh:substitute-command
(lambda ()
(for-each eval-sh exps))))))
@ -57,7 +147,7 @@
;; XXX: See comment in `exps->thunk'.
(if exp
(lambda () (eval-sh exp))
noop))
(lambda () (set-status! 0))))
(define (exps->thunk exps)
;; XXX: It probably makes more sense to exclude '#f' expressions at
@ -66,13 +156,15 @@
(match (filter values exps)
(() noop)
(exps (lambda () (eval-sh `(<sh-begin> ,@exps)))))
noop))
(lambda () (set-status! 0))))
(define (eval-sh exp)
"Evaluate the Shell expression @var{exp}."
(match exp
(('<sh-and> exp1 exp2)
(sh:and (exp->thunk exp1) (exp->thunk exp2)))
(('<sh-async> sub-exp)
(sh:async (exp->thunk sub-exp)))
(('<sh-begin> . sub-exps)
(for-each eval-sh sub-exps))
(('<sh-case> word (pattern-lists . sub-exp-lists) ...)
@ -124,11 +216,15 @@
(('<sh-pipeline> cmd*s ..1)
(apply sh:pipeline (map exp->thunk cmd*s)))
(('<sh-set!> (names words) ..1)
(for-each (lambda (name word)
(setvar! name (eval-word word
#:output 'string
#:rhs-tildes? #t)))
names words))
(let* ((command-substitution? #f)
(thunk (lambda () (set! command-substitution? #t))))
(for-each (lambda (name word)
(setvar! name (eval-word word
#:output 'string
#:rhs-tildes? #t
#:on-command-substitution thunk)))
names words)
(unless command-substitution? (set-status! 0))))
(('<sh-subshell> . sub-exps)
(sh:subshell (exps->thunk sub-exps)))
(('<sh-while> test-exp sub-exps ..1)

View File

@ -3,6 +3,14 @@
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; The careful invocation of 'seclocale' was taken from the
;;; 'module/ice-9/top-repl.scm' file in GNU Guile, which has the
;;; following copyright notice:
;;;
;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
;;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2013 Free
;;; Software Foundation, Inc.
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software; you can redistribute it and/or modify it
@ -19,6 +27,7 @@
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (gash gash)
#:use-module (gash compat)
#:use-module (gash config)
#:use-module (gash environment)
#:use-module (gash eval)
@ -42,6 +51,17 @@
(lambda (key . args)
(use-modules (gash readline)))))
;; This is done automatically since Guile 2.2.
(if-guile-version-below (2 2 0)
(and (defined? 'setlocale)
(catch 'system-error
(lambda ()
(setlocale LC_ALL ""))
(lambda (key subr fmt args errno)
(format (current-error-port)
"warning: failed to install locale: ~a~%"
(strerror (car errno)))))))
(define (display-help)
(display (string-append "\
Usage: gash [OPTION]... [FILE]...
@ -110,7 +130,8 @@ There is NO WARRANTY, to the extent permitted by law.
(not (string-null? line)))
(unless parse?
(eval-sh ast))
(add-history line))
(add-history line)
(reap-child-processes!))
(loop (let ((previous (if ast "" (string-append line "\n")))
(next (readline (if ast (prompt) "> "))))
(if (eof-object? next) next

View File

@ -1,5 +1,5 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2017, 2018 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2017, 2018, 2020, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
@ -100,7 +100,12 @@
(define (operator-prefix? str)
(any (cut string-prefix? str <>) (map car *operators*)))
(define operator-prefix-char? (compose operator-prefix? string))
(define operator-prefix-char?
(let ((prefix-chars (delete-duplicates
(map (match-lambda
((str . _) (string-ref str 0)))
*operators*))))
(cut memv <> prefix-chars)))
(define blank? (cut char-set-contains? char-set:blank <>))
@ -166,7 +171,7 @@
'()
lst))
(define (next-char port)
(define-inlinable (next-char port)
"Advance @var{port} by one character and return the lookahead
character."
(get-char port)
@ -180,7 +185,8 @@ character."
(define read-backquoted-command
;; A procedure for reading a backquoted command (e.g, "`command`").
;; This is parameterized to avoid a circular dependency.
(make-parameter (lambda (port) (throw 'backquoted-command-parser-unset))))
(make-parameter (lambda* (port #:key quoted?)
(throw 'backquoted-command-parser-unset))))
(define* (get-parameter port #:key (multidigit? #f))
"Get a parameter name (excluding the leading '$') from @var{port}.
@ -319,6 +325,48 @@ leading '$')."
((op "LINENO" x) `(,op ("LINENO" . ,(1+ (port-line port))) ,x))
(_ result))))
(define (get-arithmetic-expansion port)
"Get an arithmetic expansion from @var{port}."
(define (get-arithmetic-expansion-string port)
(let loop ((chr (lookahead-char port)) (acc '()))
(match chr
((? eof-object?) (throw 'lex-error))
((or #\( #\) #\$ #\` #\\) (list->string (reverse! acc)))
(_ (loop (next-char port) (cons chr acc))))))
(match (list (get-char port) (get-char port))
((#\( #\()
(let loop ((chr (lookahead-char port)) (depth 0) (acc '()))
(match chr
(#\( (loop (next-char port) (1+ depth) (cons "(" acc)))
(#\) (cond
((and (zero? depth) (equal? (next-char port) #\)))
(get-char port)
`(<sh-arithmetic>
,(match (join-contiguous-strings (reverse! acc))
(() "")
((word) word)
(words words))))
((positive? depth)
(loop (next-char port) (1- depth) (cons ")" acc)))
(else
(throw 'lex-error))))
((or #\$ #\`)
(let ((expansion (get-expansion port)))
(loop (lookahead-char port)
depth
(cons (or expansion (string chr)) acc))))
(#\\ (let ((escape (get-escape port
(cut member <> '(#\$ #\` #\\)))))
(loop (lookahead-char port) depth (append escape acc))))
(_ (let ((str (get-arithmetic-expansion-string port)))
(loop (lookahead-char port)
depth
(if (not (string-null? str))
(cons str acc)
acc)))))))))
(define (get-bracketed-command port)
"Get a bracketed command ('$(...)') from @var{port} (excluding the
leading '$')."
@ -328,24 +376,31 @@ leading '$')."
(match (get-char port)
(#\) `(<sh-cmd-sub> ,@result)))))))
(define (get-backquoted-command port)
"Get a backquoted command ('`...`') from @var{port}."
(define* (get-backquoted-command port #:key quoted?)
"Get a backquoted command ('`...`') from @var{port}. If
@var{quoted?} is set, treat the backquoted command as if it were
quoted."
(match (get-char port)
(#\`
(let ((result ((read-backquoted-command) port)))
(let ((result ((read-backquoted-command) port #:quoted? quoted?)))
(match (get-char port)
(#\` `(<sh-cmd-sub> ,@result)))))))
(define (get-expansion port)
(define* (get-expansion port #:key quoted?)
"Get an expansion ('$name', '${...}', '$(...)', or '`...`') from
@var{port}."
@var{port}. If @var{quoted?} is set, treat backquoted commands as if
they were quoted."
(match (lookahead-char port)
(#\$ (begin
(get-char port)
(match (lookahead-char port)
(#\( (get-bracketed-command port))
(#\( (let ((next (next-char port)))
(unget-char port #\()
(match next
(#\( (get-arithmetic-expansion port))
(_ (get-bracketed-command port)))))
(_ (get-parameter-expansion port)))))
(#\` (get-backquoted-command port))))
(#\` (get-backquoted-command port #:quoted? quoted?))))
;; When this parameter is true, expansion processing is enabled.
(define expansions? (make-parameter #t))
@ -395,7 +450,7 @@ next character statisfies @var{pred} (or is a newline)."
(words words)))))
((or #\$ #\`)
(if (expansions?)
(let ((expansion (get-expansion port)))
(let ((expansion (get-expansion port #:quoted? #t)))
(loop (lookahead-char port)
(cons (or expansion (string chr)) acc)))
(loop (next-char port) (cons (string chr) acc))))

View File

@ -398,6 +398,8 @@ the same number of times.)"
(LPAREN! pattern RPAREN! compound-list DSEMI linebreak)
: `(,$2 ,@$4))
;; If this rule is updated, the hooked version given below must be
;; updated as well.
(pattern
(WORD*-without-Esac)
: `(,$1)
@ -683,11 +685,14 @@ the same number of times.)"
;; Sometimes a "pattern" non-terminal comes before an unbalanced
;; "RPAREN". This reduction hook can be used to pretend that we
;; encountered an "LPAREN".
;; encountered an "LPAREN". It should match the unhooked one given
;; above.
(pattern!
(pattern)
: (begin (open-bracket-hook) $1))))
(WORD*-without-Esac)
: (begin (open-bracket-hook) `(,$1))
(pattern! PIPE WORD*)
: (append $1 `(,$3)))))
(define* (syntax-error message #:optional token)
"Handle a parser error"
@ -750,10 +755,17 @@ ignored."
(((? symbol? tag) . rest) `((,tag . ,rest)))
(code code)))
(define (call-with-backquoted-input-port port proc)
(define* (call-with-backquoted-input-port port proc #:key quoted?)
"Call @var{proc} with a wrapped version of @var{port} that will
return the end-of-file object upon encountering an unescaped backquote
\"`\" (without consuming the backquote)."
\"`\" (without consuming the backquote). If @var{quoted?} is set,
treat the double quote character as escapable."
(define (escape-char? chr)
(or (char=? chr #\$)
(char=? chr #\`)
(char=? chr #\\)
(and quoted? (char=? chr #\"))))
(define wrapped-port
(make-soft-port
(vector
@ -766,7 +778,7 @@ return the end-of-file object upon encountering an unescaped backquote
(#\\ (begin
(get-char port)
(match (lookahead-char port)
((or #\$ #\` #\\) (get-char port))
((? escape-char?) (get-char port))
(_ #\\))))
(_ (get-char port))))
;; close-port
@ -796,24 +808,24 @@ bracket."
#:open-bracket-hook incr-bracket-depth!
#:close-bracket-hook decr-bracket-depth!)))
(define (read-sh/backquoted port)
"Read Shell code from @var{port} until the first unescaped backquote."
(define* (read-sh/backquoted port #:key quoted?)
"Read Shell code from @var{port} until the first unescaped
backquote. If @var{quoted?} is set, treat the double quote character
as escapable."
(call-with-backquoted-input-port port
(lambda (port)
(->command-list (parse port)))))
(->command-list (parse port)))
#:quoted? quoted?))
(define* (read-sh #:optional (port #f))
(define* (read-sh #:optional (port (current-input-port)))
"Read a complete Shell command from @var{port} (or the current input
port if @var{port} is unspecified)."
(define stop? #f)
(define (stop!) (set! stop? #t))
(parse port #:lex-hook (lambda (lex) (if stop? '*eoi* (lex)))
#:command-hook stop!))
(let* ((port (or port (current-output-port))))
(parse port #:lex-hook (lambda (lex) (if stop? '*eoi* (lex)))
#:command-hook stop!)))
(define* (read-sh-all #:optional (port #f))
(define* (read-sh-all #:optional (port (current-input-port)))
"Read all complete Shell commands from @var{port} (or the current
input port if @var{port} is unspecified)."
(->command-list (parse (or port (current-input-port)))))
(->command-list (parse port)))

View File

@ -1,5 +1,5 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
@ -20,11 +20,21 @@
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (gash compat srfi-43)
#:export (parse-pattern
pattern-quote
pattern-null?
pattern-plain?
pattern-match?))
pattern-match?
pattern-drop
pattern-drop-right))
(define-immutable-record-type <pattern>
(make-pattern parts)
pattern?
(parts pattern-parts))
(define* (parse-rdelim s1 s2 #:optional (start 0) (end (string-length s1)))
@ -72,42 +82,48 @@
(define* (parse-matching-bracket-expression s #:optional (start 0)
(end (string-length s)))
(let loop ((i start) (acc '()))
(let loop ((i start) (acc '()) (errors '()))
(match (and (< i end) (string-ref s i))
(#f (values #f 0))
(#\] (if (= i start)
(loop (1+ i) (cons #\] acc))
(values (list->char-set acc) (1+ (- i start)))))
(loop (1+ i) (cons #\] acc) errors)
(match errors
(() (values (list->char-set acc) (1+ (- i start))))
(_ (throw (last errors))))))
(#\[ (match (and (< (1+ i) end) (string-ref s (1+ i)))
(#\. (receive (result length)
(parse-collating-symbol s (+ i 2) end)
(if result
(throw 'pattern-collating-symbol)
(loop (1+ i) (cons #\[ acc)))))
(loop (+ i length 1) acc
(cons 'pattern-collating-symbol errors))
(loop (1+ i) (cons #\[ acc) errors))))
(#\= (receive (result length)
(parse-equivalence-class s (+ i 2) end)
(if result
(throw 'pattern-equivalence-class)
(loop (1+ i) (cons #\[ acc)))))
(loop (+ i length 1) acc
(cons 'pattern-equivalence-class errors))
(loop (1+ i) (cons #\[ acc) errors))))
(#\: (receive (result length)
(parse-character-class s (+ i 2) end)
(if result
(throw 'pattern-character-class)
(loop (1+ i) (cons #\[ acc)))))
(_ (loop (1+ i) (cons #\[ acc)))))
(loop (+ i length 1) acc
(cons 'pattern-character-class errors))
(loop (1+ i) (cons #\[ acc) errors))))
(_ (loop (1+ i) (cons #\[ acc) errors))))
(#\- (if (or (= i start)
(and (< (1+ i) end) (char=? (string-ref s (1+ i)) #\])))
(loop (1+ i) (cons #\- acc))
(loop (1+ i) (cons #\- acc) errors)
(let ((alpha (and (pair? acc) (car acc)))
;; XXX: Escaped range end?
(omega (and (< (1+ i) end) (string-ref s (1+ i)))))
(match (character-range alpha omega)
(#f (throw 'pattern-range-expression))
(chrs (loop (+ i 2) (append chrs acc)))))))
(#f (loop (+ i 2) acc
(cons 'pattern-range-expression errors)))
(chrs (loop (+ i 2) (append chrs acc) errors))))))
(#\\ (if (< (1+ i) end)
(loop (+ i 2) (cons (string-ref s (1+ i)) acc))
(loop (1+ i) acc)))
(chr (loop (1+ i) (cons chr acc))))))
(loop (+ i 2) (cons (string-ref s (1+ i)) acc) errors)
(loop (1+ i) acc errors)))
(chr (loop (1+ i) (cons chr acc) errors)))))
(define* (parse-bracket-expression s #:optional (start 0)
(end (string-length s)))
@ -119,28 +135,41 @@
(values result length)
(values (char-set-complement! result) (1+ length))))))
(define* (parse-pattern s #:optional (start 0) (end (string-length s)))
"Parse the string @var{s} as a pattern."
(let loop ((i start) (parts '()) (acc '()))
(define* (parse-part s #:optional (start 0) (end (string-length s)))
(let loop ((i start) (acc '()))
(match (and (< i end) (string-ref s i))
(#f (if (null? acc)
(reverse! parts)
(reverse! (cons (reverse! acc) parts))))
(#\* (if (null? acc)
(loop (1+ i) (cons '* parts) '())
(loop (1+ i) (cons* '* (reverse! acc) parts) '())))
(#\? (loop (1+ i) parts (cons '? acc)))
(#f (match acc
(() (values #f 0))
(_ (values (list->vector (reverse! acc)) (- i start)))))
(#\* (match acc
(() (values '* 1))
(_ (values (list->vector (reverse! acc)) (- i start)))))
(#\? (loop (1+ i) (cons char-set:full acc)))
(#\[ (if (< (1+ i) end)
(receive (result length)
(parse-bracket-expression s (1+ i) end)
(if result
(loop (+ i length 1) parts (cons result acc))
(loop (1+ i) parts (cons #\[ acc))))
(loop (1+ i) parts (cons #\[ acc))))
(loop (+ i length 1) (cons result acc))
(loop (1+ i) (cons #\[ acc))))
(loop (1+ i) (cons #\[ acc))))
(#\\ (if (< (1+ i) end)
(loop (+ i 2) parts (cons (string-ref s (1+ i)) acc))
(loop (1+ i) parts acc)))
(chr (loop (1+ i) parts (cons chr acc))))))
(loop (+ i 2) (cons (string-ref s (1+ i)) acc))
(loop (1+ i) acc)))
(chr (loop (1+ i) (cons chr acc))))))
(define* (parse-pattern s #:optional (start 0) (end (string-length s)))
"Parse the string @var{s} as a pattern."
(let loop ((i start) (parts '()))
(receive (part length) (parse-part s i end)
(match part
(#f (make-pattern (reverse! parts)))
('* (match parts
(() (loop (+ i length) (list #() #())))
((#() . _) (loop (+ i length) parts))
(_ (loop (+ i length) (cons #() parts)))))
(_ (match parts
((#() . rest) (loop (+ i length) (cons part rest)))
(_ (loop (+ i length) (cons part parts)))))))))
(define pattern-quote
(let ((specials '(#\\ #\* #\? #\[ #\] #\! #\-)))
@ -155,99 +184,123 @@ them are treated specially when @var{s} is interpreted as a pattern."
'()
s)))))
(define (pattern-null? pattern)
(match (pattern-parts pattern)
(() #t)
((part) (vector-empty? part))
(_ #f)))
(define (pattern-plain? pattern)
"Check if @var{pattern} free of special pattern constructions like
asterisks and bracket expressions. If a pattern is ``plain'' its
source string is the only string that will match it."
(every (match-lambda
('* #f)
(parts (every (match-lambda
((or (? char?) (? string?)) #t)
(_ #f))
parts)))
pattern))
(match (pattern-parts pattern)
(() #t)
((part) (vector-every char? part))
(_ #f)))
(define* (string-starts-with-part s part #:optional (start 0)
(end (string-length s)))
(let loop ((part part) (i start))
(match (and (< i end) part)
(#f (match part
(() (- i start))
(((? string? s2) . rest)
(and (string-null? s2)
(loop rest i)))
(_ #f)))
(() (- i start))
(('? . rest) (loop rest (1+ i)))
(((? string? s2) . rest)
(and (string-prefix? s2 s 0 (string-length s2) i end)
(loop rest (+ i (string-length s2)))))
(((? char? chr) . rest)
(and (char=? (string-ref s i) chr)
(loop rest (1+ i))))
(((? char-set? cs) . rest)
(and (char-set-contains? cs (string-ref s i))
(loop rest (1+ i)))))))
(define (pattern-part-length part)
(let loop ((part part) (length 0))
(match part
(() length)
(((? string? str) . rest) (loop rest (+ length (string-length str))))
((first . rest) (loop rest (1+ length))))))
(and (<= (vector-length part) (- end start))
(let loop ((i 0) (j start))
(match (and (< i (vector-length part)) (vector-ref part i))
(#f #t)
((? char? chr)
(and (char=? (string-ref s j) chr)
(loop (1+ i) (1+ j))))
((? char-set? cs)
(and (char-set-contains? cs (string-ref s j))
(loop (1+ i) (1+ j))))))))
(define* (string-ends-with-part s part #:optional (start 0)
(end (string-length s)))
(let ((start* (- end (pattern-part-length part))))
(let ((start* (- end (vector-length part))))
(and (>= start* start)
(string-starts-with-part s part start* end))))
(define* (string-contains-part s part #:optional (start 0)
(end (string-length s)))
(let loop ((part part) (i start))
(match part
(() (cons start (- i start)))
(('? . rest) (loop rest (1+ i)))
(((? string? s2) . rest)
(and=> (string-contains s s2 i end)
(lambda (index)
(or (and=> (string-starts-with-part s part index end)
(cut cons index <>))
(loop part (1+ index))))))
(((or (? char? cp) (? char-set? cp)) . rest)
(and=> (string-index s cp i end)
(lambda (index)
(or (and=> (string-starts-with-part s part index end)
(cut cons index <>))
(loop part (1+ index)))))))))
(let loop ((i start))
(cond
((>= i end) #f)
((string-starts-with-part s part i end) i)
(else (loop (1+ i))))))
(define* (string-contains-part-right s part #:optional (start 0)
(end (string-length s)))
(let loop ((i end))
(cond
((< i start) #f)
((string-ends-with-part s part start i) (- i (vector-length part)))
(else (loop (1- i))))))
(define* (pattern-match? pattern str #:optional (start 0)
(end (string-length str))
#:key explicit-initial-period?)
"Check if @var{str} matches @var{pattern}."
(if (and explicit-initial-period?
(< start end)
(char=? (string-ref str start) #\.))
(match pattern
(((#\. . _) . _)
(pattern-match? pattern str start end
#:explicit-initial-period? #f))
((((? string? s) . _) ._)
(and (string-prefix? "." s)
(pattern-match? pattern str start end
#:explicit-initial-period? #f)))
(_ #f))
(let loop ((pattern pattern) (i start))
(match pattern
(() (= i end))
(('*) #t)
(('* (? pair? part)) (string-ends-with-part str part i end))
(('* (? pair? part) . rest)
(and=> (string-contains-part str part i end)
(match-lambda
((match-index . match-length)
(loop rest (+ match-index match-length))))))
(((? pair? part) . rest)
(and=> (string-starts-with-part str part i end)
(lambda (length)
(loop rest (+ i length)))))))))
(define (parts-match? parts start)
(match parts
(() (= start end))
((part) (string-ends-with-part str part start end))
((part . rest)
(and=> (string-contains-part str part start end)
(lambda (m)
(let ((start* (+ m (vector-length part))))
(parts-match? rest start*)))))))
(match-let ((($ <pattern> parts) pattern))
(if (and explicit-initial-period?
(< start end)
(char=? (string-ref str start) #\.))
(match parts
((#(#\. _ ...) . _)
(pattern-match? pattern str start end
#:explicit-initial-period? #f))
(_ #f))
(match parts
(() (= start end))
((part . rest)
(and (string-starts-with-part str part start end)
(let ((start* (+ start (vector-length part))))
(parts-match? rest start*))))))))
(define* (pattern-drop pattern str #:key greedy?)
(define (match-parts parts i)
(match parts
(() (substring str i))
((part . rest)
(match (if (and greedy? (null? rest))
(string-contains-part-right str part i)
(string-contains-part str part i))
(#f str)
(m (match-parts rest (+ m (vector-length part))))))))
(match-let ((($ <pattern> parts) pattern))
(match parts
(() str)
((part . rest)
(if (string-starts-with-part str part)
(match-parts rest (vector-length part))
str)))))
(define* (pattern-drop-right pattern str #:key greedy?)
(define (match-parts parts i)
(match parts
(() (substring str 0 i))
((part . rest)
(match (if (and greedy? (null? rest))
(string-contains-part str part 0 i)
(string-contains-part-right str part 0 i))
(#f str)
(m (match-parts rest m))))))
(match-let ((($ <pattern> parts) pattern))
(let ((strap (reverse parts)))
(match strap
(() str)
((part . rest)
(if (string-ends-with-part str part)
(let ((i (- (string-length str) (vector-length part))))
(match-parts rest i))
str))))))

View File

@ -36,4 +36,5 @@
((? eof-object?) (sh:exit))
(_ (if parse? (format #t "~a\n" exp)
(eval-sh exp))
(reap-child-processes!)
(loop (read-sh port))))))

View File

@ -1,5 +1,5 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018, 2019, 2020 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
@ -18,6 +18,7 @@
(define-module (gash shell)
#:use-module (gash built-ins)
#:use-module (gash compat)
#:use-module (gash compat textual-ports)
#:use-module (gash environment)
#:use-module (gash pattern)
@ -25,6 +26,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (sh:and
sh:async
sh:case
sh:cond
sh:exec-let
@ -55,7 +57,7 @@
(define (errexit)
(unless (or (zero? (get-status)) (ignore-errexit?))
(when (getopt 'errexit)
(exit (get-status)))))
(sh:exit))))
(define (install-current-ports!)
"Install all current ports into their usual file descriptors. For
@ -130,20 +132,30 @@ environment variable bindings @var{bindings}."
((name . value)
(setvar! name value)))
bindings)
(let ((exit-val (apply proc args)))
(set-status! exit-val))))
(set-status! (apply proc args))))
(and=> (getfun name)
(lambda (proc)
(with-arguments (cons (car (program-arguments)) args)
(save-variables-excursion (map car bindings)
(lambda ()
(call-with-return
(lambda ()
(apply proc args)))))))
(for-each (match-lambda
((name . value)
(setvar! name value)))
bindings)
(with-arguments (cons (car (program-arguments)) args)
(lambda ()
(call-with-return
(lambda ()
(apply proc args)))))))))
(and=> (search-built-ins name)
(lambda (proc)
;; TODO: Use 'bindings' here.
(let ((exit-val (apply proc args)))
(set-status! exit-val))))
(save-variables-excursion (map car bindings)
(lambda ()
(for-each (match-lambda
((name . value)
(setvar! name value)))
bindings)
(let ((exit-val (apply proc args)))
(set-status! exit-val))))))
(and=> (find-utility name)
(lambda (path)
(exec-utility bindings path name args)))
@ -161,45 +173,49 @@ environment variable bindings @var{bindings}."
;;; Redirects.
(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)."
(define (process-redir redir)
"Convert @var{redir} into a list consisting of the current-port
parameter to be updated, the port that should be its new value (or
@code{#f} if it should be considered closed), and a boolean indicating
if it is our responsibility to close the port."
(define* (make-parameter+port fd target #:optional (open-flags 0))
(define* (make-processed-redir fd target #:optional (open-flags 0))
(let ((port (match target
((? port?) target)
((? string?) (open target open-flags))
;; TODO: Verify open-flags.
((? integer?) ((fd->current-port target)))
(#f #f))))
`(,(fd->current-port fd) . ,port)))
`(,(fd->current-port fd) ,port ,(string? target))))
(match redir
(('< (? integer? fd) (? string? filename))
(make-parameter+port fd filename O_RDONLY))
(make-processed-redir fd filename O_RDONLY))
(('> (? integer? fd) (? string? filename))
;; TODO: Observe noclobber.
(make-parameter+port fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
(let* ((clobber-flags (logior O_WRONLY O_CREAT O_TRUNC))
(flags (if (getopt 'noclobber)
(logior clobber-flags O_EXCL)
clobber-flags)))
(make-processed-redir fd filename flags)))
(('>! (? integer? fd) (? string? filename))
(make-parameter+port fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
(make-processed-redir fd filename (logior O_WRONLY O_CREAT O_TRUNC)))
(('>> fd filename)
(make-parameter+port fd filename (logior O_WRONLY O_CREAT O_APPEND)))
(make-processed-redir fd filename (logior O_WRONLY O_CREAT O_APPEND)))
(('<> fd filename)
(make-parameter+port fd filename (logior O_RDWR O_CREAT)))
(make-processed-redir fd filename (logior O_RDWR O_CREAT)))
(('<& (? integer? fd1) (? integer? fd2))
(make-parameter+port fd1 fd2))
(make-processed-redir fd1 fd2))
(('<& (? integer? fd) '-)
(make-parameter+port fd #f))
(make-processed-redir fd #f))
(('>& (? integer? fd1) (? integer? fd2))
(make-parameter+port fd1 fd2))
(make-processed-redir fd1 fd2))
(('>& (? integer? fd) '-)
(make-parameter+port fd #f))
(make-processed-redir fd #f))
(('<< (? integer? fd) text)
(let ((port (tmpfile)))
(display text port)
(seek port 0 SEEK_SET)
(make-parameter+port fd port)))))
(make-processed-redir fd port)))))
(define (sh:set-redirects redirs)
"Put the redirects @var{redirs} into effect."
@ -207,11 +223,10 @@ parameter to be updated and the port that should be its new value (or
(match redirs
(() #t)
((redir . rest)
(match (false-if-exception
(redir->parameter+port redir))
(match (false-if-exception (process-redir redir))
(#f (set-status! 1)
(errexit))
((parameter . port)
((parameter port close?)
(parameter port)
(loop rest)))))))
@ -222,15 +237,15 @@ parameter to be updated and the port that should be its new value (or
;; only way.
((fold-right (lambda (redir thunk)
(lambda ()
(match (false-if-exception
(redir->parameter+port redir))
(match (false-if-exception (process-redir redir))
(#f (set-status! 1)
(errexit))
((parameter . port)
((parameter port close?)
(parameterize ((parameter port))
(thunk))
(when (output-port? port)
(force-output port))))))
(cond
(close? (close-port port))
((output-port? port) (force-output port)))))))
thunk
redirs)))
@ -245,13 +260,20 @@ process."
;; duplicate output.
(flush-all-ports)
(match (primitive-fork)
(0 (with-continuation-barrier
(lambda ()
(restore-signals)
(set-atexit! #f)
(thunk)
(primitive-exit (get-status))))
(primitive-exit 1))
(0 (dynamic-wind
(lambda () #t)
(lambda ()
(restore-signals)
(set-atexit! #f)
;; We need to preserve the status given to 'exit', so we
;; catch the 'quit' key here.
(catch 'quit
thunk
(lambda (_ status)
(primitive-exit status)))
(primitive-exit (get-status)))
(lambda ()
(primitive-exit 1))))
(pid pid)))
(define (sh:subshell thunk)
@ -279,36 +301,14 @@ a string."
;;; Pipelines.
(define (swap-and-shift-pairs pairs)
"Swap and shift @var{pairs} over by one. For example, the list
@code{((a . b) (c . d))} becomes @code{((#f . b) (a . d) (c . #f))}"
(let ((kons (lambda (pair acc)
(match-let (((a . b) pair))
(match acc
((head . rest) `(,b (,a . ,head) ,@rest))
(() `(,b (,a . #f))))))))
(match (fold-right kons '() pairs)
((head . rest) `((#f . ,head) ,@rest))
(() '()))))
(define (make-pipes xs)
"Cons each element of @var{xs} to a pair of ports such that the first
port is an input port connected to the second port of the previous
element's pair, and the second port is an output port connected to the
first port of next element's pair. The first pair will have @code{#f}
for an input port and the last will have @code{#f} as an output port."
(match xs
(() '())
((x) `((,x . (#f . #f))))
(_ (let ((pipes (map (lambda (x) (pipe)) (cdr xs))))
(map cons xs (swap-and-shift-pairs pipes))))))
(define (plumb in out thunk)
(define (plumb in out close 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
is left unchanged."
is left unchanged. Unless it is @code{#f}, the port @var{close} will
be closed in the new process."
(let* ((thunk* (lambda ()
(when close (close-port close))
(let ((in (or in (current-input-port)))
(out (or out (current-output-port))))
(parameterize ((current-input-port in)
@ -319,18 +319,49 @@ is left unchanged."
(when out (close-port out))
pid))
(define (waitpid/any pids)
"Wait for any process with an ID in the list @var{pids} to terminate
and return its status information."
(let loop ((interval 10))
(or (any (lambda (pid)
(match (waitpid pid WNOHANG)
((0 . _) #f)
(x x)))
pids)
(begin
(usleep interval)
(loop (if (< interval 160)
(* 2 interval)
interval))))))
(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 source sink thunk)))
(make-pipes thunks))))
(define (plumb-thunks)
(let loop ((thunks thunks) (in #f) (pids '()))
(match thunks
(() pids)
((thunk) (reverse! (cons (plumb in #f #f thunk) pids)))
((thunk . rest)
(match-let (((next-in . out) (pipe)))
(loop rest next-in (cons (plumb in out next-in thunk) pids)))))))
(let ((pids (plumb-thunks)))
(unless (null? pids)
(match-let* ((pid (last pids))
((pid . status) (waitpid pid)))
(set-status! (status:exit-val status))
(errexit)))))
(let ((last-pid (last pids)))
;; We have to wait for all the processes to finish so we can
;; reap them. We do this by polling them with 'waitpid'.
;; This is something of a naive approach, but it works for now
;; and will be easier to improve later when we have job
;; control.
(let loop ((pids pids))
(unless (null? pids)
(match (waitpid/any pids)
((pid . status)
(when (= pid last-pid)
(set-status! (status:exit-val status)))
(loop (remove (cut = pid <>) pids)))))))
(errexit))))
;;; Boolean expressions.
@ -411,3 +442,12 @@ of each thunk sent to the input of the next thunk."
(if (= (get-status) 0)
(thunk)
(loop tail))))))
;;; Asynchronous commands.
(define (sh:async thunk)
"Run @var{thunk} asynchronously."
(let ((pid (%subshell thunk)))
(set-last-job! pid)
(set-status! 0)))

View File

@ -1,5 +1,5 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Gash.
;;;
@ -23,8 +23,8 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (eval-cmd-sub
expand-word))
#:export (parameter-ref
expand-qword))
;;; Commentary:
;;;
@ -99,7 +99,7 @@ in the string @var{ifs}."
(string->char-set ifs))
(define char-set:ifs/nw
(char-set-difference char-set:ifs char-set:whitespace))
(string->char-set (string-delete char-set:whitespace ifs)))
(define (wedge-apart-quote qword)
(let loop ((qword (normalize-word qword)) (acc '()))
@ -112,7 +112,9 @@ in the string @var{ifs}."
vals))
acc)))
(((? string? h) . t)
(loop t (cons `(<sh-quote> ,h) acc))))))
(loop t (cons `(<sh-quote> ,h) acc)))
(((qwords ...) . t)
(loop t (append-reverse (wedge-apart-quote qwords) acc))))))
(define (wedge-apart qword)
(match qword
@ -168,59 +170,76 @@ string, the separator is derived from @var{ifs} using
(let ((sep (argument-separator ifs)))
(loop t (cons (string-join vals sep) acc))))
(((? string? h) . t)
(loop t (cons h acc))))))
(loop t (cons h acc)))
(((qwords ...) . t)
(loop t (cons (remove-quotes qwords ifs) acc))))))
(define (qword->pattern qword ifs)
(define (qword->pattern-string qword ifs)
(let loop ((qword (normalize-word qword)) (acc '()))
(match qword
(() (parse-pattern (string-concatenate-reverse acc)))
(() (string-concatenate-reverse acc))
((('<sh-quote> qword*) . t)
(loop t (cons (pattern-quote (remove-quotes qword* ifs)) acc)))
(((? string? h) . t)
(loop t (cons h acc))))))
(define (qword->pattern qword ifs)
(parse-pattern (qword->pattern-string qword ifs)))
(define (find-files base patterns)
"Find all the files starting from @var{base} where each node of the
file's relative path matchs the corresponding pattern in
@var{patterns}."
(define (make-select pattern)
(cut pattern-match? pattern <> #:explicit-initial-period? #t))
(define (ensure-directory path)
(and (scandir (string-append base "/" path))
(string-append path "/")))
(define* (list-directory path pattern)
(map (cond
((string-null? path) values)
((string-every #\/ path) (cut string-append path <>))
(else (cut string-append path "/" <>)))
(or (scandir (string-append base "/" path) (make-select pattern))
'())))
(let loop ((paths (list "")) (patterns patterns))
(match patterns
(() paths)
(((? pattern-null?) . rest)
(loop (filter-map ensure-directory paths) rest))
((pattern . rest)
(loop (append-map (cut list-directory <> pattern) paths) rest)))))
(define (expand-pathnames qword pwd ifs)
"Interpret @var{qword} as a pattern and find all files matching that
pattern. If no files are found, return a singleton list containing a
string version of @var{qword}. If the pattern is relative, @var{pwd}
will be used as the current directory. If @var{qword} contains
preserved fields (e.g., @code{\"$@\"}), @var{ifs} will be used to
faltten them."
(define absolute?
(match-lambda
(((? pattern-null?) . _) #t)
(_ #f)))
(define (list-matches patterns)
(let loop ((stack `(("" ,@patterns))) (acc '()))
(match stack
(() (reverse! acc))
(((path) . stack-tail)
(loop stack-tail (cons path acc)))
(((path pattern . next-patterns) . stack-tail)
(match (scandir (string-append pwd "/" path)
(cut pattern-match? pattern <>
#:explicit-initial-period? #t))
(#f (loop stack-tail acc))
(files (loop (append (map (lambda (file)
(if (string-null? path)
(cons file next-patterns)
(cons (string-append path "/" file)
next-patterns)))
files)
stack-tail)
acc)))))))
(let ((patterns (map (cut qword->pattern <> ifs)
(split-fields qword "/"))))
(if (every pattern-plain? patterns)
`(,(remove-quotes qword ifs))
(match (list-matches patterns)
(() `(,(remove-quotes qword ifs)))
(matches matches)))))
(define eval-cmd-sub
;; A procedure for evaluating (expanding) a command substitution.
;; This is parameterized to avoid a circular dependency.
(make-parameter (lambda (exps) (throw 'eval-cmd-sub-unset))))
(define (string-not-null? str)
"Check if @var{str} is a non-null string."
(and (string? str) (not (string-null? str))))
(if (getopt 'noglob)
`(,(remove-quotes qword ifs))
(let* ((pattern-string (qword->pattern-string qword ifs))
(patterns (map parse-pattern (string-split pattern-string #\/)))
(base (if (absolute? patterns) "/" pwd)))
(if (every pattern-plain? patterns)
`(,(remove-quotes qword ifs))
(match (find-files base patterns)
(() `(,(remove-quotes qword ifs)))
(matches matches))))))
(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}."
the environment. If @var{name} is unset, return @var{dflt} if
provided or @code{#f} if not."
(match name
("@" `(<sh-at> ,(cdr (program-arguments))))
("*" (let* ((ifs (or (getvar "IFS")
@ -231,6 +250,8 @@ the environment. If @var{name} is unset, return @code{#f}."
("#" (number->string (length (cdr (program-arguments)))))
("?" (number->string (get-status)))
("$" (number->string (get-root-pid)))
("!" (cond ((get-last-job) => number->string)
(else dflt)))
(("LINENO" . line) (number->string line))
(x (let ((n (string->number x)))
(if (and n (integer? n) (> n 0)
@ -238,71 +259,10 @@ the environment. If @var{name} is unset, return @code{#f}."
(list-ref (program-arguments) n)
(getvar name dflt))))))
(define (word->qword word)
"Convert @var{word} into a qword by resolving all parameter, command,
and arithmetic substitions."
(match word
((? string?)
word)
(('<sh-quote> quoted-word)
`(<sh-quote> ,(word->qword quoted-word)))
(('<sh-cmd-sub> . exps)
((eval-cmd-sub) exps))
(('<sh-ref> name)
(parameter-ref name ""))
(('<sh-ref-or> name default)
(or (parameter-ref name)
(word->qword (or default ""))))
(('<sh-ref-or*> name default)
(let ((value (parameter-ref name)))
(if (string-not-null? value)
value
(word->qword (or default "")))))
(('<sh-ref-or!> name default)
(or (parameter-ref name)
(let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t)))
(setvar! name new-value)
new-value)))
(('<sh-ref-or!*> name default)
(let ((value (parameter-ref name)))
(if (string-not-null? value)
value
(let ((new-value (expand-word (or default "")
#:output 'string #:rhs-tildes? #t)))
(setvar! name new-value)
new-value))))
(('<sh-ref-assert> name message)
(error (format #f "Not implemented: ~s" word)))
(('<sh-ref-assert*> name message)
(error (format #f "Not implemented: ~s" word)))
(('<sh-ref-and> name value)
(if (string-not-null? (parameter-ref name))
(word->qword (or value ""))
""))
(('<sh-ref-and*> name value)
(or (and (parameter-ref name)
(word->qword (or value "")))
""))
(('<sh-ref-except-min> name pattern)
(error (format #f "Not implemented: ~s" word)))
(('<sh-ref-except-max> name pattern)
(error (format #f "Not implemented: ~s" word)))
(('<sh-ref-skip-min> name pattern)
(error (format #f "Not implemented: ~s" word)))
(('<sh-ref-skip-max> name pattern)
(error (format #f "Not implemented: ~s" word)))
(('<sh-ref-length> name)
(number->string (string-length (parameter-ref name ""))))
(_ (map word->qword word))))
(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 word))
(ifs (getvar "IFS" (string #\space #\tab #\newline)))
(pwd (getvar "PWD")))
(define* (expand-qword qword #:key (output 'fields) (rhs-tildes? #f))
"Expand @var{qword} into a list of fields."
(let ((ifs (getvar "IFS" (string #\space #\tab #\newline)))
(pwd (getvar "PWD")))
(match output
('fields (if pwd
(append-map (cut expand-pathnames <> pwd ifs)

View File

@ -16,6 +16,7 @@
(gnu packages guile)
(gnu packages pkg-config)
(gnu packages texinfo)
(gnu packages version-control)
(guix build utils)
(guix build-system gnu)
(guix download)
@ -56,7 +57,8 @@
(error "Cannot make file selector")))
(lambda (file stat)
(let ((relative (substring file (1+ (string-length *srcdir*)))))
(or (eq? (stat:type stat) 'directory)
(or (string=? relative ".git")
(string-prefix? ".git/" relative)
(member relative paths)))))
(define guile-2.0.9
@ -83,11 +85,12 @@
(native-inputs
`(("autoconf" ,autoconf)
("automake" ,automake)
("git" ,git-minimal)
("lcov" ,lcov) ; For generating test coverage data
("pkg-config" ,pkg-config)
("texinfo" ,texinfo)))
(inputs
`(("guile" ,guile-2.2)))
`(("guile" ,guile-3.0)))
(home-page "https://savannah.nongnu.org/projects/gash/")
(synopsis "POSIX-compatible shell written in Guile Scheme")
(description "Gash is a POSIX-compatible shell written in Guile

38
language/sh/spec.scm Normal file
View File

@ -0,0 +1,38 @@
;;; Gash --- Guile As SHell
;;; Copyright © 2020 Stephen J. Scheck <sscheck@singularsyntax.one>
;;;
;;; This file is part of Gash.
;;;
;;; Gash is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Gash is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Gash. If not, see <http://www.gnu.org/licenses/>.
(define-module (language sh spec)
#:use-module (gash environment)
#:use-module (gash eval)
#:use-module (gash parser)
#:use-module (system base language)
#:export (sh))
;;; Commentary:
;;;
;;; This module contains the language spec definition that extends
;;; Guile allowing use of shell syntax from the REPL by invocation
;;; of the ,language meta-command.
;;;
;;; Code:
(define-language sh
#:title "Guile as Shell"
#:reader (lambda (port env) (read-sh port))
#:evaluator (lambda (x module) (eval-sh x) (get-status))
#:printer write)

53
test.sh
View File

@ -1,53 +0,0 @@
# Gash --- Guile As SHell
# Copyright © 2016, 2017 R.E.W. van Beusekom <rutger.van.beusekom@gmail.com>
# Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
# Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
#
# This file is part of Gash.
#
# Gash is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# Gash is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Gash. If not, see <http://www.gnu.org/licenses/>.
set -e
if [ -n "$V" ]; then
set -x
fi
DIFF=${DIFF-diff}
TEST_SHELL=${TEST_SHELL-gash}
t="$1"
s=tests/$(basename "$t" .sh)
# This is a hack to make sure we can build from an external directory.
# We move into the source directory, and then send all of our output
# back to the build directory.
export TEST_TMP=$(pwd)
b=$(pwd)/$s
cd $(dirname "$t")/..
set +e
timeout 10 $TEST_SHELL -e "$s".sh -s --long file0 file1 > "$b".1 2> "$b".2
r=$?
set -e
if [ -f "$s".exit ]; then
e=$(cat "$s".exit)
else
e=0
fi
[ $r = $e ] || exit 1
if [ -f "$s".stdout ]; then
$DIFF -u "$s".stdout "$b".1
fi
if [ -f "$s".stderr ]; then
$DIFF -u "$s".stderr "$b".2
fi

View File

@ -1 +0,0 @@
exit 0

View File

@ -1 +0,0 @@
1

View File

@ -1 +0,0 @@
exit 1

View File

@ -1 +0,0 @@
2

View File

@ -1 +0,0 @@
exit 2

View File

@ -1 +0,0 @@
2

View File

@ -1,2 +0,0 @@
set +e
ls /foo

View File

@ -1 +0,0 @@
2

View File

@ -1,3 +0,0 @@
set +e
ls /foo
exit $?

View File

@ -1 +0,0 @@
exit

View File

@ -1,2 +0,0 @@
echo $0

View File

@ -1 +0,0 @@
echo $#

View File

@ -1 +0,0 @@
4

View File

@ -1 +0,0 @@
echo $@

View File

@ -1 +0,0 @@
-s --long file0 file1

View File

@ -1,4 +0,0 @@
echo foo\
bar baz\
bla
echo

View File

@ -1 +0,0 @@
2

View File

@ -1,3 +0,0 @@
exit \
\
2

View File

@ -1 +0,0 @@
0

View File

@ -1,2 +0,0 @@
exit\
0

View File

@ -1 +0,0 @@
2

View File

@ -1,2 +0,0 @@
true
exit 2

View File

@ -1 +0,0 @@
2

View File

@ -1 +0,0 @@
true; exit 2

View File

@ -1,9 +0,0 @@
echo $@
shift
echo $@
shift
echo $@
shift
echo $@
shift
echo $@

View File

@ -1,5 +0,0 @@
-s --long file0 file1
--long file0 file1
file0 file1
file1

View File

@ -1 +0,0 @@
echo foo:{bar}

View File

@ -1 +0,0 @@
foo:{bar}

View File

@ -1 +0,0 @@
echo "foo" b"ar"

View File

@ -1 +0,0 @@
foo bar

View File

@ -1 +0,0 @@
echo foo "bar" \"baz\"

View File

@ -1 +0,0 @@
foo bar "baz"

View File

@ -1 +0,0 @@
echo 'foo "bar"'

View File

@ -1 +0,0 @@
foo "bar"

View File

@ -1 +0,0 @@
echo foo "bar" '"baz"'

View File

@ -1 +0,0 @@
foo bar "baz"

View File

@ -1 +0,0 @@
echo

View File

@ -1 +0,0 @@
echo a=$a

View File

@ -1 +0,0 @@
a=

View File

@ -1 +0,0 @@
echo $SHELL

View File

@ -1 +0,0 @@
echo command $@ plus

View File

@ -1 +0,0 @@
command -s --long file0 file1 plus

View File

@ -1 +0,0 @@
echo command $@

View File

@ -1 +0,0 @@
command -s --long file0 file1

View File

@ -1,3 +0,0 @@
obj=ar.o
objs="$objs `basename $obj`"
echo "objs:>$objs<"

View File

@ -1 +0,0 @@
objs:> ar.o<

View File

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

View File

@ -1,4 +0,0 @@
aliaspath=alias
localedir=locale
defines="-DALIASPATH=\"${aliaspath}\" -DLOCALEDIR=\"${localedir}\""
echo cc $defines

View File

@ -1 +0,0 @@
cc -DALIASPATH="alias" -DLOCALEDIR="locale"

View File

@ -1,2 +0,0 @@
SHELL=/bin/bash
echo $SHELL

View File

@ -1 +0,0 @@
/bin/bash

View File

@ -1,2 +0,0 @@
a=
echo a:$a

View File

@ -1 +0,0 @@
a:

View File

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

View File

@ -1,3 +0,0 @@
SHELL=gash
bin=${SHELL}/bin
echo $bin

View File

@ -1 +0,0 @@
gash/bin

View File

@ -1,3 +0,0 @@
SHELL=gash
PATH=bin:${SHELL}
echo $PATH

View File

@ -1 +0,0 @@
bin:gash

View File

@ -1 +0,0 @@
SHELL=/bin/bash

View File

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

View File

@ -1 +0,0 @@
-I ar.o

View File

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

View File

@ -1 +0,0 @@
cc -c ./

View File

@ -1,2 +0,0 @@
foo=baz
echo ${foo-bar}

Some files were not shown because too many files have changed in this diff Show More