Add parser
* geesh/parser.scm: New file. * tests/parser.scm: New file. * Makefile.am: Add them. * .dir-locals.el: New file. Include indenting rules for Shell AST forms and 'call-with-backquoted-input-port'.
This commit is contained in:
Timothy Sample
parent
95181a98b5
commit
69c3f9e6ad
|
|
@ -0,0 +1,10 @@
|
|||
((scheme-mode
|
||||
.
|
||||
((eval . (put '<sh-case> 'scheme-indent-function 1))
|
||||
(eval . (put '<sh-define> 'scheme-indent-function 1))
|
||||
(eval . (put '<sh-exec-let> 'scheme-indent-function 1))
|
||||
(eval . (put '<sh-for> 'scheme-indent-function 1))
|
||||
(eval . (put '<sh-until> 'scheme-indent-function 1))
|
||||
(eval . (put '<sh-while> 'scheme-indent-function 1))
|
||||
(eval . (put '<sh-with-redirects> 'scheme-indent-function 1))
|
||||
(eval . (put 'call-with-backquoted-input-port 'scheme-indent-function 1)))))
|
||||
|
|
@ -38,6 +38,7 @@ test-list: ; @echo $(TESTS)
|
|||
|
||||
MODULES = \
|
||||
geesh/lexer.scm \
|
||||
geesh/parser.scm \
|
||||
geesh/repl.scm
|
||||
|
||||
bin_SCRIPTS = \
|
||||
|
|
@ -45,6 +46,7 @@ bin_SCRIPTS = \
|
|||
|
||||
TESTS = \
|
||||
tests/lexer.scm \
|
||||
tests/parser.scm \
|
||||
tests/repl.scm
|
||||
|
||||
CLEANFILES = \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,660 @@
|
|||
;;; The Geesh Shell Interpreter
|
||||
;;; Copyright 2018 Timothy Sample <samplet@ngyro.com>
|
||||
;;;
|
||||
;;; This file is part of Geesh.
|
||||
;;;
|
||||
;;; Geesh is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation, either version 3 of the License, or
|
||||
;;; (at your option) any later version.
|
||||
;;;
|
||||
;;; Geesh is distributed in the hope that it will be useful,
|
||||
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with Geesh. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (geesh parser)
|
||||
#:use-module (geesh lexer)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 textual-ports)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-41)
|
||||
#:use-module (system base lalr)
|
||||
#:export (read-sh))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This module contains the parser for the Shell language.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define io-redirect-defaults
|
||||
'((< . 0) (<& . 0) (> . 1)
|
||||
(>& . 1) (>> . 1) (<> . 0)
|
||||
(>! . 1) (<< . 0) (<<- . 0)))
|
||||
|
||||
(define (io-redirect? sexp)
|
||||
"Determine if @var{sexp} is an I/O redirect form."
|
||||
(match sexp
|
||||
((or ('< x y) ('<& x y) ('> x y)
|
||||
('>& x y) ('>> x y) ('<> x y)
|
||||
('>! x y) ('<< x y) ('<<- x y)) #t)
|
||||
(_ #f)))
|
||||
|
||||
(define (process-dup-or-close-word word)
|
||||
"Process the right-hand-side of a \"<&\" or \"&>\" redirect."
|
||||
(let ((n (string->number word)))
|
||||
(cond
|
||||
((and n (exact-integer? n)) n)
|
||||
((string=? word "-") '-)
|
||||
(else word))))
|
||||
|
||||
(define (split-assignment word)
|
||||
"Split assignment @var{word} into a list where the first element is
|
||||
the variable name and the second element is the value expression."
|
||||
|
||||
(define (assignment-name-and-value str)
|
||||
(let* ((index (string-index str #\=))
|
||||
(name (substring str 0 index))
|
||||
(value (substring str (1+ index))))
|
||||
`(,name . ,value)))
|
||||
|
||||
(match word
|
||||
(((? string?) . tail)
|
||||
(match (assignment-name-and-value (car word))
|
||||
((name . value)
|
||||
(cond
|
||||
((null? tail) `(,name ,value))
|
||||
((string-null? value) (if (null? (cdr tail))
|
||||
`(,name ,(car tail))
|
||||
`(,name ,tail)))
|
||||
(else `(,name ,(cons value tail)))))))
|
||||
((? string?)
|
||||
(match (assignment-name-and-value word)
|
||||
((name . value) `(,name ,value))))))
|
||||
|
||||
;; The (ice-9 textual-ports) module does not allow instantiating
|
||||
;; end-of-file objects, but (rnrs io ports) does.
|
||||
(define eof-object (@ (rnrs io ports) eof-object))
|
||||
|
||||
(define (make-lexer port read-sh/bracketed read-sh/backquoted)
|
||||
"Make a lexer thunk that reads tokens from @var{port}. When the lexer
|
||||
needs to read subcommands, it uses @var{read-sh/bracketed} to read
|
||||
bracketed subcommands and @var{read-sh/backquoted} to read backquoted
|
||||
subcommands."
|
||||
(lambda ()
|
||||
(parameterize ((read-bracketed-command read-sh/bracketed)
|
||||
(read-backquoted-command read-sh/backquoted))
|
||||
(get-token port))))
|
||||
|
||||
(define* (make-parser #:key (command-hook noop)
|
||||
(open-bracket-hook noop)
|
||||
(close-bracket-hook noop))
|
||||
"Make an LALR parser for the Shell language. The optional hooks are
|
||||
all thunks. The @var{command-hook} thunk is called after reducing a
|
||||
complete command. The @var{open-bracket-hook} thunk is called after
|
||||
reducing an opening bracket. The @var{close-bracket-hook} is called
|
||||
after reducing a closing bracket. (Note that a @var{open-bracket-hook}
|
||||
is also called when reducing case patterns that end with an unbalanced
|
||||
closing bracket. This ensures that when parsing valid Shell code,
|
||||
@var{open-bracket-hook} and @var{close-bracket-hook} should be called
|
||||
the same number of times.)"
|
||||
(lalr-parser
|
||||
|
||||
(AND ; '&'
|
||||
SEMI ; ';'
|
||||
LESS ; '<'
|
||||
GREAT ; '>'
|
||||
PIPE ; '|'
|
||||
LPAREN ; '('
|
||||
RPAREN ; ')'
|
||||
|
||||
AND-IF ; '&&'
|
||||
OR-IF ; '||'
|
||||
DSEMI ; ';;'
|
||||
DLESS ; '<<'
|
||||
DGREAT ; '>>'
|
||||
LESSAND ; '<&'
|
||||
GREATAND ; '>&'
|
||||
LESSGREAT ; '<>'
|
||||
DLESSDASH ; '<<-'
|
||||
CLOBBER ; '>|'
|
||||
|
||||
If ; 'if'
|
||||
Then ; 'then'
|
||||
Else ; 'else'
|
||||
Elif ; 'elif'
|
||||
Fi ; 'fi'
|
||||
Do ; 'do'
|
||||
Done ; 'done'
|
||||
Case ; 'case'
|
||||
Esac ; 'esac'
|
||||
While ; 'while'
|
||||
Until ; 'until'
|
||||
For ; 'for'
|
||||
Lbrace ; '{'
|
||||
Rbrace ; '}'
|
||||
Bang ; '!'
|
||||
In ; 'in'
|
||||
|
||||
WORD
|
||||
ASSIGNMENT-WORD
|
||||
NAME
|
||||
NEWLINE
|
||||
IO-NUMBER)
|
||||
|
||||
(program
|
||||
(linebreak complete-commands linebreak)
|
||||
: (if (null? (cdr $2)) (car $2) (reverse! $2))
|
||||
(linebreak)
|
||||
: (eof-object))
|
||||
|
||||
(complete-commands
|
||||
(complete-commands newline-list complete-command)
|
||||
: (begin
|
||||
(command-hook)
|
||||
(cons (if (null? (cdr $3)) (car $3) $3) $1))
|
||||
(complete-command)
|
||||
: (begin
|
||||
(command-hook)
|
||||
(if (null? (cdr $1)) `(,(car $1)) `(,$1))))
|
||||
|
||||
(complete-command
|
||||
(list separator-op)
|
||||
: (match $2
|
||||
('AND (reverse! (cons `(<sh-async> ,(car $1)) (cdr $1))))
|
||||
('SEMI (reverse! $1)))
|
||||
(list)
|
||||
: (reverse! $1))
|
||||
|
||||
(list
|
||||
(list separator-op and-or)
|
||||
: (match $2
|
||||
('AND (cons* $3 `(<sh-async> ,(car $1)) (cdr $1)))
|
||||
('SEMI (cons $3 $1)))
|
||||
(and-or)
|
||||
: `(,$1))
|
||||
|
||||
(and-or
|
||||
(pipeline)
|
||||
: $1
|
||||
(and-or AND-IF linebreak pipeline)
|
||||
: `(<sh-and> ,$1 ,$4)
|
||||
(and-or OR-IF linebreak pipeline)
|
||||
: `(<sh-or> ,$1 ,$4))
|
||||
|
||||
(pipeline
|
||||
(pipe-sequence)
|
||||
: (if (null? (cdr $1)) (car $1) $1)
|
||||
(Bang pipe-sequence)
|
||||
: `(<sh-bang> ,$2))
|
||||
|
||||
(pipe-sequence
|
||||
(command)
|
||||
: `(,$1)
|
||||
(pipe-sequence PIPE linebreak command)
|
||||
: `(<sh-pipe> ,(append $1 (list $4))))
|
||||
|
||||
(command
|
||||
(simple-command)
|
||||
: $1
|
||||
(compound-command)
|
||||
: $1
|
||||
(compound-command redirect-list)
|
||||
: `(<sh-with-redirects> ,$2 ,$1)
|
||||
(function-definition)
|
||||
: $1)
|
||||
|
||||
(compound-command
|
||||
(brace-group)
|
||||
: $1
|
||||
(subshell)
|
||||
: $1
|
||||
(for-clause)
|
||||
: $1
|
||||
(case-clause)
|
||||
: $1
|
||||
(if-clause)
|
||||
: $1
|
||||
(while-clause)
|
||||
: $1
|
||||
(until-clause)
|
||||
: $1)
|
||||
|
||||
(subshell
|
||||
(LPAREN! compound-list RPAREN!)
|
||||
: `(<sh-subshell> ,$2))
|
||||
|
||||
(compound-list
|
||||
(linebreak term)
|
||||
: (match $2
|
||||
((cmd) cmd)
|
||||
(cmds `(<sh-begin> ,@(reverse! cmds))))
|
||||
(linebreak term separator)
|
||||
: (match (match $3
|
||||
('AND (cons `(<sh-async> ,(car $2)) (cdr $2)))
|
||||
((or 'SEMI 'NEWLINE) $2))
|
||||
((cmd) cmd)
|
||||
(cmds `(<sh-begin> ,@(reverse! cmds)))))
|
||||
|
||||
(term
|
||||
(term separator and-or)
|
||||
: (match $2
|
||||
('AND (cons* $3 `(<sh-async> ,(car $1)) (cdr $1)))
|
||||
((or 'SEMI 'NEWLINE) (cons $3 $1)))
|
||||
(and-or)
|
||||
: `(,$1))
|
||||
|
||||
(for-clause
|
||||
(For name do-group)
|
||||
: `(<sh-for> (,$2 (<sh-ref> "@")) ,$3)
|
||||
(For name sequential-sep do-group)
|
||||
: `(<sh-for> (,$2 (<sh-ref> "@")) ,$4)
|
||||
(For name linebreak in sequential-sep do-group)
|
||||
: `(<sh-for> (,$2 (<sh-ref> "@")) ,$6)
|
||||
(For name linebreak in wordlist sequential-sep do-group)
|
||||
: `(<sh-for> (,$2 ,$5) ,$7))
|
||||
|
||||
(name
|
||||
(NAME-with-keywords)
|
||||
: $1)
|
||||
|
||||
(in
|
||||
(In)
|
||||
: #f)
|
||||
|
||||
(wordlist
|
||||
(wordlist WORD*)
|
||||
: (append $1 `(,$2))
|
||||
(WORD*)
|
||||
: `(,$1))
|
||||
|
||||
(case-clause
|
||||
(Case WORD* linebreak in linebreak case-list Esac)
|
||||
: `(<sh-case> ,$2 ,@$6)
|
||||
(Case WORD* linebreak in linebreak case-list-ns Esac)
|
||||
: `(<sh-case> ,$2 ,@$6)
|
||||
(Case WORD* linebreak in linebreak Esac)
|
||||
: `(<sh-case> ,$2))
|
||||
|
||||
(case-list-ns
|
||||
(case-list case-item-ns)
|
||||
: (append $1 `(,$2))
|
||||
(case-item-ns)
|
||||
: `(,$1))
|
||||
|
||||
(case-list
|
||||
(case-list case-item)
|
||||
: (append $1 `(,$2))
|
||||
(case-item)
|
||||
: `(,$1))
|
||||
|
||||
(case-item-ns
|
||||
(pattern! RPAREN! linebreak)
|
||||
: `(,$1 #f)
|
||||
(pattern! RPAREN! compound-list)
|
||||
: `(,$1 ,$3)
|
||||
(LPAREN! pattern RPAREN! linebreak)
|
||||
: `(,$2 #f)
|
||||
(LPAREN! pattern RPAREN! compound-list)
|
||||
: `(,$2 ,$4))
|
||||
|
||||
(case-item
|
||||
(pattern! RPAREN! linebreak DSEMI linebreak)
|
||||
: `(,$1 #f)
|
||||
(pattern! RPAREN! compound-list DSEMI linebreak)
|
||||
: `(,$1 ,$3)
|
||||
(LPAREN! pattern RPAREN! linebreak DSEMI linebreak)
|
||||
: `(,$2 #f)
|
||||
(LPAREN! pattern RPAREN! compound-list DSEMI linebreak)
|
||||
: `(,$2 ,$4))
|
||||
|
||||
(pattern
|
||||
(WORD*-with-non-Esac-keywords)
|
||||
: `(,$1)
|
||||
(pattern PIPE WORD*)
|
||||
: (append $1 `(,$3)))
|
||||
|
||||
(if-clause
|
||||
(If compound-list Then compound-list else-part Fi)
|
||||
: `(<sh-cond> (,$2 ,$4) ,@$5)
|
||||
(If compound-list Then compound-list Fi)
|
||||
: `(<sh-cond> (,$2 ,$4)))
|
||||
|
||||
(else-part
|
||||
(Elif compound-list Then compound-list)
|
||||
: `((,$2 ,$4))
|
||||
(Elif compound-list Then compound-list else-part)
|
||||
: (cons `(,$2 ,$4) $5)
|
||||
(Else compound-list)
|
||||
: `((<sh-else> ,$2)))
|
||||
|
||||
(while-clause
|
||||
(While compound-list do-group)
|
||||
: `(<sh-while> ,$2 ,$3))
|
||||
|
||||
(until-clause
|
||||
(Until compound-list do-group)
|
||||
: `(<sh-until> ,$2 ,$3))
|
||||
|
||||
(function-definition
|
||||
(fname LPAREN! RPAREN! linebreak function-body)
|
||||
: `(<sh-define> (,$1) ,$5))
|
||||
|
||||
(function-body
|
||||
(compound-command)
|
||||
: $1
|
||||
(compound-command redirect-list)
|
||||
: `(<sh-with-redirects> ,$2 ,$1))
|
||||
|
||||
(fname
|
||||
(NAME)
|
||||
: $1)
|
||||
|
||||
(brace-group
|
||||
(Lbrace compound-list Rbrace)
|
||||
: $2)
|
||||
|
||||
(do-group
|
||||
(Do compound-list Done)
|
||||
: $2)
|
||||
|
||||
(simple-command
|
||||
(cmd-prefix cmd-word cmd-suffix)
|
||||
: (let*-values (((redirects-1 assignments*) (partition io-redirect? $1))
|
||||
((redirects-2 args) (partition io-redirect? $3))
|
||||
((assignments) (map split-assignment assignments*)))
|
||||
(match (append redirects-1 redirects-2)
|
||||
(() `(<sh-exec-let> ,assignments ,$2 ,@args))
|
||||
(redirects `(<sh-with-redirects> ,redirects
|
||||
(<sh-exec-let> ,assignments ,$2 ,@args)))))
|
||||
(cmd-prefix cmd-word)
|
||||
: (let*-values (((redirects assignments*) (partition io-redirect? $1))
|
||||
((assignments) (map split-assignment assignments*)))
|
||||
(match redirects
|
||||
(() `(<sh-exec-let> ,assignments ,$2))
|
||||
(_ `(<sh-with-redirects> ,redirects
|
||||
(<sh-exec-let> ,assignments ,$2)))))
|
||||
(cmd-prefix)
|
||||
: (let*-values (((redirects assignments*) (partition io-redirect? $1))
|
||||
((assignments) (map split-assignment assignments*)))
|
||||
(match redirects
|
||||
(() `(<sh-set!> ,assignments))
|
||||
(_ `(<sh-with-redirects> ,redirects
|
||||
,(if (null? assignments)
|
||||
#f
|
||||
`(<sh-set!> ,assignments))))))
|
||||
(cmd-name cmd-suffix)
|
||||
: (let-values (((redirects args) (partition io-redirect? $2)))
|
||||
(match redirects
|
||||
(() `(<sh-exec> ,$1 ,@args))
|
||||
(_ `(<sh-with-redirects> ,redirects
|
||||
(<sh-exec> ,$1 ,@args)))))
|
||||
(cmd-name)
|
||||
: `(<sh-exec> ,$1))
|
||||
|
||||
(cmd-name
|
||||
(WORD*-without-ASSIGNMENT-WORD)
|
||||
: $1)
|
||||
|
||||
(cmd-word
|
||||
(WORD*-without-ASSIGNMENT-WORD)
|
||||
: $1)
|
||||
|
||||
(cmd-prefix
|
||||
(io-redirect)
|
||||
: `(,$1)
|
||||
(cmd-prefix io-redirect)
|
||||
: (append $1 `(,$2))
|
||||
(ASSIGNMENT-WORD)
|
||||
: `(,$1)
|
||||
(cmd-prefix ASSIGNMENT-WORD)
|
||||
: (append $1 `(,$2)))
|
||||
|
||||
(cmd-suffix
|
||||
(io-redirect)
|
||||
: `(,$1)
|
||||
(cmd-suffix io-redirect)
|
||||
: (append $1 `(,$2))
|
||||
(WORD*)
|
||||
: `(,$1)
|
||||
(cmd-suffix WORD*)
|
||||
: (append $1 `(,$2)))
|
||||
|
||||
(redirect-list
|
||||
(io-redirect)
|
||||
: `(,$1)
|
||||
(redirect-list io-redirect)
|
||||
: (append $1 `(,$2)))
|
||||
|
||||
(io-redirect
|
||||
(io-file)
|
||||
: `(,(car $1) ,(assoc-ref io-redirect-defaults (car $1)) ,(cdr $1))
|
||||
(IO-NUMBER io-file)
|
||||
: `(,(car $2) ,(string->number $1) ,(cdr $2))
|
||||
(io-here)
|
||||
: `(,(car $1) ,(assoc-ref io-redirect-defaults (car $1)) ,(cdr $1))
|
||||
(IO-NUMBER io-here)
|
||||
: `(,(car $2) ,(string->number $1) ,(cdr $2)))
|
||||
|
||||
(io-file
|
||||
(LESS filename)
|
||||
: `(< . ,$2)
|
||||
(LESSAND filename)
|
||||
: `(<& . ,(process-dup-or-close-word $2))
|
||||
(GREAT filename)
|
||||
: `(> . ,$2)
|
||||
(GREATAND filename)
|
||||
: `(>& . ,(process-dup-or-close-word $2))
|
||||
(DGREAT filename)
|
||||
: `(>> . ,$2)
|
||||
(LESSGREAT filename)
|
||||
: `(<> . ,$2)
|
||||
(CLOBBER filename)
|
||||
: `(>! . ,$2))
|
||||
|
||||
(filename
|
||||
(WORD*)
|
||||
: $1)
|
||||
|
||||
(io-here
|
||||
(DLESS here-end)
|
||||
: `(<< . ,$2)
|
||||
(DLESSDASH here-end)
|
||||
: `(<<- . ,$2))
|
||||
|
||||
(here-end
|
||||
(WORD*)
|
||||
: $1)
|
||||
|
||||
(newline-list
|
||||
(NEWLINE)
|
||||
: #f
|
||||
(newline-list NEWLINE)
|
||||
: #f)
|
||||
|
||||
(linebreak
|
||||
(newline-list)
|
||||
: #f
|
||||
()
|
||||
: #f)
|
||||
|
||||
(separator-op
|
||||
(AND)
|
||||
: 'AND
|
||||
(SEMI)
|
||||
: 'SEMI)
|
||||
|
||||
(separator
|
||||
(separator-op linebreak)
|
||||
: $1
|
||||
(newline-list)
|
||||
: 'NEWLINE)
|
||||
|
||||
(sequential-sep
|
||||
(SEMI linebreak)
|
||||
: #f
|
||||
(newline-list)
|
||||
: #f)
|
||||
|
||||
;; Rules added to emulate the POSIX context-sensitive lexer
|
||||
;; approach.
|
||||
|
||||
;; Accept all the specializations of a normal word. This corresponds
|
||||
;; to "rule 1" in the POSIX specification.
|
||||
(WORD*
|
||||
(WORD) : $1
|
||||
(NAME) : $1
|
||||
(ASSIGNMENT-WORD) : $1)
|
||||
|
||||
;; Accept all keywords except "esac". This corresponds to "rule 4"
|
||||
;; in the POSIX specification.
|
||||
(WORD*-with-non-Esac-keywords
|
||||
(WORD) : $1
|
||||
(NAME) : $1
|
||||
(ASSIGNMENT-WORD) : $1
|
||||
(If) : $1
|
||||
(Then) : $1
|
||||
(Else) : $1
|
||||
(Elif) : $1
|
||||
(Fi) : $1
|
||||
(Do) : $1
|
||||
(Done) : $1
|
||||
(Case) : $1
|
||||
;; (Esac) : $1
|
||||
(While) : $1
|
||||
(Until) : $1
|
||||
(For) : $1
|
||||
(Lbrace) : $1
|
||||
(Rbrace) : $1
|
||||
(Bang) : $1
|
||||
(In) : $1)
|
||||
|
||||
;; Accept a "NAME" or any keyword. This corresponds to "rule 5" in
|
||||
;; the POSIX specification.
|
||||
(NAME-with-keywords
|
||||
(NAME) : $1
|
||||
(If) : $1
|
||||
(Then) : $1
|
||||
(Else) : $1
|
||||
(Elif) : $1
|
||||
(Fi) : $1
|
||||
(Do) : $1
|
||||
(Done) : $1
|
||||
(Case) : $1
|
||||
(Esac) : $1
|
||||
(While) : $1
|
||||
(Until) : $1
|
||||
(For) : $1
|
||||
(Lbrace) : $1
|
||||
(Rbrace) : $1
|
||||
(Bang) : $1
|
||||
(In) : $1)
|
||||
|
||||
;; Accept any "WORD*" token except for "ASSIGNMENT-WORD". This
|
||||
;; corresponds to "rule 7" in the POSIX specification.
|
||||
(WORD*-without-ASSIGNMENT-WORD
|
||||
(WORD) : $1
|
||||
(NAME) : $1)
|
||||
|
||||
;; Rules for updating bracket balance.
|
||||
|
||||
(LPAREN!
|
||||
(LPAREN)
|
||||
: (begin (open-bracket-hook) $1))
|
||||
|
||||
(RPAREN!
|
||||
(RPAREN)
|
||||
: (begin (close-bracket-hook) $1))
|
||||
|
||||
;; Sometimes a "pattern" non-terminal comes before an unbalanced
|
||||
;; "RPAREN". This reduction hook can be used to pretend that we
|
||||
;; encountered an "LPAREN".
|
||||
|
||||
(pattern!
|
||||
(pattern)
|
||||
: (begin (open-bracket-hook) $1))))
|
||||
|
||||
(define* (syntax-error message #:optional token)
|
||||
"Handle a parser error"
|
||||
(if (lexical-token? token)
|
||||
(throw 'syntax-error #f message
|
||||
(and=> (lexical-token-source token)
|
||||
source-location->source-properties)
|
||||
(or (lexical-token-value token)
|
||||
(lexical-token-category token))
|
||||
#f)
|
||||
(throw 'syntax-error #f message #f token #f)))
|
||||
|
||||
(define (call-with-backquoted-input-port port proc)
|
||||
"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)."
|
||||
(define wrapped-port
|
||||
(make-soft-port
|
||||
(vector
|
||||
;; put-char, put-string, and flush-output-port
|
||||
#f #f #f
|
||||
;; get-char
|
||||
(lambda ()
|
||||
(match (lookahead-char port)
|
||||
(#\` (eof-object))
|
||||
(#\\ (begin
|
||||
(get-char port)
|
||||
(match (lookahead-char port)
|
||||
((or #\$ #\` #\\) (get-char port))
|
||||
(_ #\\))))
|
||||
(_ (get-char port))))
|
||||
;; close-port
|
||||
#f)
|
||||
"r"))
|
||||
(proc wrapped-port))
|
||||
|
||||
(define (read-sh/bracketed port)
|
||||
"Read Shell code from @var{port} until the first unmatched closing
|
||||
bracket."
|
||||
(let* ((bracket-depth 0)
|
||||
(incr-bracket-depth! (lambda ()
|
||||
(set! bracket-depth (1+ bracket-depth))))
|
||||
(decr-bracket-depth! (lambda ()
|
||||
(set! bracket-depth (1- bracket-depth))))
|
||||
(balanced? (lambda () (= 0 bracket-depth)))
|
||||
(pre-lex (make-lexer port read-sh/bracketed read-sh/backquoted))
|
||||
(lex (lambda ()
|
||||
(let ((token (pre-lex)))
|
||||
(if (and (balanced?)
|
||||
(lexical-token? token)
|
||||
(eq? (lexical-token-category token) 'RPAREN))
|
||||
(begin
|
||||
(unget-char port #\))
|
||||
'*eoi*)
|
||||
token))))
|
||||
(parse (make-parser #:open-bracket-hook incr-bracket-depth!
|
||||
#:close-bracket-hook decr-bracket-depth!)))
|
||||
(match (parse lex syntax-error)
|
||||
((? eof-object?) #f)
|
||||
(code code))))
|
||||
|
||||
(define (read-sh/backquoted port)
|
||||
"Read Shell code from @var{port} until the first unescaped backquote."
|
||||
(call-with-backquoted-input-port port
|
||||
(lambda (port)
|
||||
(let ((lex (make-lexer port read-sh/bracketed read-sh/backquoted))
|
||||
(parse (make-parser)))
|
||||
(match (parse lex syntax-error)
|
||||
((? eof-object?) #f)
|
||||
(code code))))))
|
||||
|
||||
(define (read-sh port)
|
||||
"Read a complete Shell command from @var{port} (or the current input
|
||||
port if @var{port} is unspecified)."
|
||||
(let* ((stop? #f)
|
||||
(stop! (lambda () (set! stop? #t)))
|
||||
(pre-lex (make-lexer port read-sh/bracketed read-sh/backquoted))
|
||||
(lex (lambda () (if stop? '*eoi* (pre-lex))))
|
||||
(parse (make-parser #:command-hook stop!)))
|
||||
(parse lex syntax-error)))
|
||||
|
|
@ -0,0 +1,276 @@
|
|||
(define-module (test-parser)
|
||||
#:use-module (geesh parser)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (tests automake))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Tests for the parser module.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define (parse str)
|
||||
(call-with-input-string str read-sh))
|
||||
|
||||
(test-begin "reader")
|
||||
|
||||
;; Commands and lists
|
||||
|
||||
(test-equal "Parses simple command"
|
||||
'(<sh-exec> "echo" "foo")
|
||||
(parse "echo foo"))
|
||||
|
||||
(test-equal "Parses command lists"
|
||||
'((<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(parse "echo foo; echo bar"))
|
||||
|
||||
(test-equal "Parses asynchronous command lists"
|
||||
'((<sh-async> (<sh-exec> "echo" "foo"))
|
||||
(<sh-async> (<sh-exec> "echo" "bar")))
|
||||
(parse "echo foo& echo bar&"))
|
||||
|
||||
(test-equal "Parses mixed command lists"
|
||||
'((<sh-async> (<sh-exec> "echo" "foo"))
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(parse "echo foo& echo bar"))
|
||||
|
||||
(test-equal "Parses commands with assignments"
|
||||
'(<sh-exec-let> (("FOO" "bar"))
|
||||
"echo" (<sh-ref> "FOO"))
|
||||
(parse "FOO=bar echo $FOO"))
|
||||
|
||||
(test-equal "Parses commands with default redirects"
|
||||
'(<sh-with-redirects> ((> 1 "bar"))
|
||||
(<sh-exec> "echo" "foo"))
|
||||
(parse "echo foo > bar"))
|
||||
|
||||
(test-equal "Parses commands with specific redirects"
|
||||
'(<sh-with-redirects> ((< 5 "bar"))
|
||||
(<sh-exec> "echo" "foo"))
|
||||
(parse "echo foo 5< bar"))
|
||||
|
||||
(test-equal "Parses commands with dup redirects"
|
||||
'(<sh-with-redirects> ((>& 1 3))
|
||||
(<sh-exec> "exec"))
|
||||
(parse "exec >&3"))
|
||||
|
||||
(test-equal "Parses commands with close redirects"
|
||||
'(<sh-with-redirects> ((<& 3 -))
|
||||
(<sh-exec> "exec"))
|
||||
(parse "exec 3<&-"))
|
||||
|
||||
(test-equal "Parses assignments"
|
||||
'(<sh-set!> (("FOO" "bar")))
|
||||
(parse "FOO=bar"))
|
||||
|
||||
;; Boolean expressions
|
||||
|
||||
(test-equal "Parses disjunctions"
|
||||
'(<sh-or> (<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(parse "echo foo || echo bar"))
|
||||
|
||||
(test-equal "Parses conjunctions"
|
||||
'(<sh-and> (<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(parse "echo foo && echo bar"))
|
||||
|
||||
(test-equal "Parses conjunction than disjunction"
|
||||
'(<sh-or> (<sh-and> (<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(<sh-exec> "echo" "baz"))
|
||||
(parse "echo foo && echo bar || echo baz"))
|
||||
|
||||
(test-equal "Parses disjunction than conjunction"
|
||||
'(<sh-and> (<sh-or> (<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(<sh-exec> "echo" "baz"))
|
||||
(parse "echo foo || echo bar && echo baz"))
|
||||
|
||||
;; Pipelines
|
||||
|
||||
(test-equal "Parses pipelines"
|
||||
'(<sh-pipe> ((<sh-exec> "cat" "foo.txt")
|
||||
(<sh-exec> "grep" "bar")))
|
||||
(parse "cat foo.txt | grep bar"))
|
||||
|
||||
;; Brace groups and subshells
|
||||
|
||||
(test-equal "Parses brace groups"
|
||||
'(<sh-begin> (<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(parse "{ echo foo
|
||||
echo bar }"))
|
||||
|
||||
(test-equal "Parses subshells"
|
||||
'(<sh-subshell> (<sh-begin> (<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar")))
|
||||
(parse "(echo foo; echo bar)"))
|
||||
|
||||
;; For loops
|
||||
|
||||
(test-equal "Parses for loops over parameters without seperator"
|
||||
'(<sh-for> ("x" (<sh-ref> "@"))
|
||||
(<sh-exec> "echo" (<sh-ref> "x")))
|
||||
(parse "for x do echo $x done"))
|
||||
|
||||
(test-equal "Parses for loops over parameters with seperator"
|
||||
'(<sh-for> ("x" (<sh-ref> "@"))
|
||||
(<sh-exec> "echo" (<sh-ref> "x")))
|
||||
(parse "for x; do echo $x done"))
|
||||
|
||||
(test-equal "Parses for loops over parameters with \"in\""
|
||||
'(<sh-for> ("x" (<sh-ref> "@"))
|
||||
(<sh-exec> "echo" (<sh-ref> "x")))
|
||||
(parse "for x in; do echo $x done"))
|
||||
|
||||
(test-equal "Parses for loops over word lists"
|
||||
'(<sh-for> ("x" ("foo" "bar" "baz"))
|
||||
(<sh-exec> "echo" (<sh-ref> "x")))
|
||||
(parse "for x in foo bar baz; do echo $x done"))
|
||||
|
||||
;; Case statements
|
||||
|
||||
(test-equal "Parses case statements with final seperator"
|
||||
'(<sh-case> (<sh-ref> "foo")
|
||||
(("bar") (<sh-exec> "echo" "bar")))
|
||||
(parse "case $foo in bar) echo bar ;; esac"))
|
||||
|
||||
(test-equal "Parses case statements without final seperator"
|
||||
'(<sh-case> (<sh-ref> "foo")
|
||||
(("bar") (<sh-exec> "echo" "bar")))
|
||||
(parse "case $foo in bar) echo bar esac"))
|
||||
|
||||
(test-equal "Parses empty case statements"
|
||||
'(<sh-case> (<sh-ref> "foo"))
|
||||
(parse "case $foo in esac"))
|
||||
|
||||
(test-equal "Parses case statements with empty case item"
|
||||
'(<sh-case> (<sh-ref> "foo")
|
||||
(("bar") #f))
|
||||
(parse "case $foo in bar) esac"))
|
||||
|
||||
(test-equal "Parses case statements with multiple case items"
|
||||
'(<sh-case> (<sh-ref> "foo")
|
||||
(("bar") (<sh-exec> "echo" "bar"))
|
||||
(("baz") (<sh-exec> "echo" "baz")))
|
||||
(parse "case $foo in bar) echo bar ;; baz) echo baz esac"))
|
||||
|
||||
(test-equal "Parses case statements with compound patterns"
|
||||
'(<sh-case> (<sh-ref> "foo")
|
||||
(("bar" "baz") (<sh-exec> "echo" (<sh-quote> "bar or baz"))))
|
||||
(parse "case $foo in bar | baz) echo 'bar or baz' ;; esac"))
|
||||
|
||||
;; If statements
|
||||
|
||||
(test-equal "Parses one-branch if statements"
|
||||
'(<sh-cond>
|
||||
((<sh-exec> "[" (<sh-ref> "foo") "=" "bar" "]")
|
||||
(<sh-exec> "echo" "bar")))
|
||||
(parse "if [ $foo = bar ] then echo bar fi"))
|
||||
|
||||
(test-equal "Parses two-branch if statements"
|
||||
'(<sh-cond>
|
||||
((<sh-exec> "[" (<sh-ref> "foo") "=" "bar" "]")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(<sh-else>
|
||||
(<sh-exec> "echo" "baz")))
|
||||
(parse "if [ $foo = bar ] then echo bar else echo baz fi"))
|
||||
|
||||
(test-equal "Parses multi-branch if statements"
|
||||
'(<sh-cond>
|
||||
((<sh-exec> "[" (<sh-ref> "foo") "=" "bar" "]")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
((<sh-exec> "[" (<sh-ref> "foo") "=" "baz" "]")
|
||||
(<sh-exec> "echo" "baz"))
|
||||
(<sh-else>
|
||||
(<sh-exec> "echo" "quux")))
|
||||
(parse "if [ $foo = bar ] then
|
||||
echo bar
|
||||
elif [ $foo = baz ] then
|
||||
echo baz
|
||||
else
|
||||
echo quux
|
||||
fi"))
|
||||
|
||||
;; While and until loops
|
||||
|
||||
(test-equal "Parses while loops"
|
||||
'(<sh-while> (<sh-exec> "is-foo-time")
|
||||
(<sh-exec> "foo"))
|
||||
(parse "while is-foo-time do foo done"))
|
||||
|
||||
(test-equal "Parses until loops"
|
||||
'(<sh-until> (<sh-exec> "is-no-longer-foo-time")
|
||||
(<sh-exec> "foo"))
|
||||
(parse "until is-no-longer-foo-time do foo done"))
|
||||
|
||||
;; Functions
|
||||
|
||||
(test-equal "Parses functions"
|
||||
'(<sh-define> ("foo")
|
||||
(<sh-exec> "echo" "foo"))
|
||||
(parse "foo() { echo foo }"))
|
||||
|
||||
;; Nested commands
|
||||
|
||||
(test-equal "Parses bracketed command substitions"
|
||||
'(<sh-exec> "echo"
|
||||
(<sh-cmd-sub> (<sh-exec> "foo"))
|
||||
(<sh-cmd-sub> (<sh-exec> "bar")))
|
||||
(parse "echo $(foo) $(bar)"))
|
||||
|
||||
(test-equal "Parses nested bracketed command substitions"
|
||||
'(<sh-exec> "echo"
|
||||
(<sh-cmd-sub> (<sh-exec> "foo"
|
||||
(<sh-cmd-sub> (<sh-exec> "bar")))))
|
||||
(parse "echo $(foo $(bar))"))
|
||||
|
||||
(test-equal "Parses empty bracketed command substitions"
|
||||
'(<sh-exec> "echo" (<sh-cmd-sub> #f))
|
||||
(parse "echo $()"))
|
||||
|
||||
(test-equal "Parses multiline bracketed command substitions"
|
||||
'(<sh-exec> "echo" (<sh-cmd-sub> ((<sh-exec> "foo")
|
||||
(<sh-exec> "bar"))))
|
||||
(parse "echo $(foo
|
||||
bar)"))
|
||||
|
||||
(test-equal "Parses backquoted command substitions"
|
||||
'(<sh-exec> "echo"
|
||||
(<sh-cmd-sub> (<sh-exec> "foo"))
|
||||
(<sh-cmd-sub> (<sh-exec> "bar")))
|
||||
(parse "echo `foo` `bar`"))
|
||||
|
||||
(test-equal "Parses nested backquoted command substitions"
|
||||
'(<sh-exec> "echo"
|
||||
(<sh-cmd-sub> (<sh-exec> "foo"
|
||||
(<sh-cmd-sub> (<sh-exec> "bar")))))
|
||||
(parse "echo `foo \\`bar\\``"))
|
||||
|
||||
(test-equal "Parses empty backquoted command substitions"
|
||||
'(<sh-exec> "echo" (<sh-cmd-sub> #f))
|
||||
(parse "echo ``"))
|
||||
|
||||
(test-equal "Parses multiline backquoted command substitions"
|
||||
'(<sh-exec> "echo" (<sh-cmd-sub> ((<sh-exec> "foo")
|
||||
(<sh-exec> "bar"))))
|
||||
(parse "echo `foo
|
||||
bar`"))
|
||||
|
||||
;; Other tests
|
||||
|
||||
(test-assert "Returns EOF on EOF"
|
||||
(eof-object? (parse "")))
|
||||
|
||||
(test-equal "Parses one statement at a time"
|
||||
'((<sh-exec> "echo" "foo")
|
||||
(<sh-exec> "echo" "bar"))
|
||||
(call-with-input-string "echo foo
|
||||
echo bar"
|
||||
(lambda (port)
|
||||
(list (read-sh port)
|
||||
(read-sh port)))))
|
||||
|
||||
(test-end)
|
||||
Loading…
Reference in New Issue