269 lines
9.2 KiB
Scheme
269 lines
9.2 KiB
Scheme
;;; 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)))
|