diff --git a/Makefile.am b/Makefile.am index 431fe9a..c4deefa 100644 --- a/Makefile.am +++ b/Makefile.am @@ -35,6 +35,7 @@ EXTRA_DIST += \ ##################### SOURCES = \ + gash/arithmetic.scm \ gash/built-ins/break.scm \ gash/built-ins/cd.scm \ gash/built-ins/colon.scm \ diff --git a/doc/gash.texi b/doc/gash.texi index 365260b..f8e95e6 100644 --- a/doc/gash.texi +++ b/doc/gash.texi @@ -273,9 +273,6 @@ exhaustive, but covers the most glaring omissions. @itemize @bullet -@item -Arithmetic substitution. - @item Job control. @@ -743,6 +740,7 @@ word ::= string | (word ...) | (' word) | (' sync ...) + | (' word) | (' var) | (' var [word]) | (' var [word]) diff --git a/doc/syntax.txt b/doc/syntax.txt index 289815c..c5dcd7c 100644 --- a/doc/syntax.txt +++ b/doc/syntax.txt @@ -48,6 +48,7 @@ word ::= string | (word ...) | (' word) | (' sync ...) + | (' word) | (' var) | (' var [word]) | (' var [word]) diff --git a/gash/arithmetic.scm b/gash/arithmetic.scm new file mode 100644 index 0000000..2d8ce0c --- /dev/null +++ b/gash/arithmetic.scm @@ -0,0 +1,268 @@ +;;; Gash -- Guile As SHell +;;; Copyright © 2020, 2021 Timothy Sample +;;; +;;; 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 . + +(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))) diff --git a/gash/eval.scm b/gash/eval.scm index 576e6cc..42457d5 100644 --- a/gash/eval.scm +++ b/gash/eval.scm @@ -18,6 +18,7 @@ ;;; along with Gash. If not, see . (define-module (gash eval) + #:use-module (gash arithmetic) #:use-module (gash compat) #:use-module (gash environment) #:use-module (gash pattern) @@ -52,6 +53,11 @@ and arithmetic substitions." `( ,(word->qword quoted-word))) ((' . exps) ((eval-cmd-sub) exps)) + ((' word) + (let* ((arithmetic (expand-word word #:output 'string)) + (expr `(begin (use-modules (gash environment)) + (number->string ,(read-arithmetic arithmetic))))) + (eval expr (interaction-environment)))) ((' name) (parameter-ref name "")) ((' name default) diff --git a/gash/lexer.scm b/gash/lexer.scm index 02bb7ed..9c5ab34 100644 --- a/gash/lexer.scm +++ b/gash/lexer.scm @@ -1,5 +1,5 @@ ;;; Gash -- Guile As SHell -;;; Copyright © 2017, 2018 Timothy Sample +;;; Copyright © 2017, 2018, 2020, 2021 Timothy Sample ;;; ;;; This file is part of Gash. ;;; @@ -325,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) + `( + ,(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 '$')." @@ -352,7 +394,11 @@ they were quoted." (#\$ (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 #:quoted? quoted?)))) diff --git a/tests/spec/Makefile.am b/tests/spec/Makefile.am index 3f070cf..969d1c4 100644 --- a/tests/spec/Makefile.am +++ b/tests/spec/Makefile.am @@ -36,6 +36,7 @@ TEST_EXTENSIONS = .sh SH_LOG_COMPILER = ./check-spec TESTS = \ + oil/spec/arith.test.sh \ oil/spec/case_.test.sh \ oil/spec/command-sub.test.sh \ oil/spec/errexit.test.sh \ diff --git a/tests/spec/oil.scm b/tests/spec/oil.scm index 82c8f40..9c65f70 100644 --- a/tests/spec/oil.scm +++ b/tests/spec/oil.scm @@ -1,5 +1,5 @@ ;;; Gash -- Guile As SHell -;;; Copyright © 2018, 2019 Timothy Sample +;;; Copyright © 2018, 2019, 2021 Timothy Sample ;;; ;;; This file is part of Gash. ;;; @@ -128,7 +128,54 @@ out))) (loop (read-line in 'concat) transformers)))))))) (tests-to-filter - `(("spec/case_.test.sh" + `(("spec/arith.test.sh" + (;; These are Bash specific. + ("Side Effect in Array Indexing") + ("Array indexing in arith") + ;; These go beyond POSIX. + ("Invalid string to int with strict-arith") + ("Preincrement") + ("Postincrement") + ("Increment undefined variables") + ("Increment and decrement array") + ("Increment undefined variables with nounset") + ("Comma operator (borrowed from C)") + ("Constants in base 36") + ("Constants in bases 2 to 64") + ("Dynamic base constants") + ;; Following POSIX, we keep the quotes in the + ;; expession. + ("Constant with quotes like '1'" + ("N-I bash/zsh" "N-I bash/zsh/gash")) + ;; Follow bash/mksh and return status 1. + ("No floating point" + ("OK bash/mksh" "OK bash/mksh/gash")) + ;; We do not support nounset yet. + ("nounset with arithmetic") + ;; We return 1 here. + ("Invalid LValue" + ("## status: 2" ,(string-append + "## status: 2\n" + "## OK gash status: 1\n"))) + ;; Follow Dash on these two. + ("Invalid LValue that looks like array" + ("N-I dash" "N-I dash/gash")) + ("Invalid LValue: two sets of brackets" + ("N-I dash" "N-I dash/gash")) + ;; We do not support exponentiation. + ("Exponentiation with **") + ("Exponentiation operator has buggy precedence") + ;; This test seems to be broken. + ("Logical Ops Short Circuit" + ("\\(\\(" "y=$((")) + ;; Not sure about this one. We only do one + ;; layer of variable lookup. + ("Bizarre recursive name evaluation - result of runtime parse/eval" + ("## stdout: 6 6 6 6" + ,(string-append + "## stdout: 6 6 6 6\n" + "## OK gash stdout: 6 1 1 1\n"))))) + ("spec/case_.test.sh" (;; These two are Bash specific. ("Case statement with ;;&") ("Case statement with ;&"))) diff --git a/tests/unit/eval.scm b/tests/unit/eval.scm index 877d466..9c0ee93 100644 --- a/tests/unit/eval.scm +++ b/tests/unit/eval.scm @@ -19,6 +19,7 @@ (define-module (test-eval) #:use-module (gash environment) #:use-module (gash eval) + #:use-module (ice-9 match) #:use-module (srfi srfi-64) #:use-module (tests unit automake)) @@ -294,7 +295,166 @@ ;;; Arithmetic expansion. -;;; -;;; Not yet implemented. + +(test-equal "Evaluates arithmetic constant (decimal)" + '("42") + (eval-word '( "42"))) + +(test-equal "Evaluates arithmetic constant (octal)" + '("34") + (eval-word '( "042"))) + +(test-equal "Evaluates arithmetic constant (hexadecimal)" + '("66") + (eval-word '( "0x42"))) + +;;; Binary (and tertiary) operators + +(test-equal "Evaluates arithmetic addition" + '("6") + (eval-word '( "2 + 4"))) + +(test-equal "Evaluates arithmetic subtraction" + '("2") + (eval-word '( "4 - 2"))) + +(test-equal "Evaluates arithmetic multiplication" + '("12") + (eval-word '( "3 * 4"))) + +(test-equal "Evaluates arithmetic division" + '("6") + (eval-word '( "19 / 3"))) + +(test-equal "Evaluates arithmetic modulo" + '("2") + (eval-word '( "32 % 3"))) + +(test-equal "Evaluates arithmetic left shift" + '("12") + (eval-word '( "3 << 2"))) + +(test-equal "Evaluates arithmetic right shift" + '("3") + (eval-word '( "15 >> 2"))) + +(test-equal "Evaluates arithmetic greater than" + '("1") + (eval-word '( "5 > 3"))) + +(test-equal "Evaluates arithmetic greater than or equal to" + '("0") + (eval-word '( "3 >= 5"))) + +(test-equal "Evaluates arithmetic less than" + '("0") + (eval-word '( "5 < 3"))) + +(test-equal "Evaluates arithmetic less than or equal to" + '("1") + (eval-word '( "3 <= 5"))) + +(test-equal "Evaluates arithmetic equals" + '("0") + (eval-word '( "0 == 1"))) + +(test-equal "Evaluates arithmetic not equals" + '("1") + (eval-word '( "0 != 1"))) + +(test-equal "Evaluates arithmetic bitwise and" + '("4") + (eval-word '( "12 & 7"))) + +(test-equal "Evaluates arithmetic bitwise inclusive or" + '("9") + (eval-word '( "8 | 1"))) + +(test-equal "Evaluates arithmetic bitwise exclusive or" + '("5") + (eval-word '( "15 ^ 10"))) + +(test-equal "Evaluates arithmetic logical and" + '("0") + (eval-word '( "0 && 1"))) + +(test-equal "Evaluates arithmetic logical or" + '("1") + (eval-word '( "0 || 1"))) + +(test-equal "Evaluates arithmetic conditional" + '("3") + (eval-word '( "0 ? 5 : 3"))) + +;;; Variables + +(test-equal "Evaluates variables in arithmetic" + '("5") + (with-variables '(("x" . "3")) + (lambda () + (eval-word `( "x + 2"))))) + +(test-equal "Evaluates non-numeric variables as zero in arithmetic" + '("0") + (with-variables '(("x" . "hello")) + (lambda () + (eval-word `( "x"))))) + +;;; Assignments + +(for-each (match-lambda + ((op . result) + (test-equal (string-append "Evaluates arithmetic " op) + result + (with-variables '(("x" . "7")) + (lambda () + (eval-word `( + ,(string-append "x " op " 3"))) + (getvar "x")))))) + '(("=" . "3") + ("*=" . "21") + ("/=" . "2") + ("%=" . "1") + ("+=" . "10") + ("-=" . "4") + ("<<=" . "56") + (">>=" . "0") + ("&=" . "3") + ("^=" . "4") + ("|=" . "7"))) + +;;; Unary operators + +(test-equal "Evaluates arithmetic negation" + '("-3") + (with-variables '(("x" . "3")) + (lambda () + (eval-word `( "-x"))))) + +(test-equal "Evaluates arithmetic unary plus" + '("3") + (with-variables '(("x" . "3")) + (lambda () + (eval-word `( "+x"))))) + +(test-equal "Evaluates arithmetic bitwise complement" + '("-6") + (eval-word `( "~5"))) + +(test-equal "Evaluates arithmetic logical complement" + '("0") + (eval-word `( "!1"))) + +(test-equal "Evaluates arithmetic negation on the left" + '("-12") + (with-variables '(("x" . "3")) + (lambda () + (eval-word `( "-x * 4"))))) + +(test-equal "Evaluates arithmetic negation on the right" + '("0") + (with-variables '(("x" . "3")) + (lambda () + (eval-word `( "3 + -x"))))) (test-end "eval")