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.
This commit is contained in:
Timothy Sample 2020-03-27 22:33:51 -04:00
parent d3244e0ec0
commit 87229e4b3a
9 changed files with 537 additions and 9 deletions

View File

@ -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 \

View File

@ -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 ...)
| ('<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

@ -18,6 +18,7 @@
;;; 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)
@ -52,6 +53,11 @@ and arithmetic substitions."
`(<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)

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.
;;;
@ -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)
`(<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 '$')."
@ -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?))))

View File

@ -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 \

View File

@ -1,5 +1,5 @@
;;; Gash -- Guile As SHell
;;; Copyright © 2018, 2019 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2018, 2019, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; 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 ;&")))

View File

@ -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 '(<sh-arithmetic> "42")))
(test-equal "Evaluates arithmetic constant (octal)"
'("34")
(eval-word '(<sh-arithmetic> "042")))
(test-equal "Evaluates arithmetic constant (hexadecimal)"
'("66")
(eval-word '(<sh-arithmetic> "0x42")))
;;; Binary (and tertiary) operators
(test-equal "Evaluates arithmetic addition"
'("6")
(eval-word '(<sh-arithmetic> "2 + 4")))
(test-equal "Evaluates arithmetic subtraction"
'("2")
(eval-word '(<sh-arithmetic> "4 - 2")))
(test-equal "Evaluates arithmetic multiplication"
'("12")
(eval-word '(<sh-arithmetic> "3 * 4")))
(test-equal "Evaluates arithmetic division"
'("6")
(eval-word '(<sh-arithmetic> "19 / 3")))
(test-equal "Evaluates arithmetic modulo"
'("2")
(eval-word '(<sh-arithmetic> "32 % 3")))
(test-equal "Evaluates arithmetic left shift"
'("12")
(eval-word '(<sh-arithmetic> "3 << 2")))
(test-equal "Evaluates arithmetic right shift"
'("3")
(eval-word '(<sh-arithmetic> "15 >> 2")))
(test-equal "Evaluates arithmetic greater than"
'("1")
(eval-word '(<sh-arithmetic> "5 > 3")))
(test-equal "Evaluates arithmetic greater than or equal to"
'("0")
(eval-word '(<sh-arithmetic> "3 >= 5")))
(test-equal "Evaluates arithmetic less than"
'("0")
(eval-word '(<sh-arithmetic> "5 < 3")))
(test-equal "Evaluates arithmetic less than or equal to"
'("1")
(eval-word '(<sh-arithmetic> "3 <= 5")))
(test-equal "Evaluates arithmetic equals"
'("0")
(eval-word '(<sh-arithmetic> "0 == 1")))
(test-equal "Evaluates arithmetic not equals"
'("1")
(eval-word '(<sh-arithmetic> "0 != 1")))
(test-equal "Evaluates arithmetic bitwise and"
'("4")
(eval-word '(<sh-arithmetic> "12 & 7")))
(test-equal "Evaluates arithmetic bitwise inclusive or"
'("9")
(eval-word '(<sh-arithmetic> "8 | 1")))
(test-equal "Evaluates arithmetic bitwise exclusive or"
'("5")
(eval-word '(<sh-arithmetic> "15 ^ 10")))
(test-equal "Evaluates arithmetic logical and"
'("0")
(eval-word '(<sh-arithmetic> "0 && 1")))
(test-equal "Evaluates arithmetic logical or"
'("1")
(eval-word '(<sh-arithmetic> "0 || 1")))
(test-equal "Evaluates arithmetic conditional"
'("3")
(eval-word '(<sh-arithmetic> "0 ? 5 : 3")))
;;; Variables
(test-equal "Evaluates variables in arithmetic"
'("5")
(with-variables '(("x" . "3"))
(lambda ()
(eval-word `(<sh-arithmetic> "x + 2")))))
(test-equal "Evaluates non-numeric variables as zero in arithmetic"
'("0")
(with-variables '(("x" . "hello"))
(lambda ()
(eval-word `(<sh-arithmetic> "x")))))
;;; Assignments
(for-each (match-lambda
((op . result)
(test-equal (string-append "Evaluates arithmetic " op)
result
(with-variables '(("x" . "7"))
(lambda ()
(eval-word `(<sh-arithmetic>
,(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 `(<sh-arithmetic> "-x")))))
(test-equal "Evaluates arithmetic unary plus"
'("3")
(with-variables '(("x" . "3"))
(lambda ()
(eval-word `(<sh-arithmetic> "+x")))))
(test-equal "Evaluates arithmetic bitwise complement"
'("-6")
(eval-word `(<sh-arithmetic> "~5")))
(test-equal "Evaluates arithmetic logical complement"
'("0")
(eval-word `(<sh-arithmetic> "!1")))
(test-equal "Evaluates arithmetic negation on the left"
'("-12")
(with-variables '(("x" . "3"))
(lambda ()
(eval-word `(<sh-arithmetic> "-x * 4")))))
(test-equal "Evaluates arithmetic negation on the right"
'("0")
(with-variables '(("x" . "3"))
(lambda ()
(eval-word `(<sh-arithmetic> "3 + -x")))))
(test-end "eval")