wip! Port the front end to Mes.
* gash/lexer.scm (operator-prefix-char?): Avoid using 'match-lambda': it seems to confuse Mes. * gash/parser.scm: Replace '(eof-object)' with 'the-eof-object'; replace 'let-values' and 'let-values*' with 'receive'. * mes/gash.mes: New file.
This commit is contained in:
parent
eae0953f31
commit
d18e721a78
|
@ -102,8 +102,7 @@
|
||||||
|
|
||||||
(define operator-prefix-char?
|
(define operator-prefix-char?
|
||||||
(let ((prefix-chars (delete-duplicates
|
(let ((prefix-chars (delete-duplicates
|
||||||
(map (match-lambda
|
(map (lambda (pair) (string-ref (car pair) 0))
|
||||||
((str . _) (string-ref str 0)))
|
|
||||||
*operators*))))
|
*operators*))))
|
||||||
(cut memv <> prefix-chars)))
|
(cut memv <> prefix-chars)))
|
||||||
|
|
||||||
|
|
|
@ -20,6 +20,7 @@
|
||||||
#:use-module (gash compat textual-ports)
|
#:use-module (gash compat textual-ports)
|
||||||
#:use-module (gash lexer)
|
#:use-module (gash lexer)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (ice-9 receive)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-41)
|
#:use-module (srfi srfi-41)
|
||||||
|
@ -70,10 +71,6 @@ the variable name and the second element is the value expression."
|
||||||
(match (assignment-name-and-value word)
|
(match (assignment-name-and-value word)
|
||||||
((name . value) `(,name ,value))))))
|
((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 (map+fold proc init xs)
|
(define (map+fold proc init xs)
|
||||||
"Apply @var{proc} to each element of @var{xs}, mapping and folding
|
"Apply @var{proc} to each element of @var{xs}, mapping and folding
|
||||||
at the same time. The procedure @var{proc} must return two values:
|
at the same time. The procedure @var{proc} must return two values:
|
||||||
|
@ -81,7 +78,7 @@ the first is the result for mapping, and the second is the result for
|
||||||
folding."
|
folding."
|
||||||
(let loop ((xs xs) (map-acc '()) (fold-acc init))
|
(let loop ((xs xs) (map-acc '()) (fold-acc init))
|
||||||
(match xs
|
(match xs
|
||||||
((x . rest) (let-values (((map-value fold-value) (proc x fold-acc)))
|
((x . rest) (receive (map-value fold-value) (proc x fold-acc)
|
||||||
(loop rest (cons map-value map-acc) fold-value)))
|
(loop rest (cons map-value map-acc) fold-value)))
|
||||||
(() (values (reverse! map-acc) fold-acc)))))
|
(() (values (reverse! map-acc) fold-acc)))))
|
||||||
|
|
||||||
|
@ -237,7 +234,7 @@ the same number of times.)"
|
||||||
(linebreak complete-commands linebreak)
|
(linebreak complete-commands linebreak)
|
||||||
: (if (null? (cdr $2)) (car $2) (reverse! $2))
|
: (if (null? (cdr $2)) (car $2) (reverse! $2))
|
||||||
(linebreak)
|
(linebreak)
|
||||||
: (eof-object))
|
: the-eof-object)
|
||||||
|
|
||||||
(complete-commands
|
(complete-commands
|
||||||
(complete-commands newline-list complete-command)
|
(complete-commands newline-list complete-command)
|
||||||
|
@ -469,16 +466,16 @@ the same number of times.)"
|
||||||
`(<sh-exec> ,$2)
|
`(<sh-exec> ,$2)
|
||||||
`(<sh-exec-let> ,assignments ,$2))))))
|
`(<sh-exec-let> ,assignments ,$2))))))
|
||||||
(cmd-prefix)
|
(cmd-prefix)
|
||||||
: (let*-values (((redirects assignments*) (partition io-redirect? $1))
|
: (receive (redirects assignments*) (partition io-redirect? $1)
|
||||||
((assignments) (map split-assignment assignments*)))
|
(let ((assignments (map split-assignment assignments*)))
|
||||||
(match redirects
|
(match redirects
|
||||||
(() `(<sh-set!> ,@assignments))
|
(() `(<sh-set!> ,@assignments))
|
||||||
(_ `(<sh-with-redirects> ,redirects
|
(_ `(<sh-with-redirects> ,redirects
|
||||||
,(if (null? assignments)
|
,(if (null? assignments)
|
||||||
#f
|
#f
|
||||||
`(<sh-set!> ,@assignments))))))
|
`(<sh-set!> ,@assignments)))))))
|
||||||
(cmd-name cmd-suffix)
|
(cmd-name cmd-suffix)
|
||||||
: (let-values (((redirects args) (partition io-redirect? $2)))
|
: (receive (redirects args) (partition io-redirect? $2)
|
||||||
(match redirects
|
(match redirects
|
||||||
(() `(<sh-exec> ,$1 ,@args))
|
(() `(<sh-exec> ,$1 ,@args))
|
||||||
(_ `(<sh-with-redirects> ,redirects
|
(_ `(<sh-with-redirects> ,redirects
|
||||||
|
@ -725,8 +722,7 @@ ignored."
|
||||||
(set! here-docs (append-reverse docs here-docs)))
|
(set! here-docs (append-reverse docs here-docs)))
|
||||||
|
|
||||||
(define (insert-here-docs exp)
|
(define (insert-here-docs exp)
|
||||||
(let-values (((exp here-docs*)
|
(receive (exp here-docs*) (merge-here-docs exp (reverse here-docs))
|
||||||
(merge-here-docs exp (reverse here-docs))))
|
|
||||||
(unless (null? here-docs*)
|
(unless (null? here-docs*)
|
||||||
(error "Unused here-documents"))
|
(error "Unused here-documents"))
|
||||||
(set! here-docs '())
|
(set! here-docs '())
|
||||||
|
@ -774,7 +770,7 @@ treat the double quote character as escapable."
|
||||||
;; get-char
|
;; get-char
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(match (lookahead-char port)
|
(match (lookahead-char port)
|
||||||
(#\` (eof-object))
|
(#\` the-eof-object)
|
||||||
(#\\ (begin
|
(#\\ (begin
|
||||||
(get-char port)
|
(get-char port)
|
||||||
(match (lookahead-char port)
|
(match (lookahead-char port)
|
||||||
|
|
|
@ -0,0 +1,141 @@
|
||||||
|
(mes-use-module (mes fluids))
|
||||||
|
(mes-use-module (mes lalr))
|
||||||
|
(mes-use-module (mes match))
|
||||||
|
(mes-use-module (mes scm))
|
||||||
|
(mes-use-module (srfi srfi-1))
|
||||||
|
(mes-use-module (srfi srfi-8))
|
||||||
|
(mes-use-module (srfi srfi-9))
|
||||||
|
(mes-use-module (srfi srfi-14))
|
||||||
|
(mes-use-module (srfi srfi-26))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;; Stuff for the lexer.
|
||||||
|
|
||||||
|
|
||||||
|
;; SRFI 14 extras
|
||||||
|
|
||||||
|
(define (char-set-union . css)
|
||||||
|
(apply lset-union equal? css))
|
||||||
|
|
||||||
|
(define (char-set-intersection . css)
|
||||||
|
(apply lset-intersection equal? css))
|
||||||
|
|
||||||
|
(define char-set:ascii
|
||||||
|
(list->char-set (map integer->char (iota 128))))
|
||||||
|
|
||||||
|
(define char-set:letter
|
||||||
|
(char-set-union char-set:upper-case char-set:lower-case))
|
||||||
|
|
||||||
|
(define char-set:letter+digit
|
||||||
|
(char-set-union char-set:letter char-set:digit))
|
||||||
|
|
||||||
|
(define char-set:blank
|
||||||
|
(char-set #\tab #\space))
|
||||||
|
|
||||||
|
|
||||||
|
;; Parameters
|
||||||
|
|
||||||
|
;; This is cute, but maybe a record would be better.
|
||||||
|
(define *fluid-accessor* (list 'fluid-accessor))
|
||||||
|
|
||||||
|
(define (make-parameter init)
|
||||||
|
(define fluid (make-fluid init))
|
||||||
|
(lambda args
|
||||||
|
(if (null? args)
|
||||||
|
(fluid-ref fluid)
|
||||||
|
(let ((new-value (car args)))
|
||||||
|
(if (eq? new-value *fluid-accessor*)
|
||||||
|
fluid
|
||||||
|
(let ((old-value (fluid-ref fluid)))
|
||||||
|
(fluid-set! new-value)
|
||||||
|
old-value))))))
|
||||||
|
|
||||||
|
(define-syntax-rule (parameterize ((param value) ...) body ...)
|
||||||
|
(with-fluids (((param *fluid-accessor*) value) ...) body ...))
|
||||||
|
|
||||||
|
|
||||||
|
;; Input shims
|
||||||
|
|
||||||
|
(define-record-type <soft-input-port>
|
||||||
|
(make-soft-input-port thunk buffer)
|
||||||
|
soft-input-port?
|
||||||
|
(thunk soft-input-port-thunk)
|
||||||
|
(buffer soft-input-port-buffer set-soft-input-port-buffer!))
|
||||||
|
|
||||||
|
(define (make-soft-port pv modes)
|
||||||
|
(unless (equal? modes "r")
|
||||||
|
(error "Soft ports must have mode \"r\""))
|
||||||
|
(make-soft-input-port (vector-ref pv 3) '()))
|
||||||
|
|
||||||
|
(define (push-soft-input-port-buffer! sip char)
|
||||||
|
(let ((buffer (soft-input-port-buffer sip)))
|
||||||
|
(set-soft-input-port-buffer! sip (cons char buffer))))
|
||||||
|
|
||||||
|
(define (pop-soft-input-port-buffer! sip)
|
||||||
|
(let* ((buffer (soft-input-port-buffer sip))
|
||||||
|
(result (car buffer)))
|
||||||
|
(set-soft-input-port-buffer! sip (cdr buffer))
|
||||||
|
result))
|
||||||
|
|
||||||
|
(define-syntax-rule (with-input-port port body ...)
|
||||||
|
(let ((old-port (current-input-port)))
|
||||||
|
(set-current-input-port port)
|
||||||
|
(let ((result (begin body ...)))
|
||||||
|
(set-current-input-port old-port)
|
||||||
|
result)))
|
||||||
|
|
||||||
|
(define (get-char port)
|
||||||
|
(if (soft-input-port? port)
|
||||||
|
(let ((thunk (soft-input-port-thunk port))
|
||||||
|
(buffer (soft-input-port-buffer port)))
|
||||||
|
(if (null? buffer)
|
||||||
|
(thunk)
|
||||||
|
(pop-soft-input-port-buffer! port)))
|
||||||
|
(with-input-port port (read-char))))
|
||||||
|
|
||||||
|
(define (unget-char port char)
|
||||||
|
(if (soft-input-port? port)
|
||||||
|
(push-soft-input-port-buffer! port char)
|
||||||
|
(with-input-port port (unread-char char))))
|
||||||
|
|
||||||
|
(define (lookahead-char port)
|
||||||
|
(let ((result (get-char port)))
|
||||||
|
(unget-char port result)
|
||||||
|
result))
|
||||||
|
|
||||||
|
(define (set-port-line! port line)
|
||||||
|
#f)
|
||||||
|
|
||||||
|
|
||||||
|
;; String funtions
|
||||||
|
|
||||||
|
(define (string-every pred str)
|
||||||
|
(every pred (string->list str)))
|
||||||
|
|
||||||
|
|
||||||
|
;; Misc. fixes
|
||||||
|
|
||||||
|
(define-syntax-rule (define-inlinable stuff ...)
|
||||||
|
(define stuff ...))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;; Stuff for the parser
|
||||||
|
|
||||||
|
(define the-eof-object (integer->char -1))
|
||||||
|
|
||||||
|
(define (noop . args) #f)
|
||||||
|
|
||||||
|
|
||||||
|
;; Main show
|
||||||
|
|
||||||
|
(include-from-path "gash/lexer.scm")
|
||||||
|
(include-from-path "gash/parser.scm")
|
||||||
|
|
||||||
|
;; XXX: Mes module loading seems to bork reading from stdin.
|
||||||
|
(set-current-input-port
|
||||||
|
(open-input-file "/home/samplet/code/gash/mes/test.sh"))
|
||||||
|
|
||||||
|
(write (read-sh-all))
|
||||||
|
(newline)
|
Loading…
Reference in New Issue