From d18e721a78d9551e12ac7efb44698cc65840dfb3 Mon Sep 17 00:00:00 2001 From: Timothy Sample Date: Wed, 23 Jun 2021 14:14:17 -0400 Subject: [PATCH] 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. --- gash/lexer.scm | 3 +- gash/parser.scm | 32 +++++------ mes/gash.mes | 141 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 156 insertions(+), 20 deletions(-) create mode 100644 mes/gash.mes diff --git a/gash/lexer.scm b/gash/lexer.scm index 9c5ab34..fe48082 100644 --- a/gash/lexer.scm +++ b/gash/lexer.scm @@ -102,8 +102,7 @@ (define operator-prefix-char? (let ((prefix-chars (delete-duplicates - (map (match-lambda - ((str . _) (string-ref str 0))) + (map (lambda (pair) (string-ref (car pair) 0)) *operators*)))) (cut memv <> prefix-chars))) diff --git a/gash/parser.scm b/gash/parser.scm index 6780c08..8f86e88 100644 --- a/gash/parser.scm +++ b/gash/parser.scm @@ -20,6 +20,7 @@ #:use-module (gash compat textual-ports) #:use-module (gash lexer) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #: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) ((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) "Apply @var{proc} to each element of @var{xs}, mapping and folding 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." (let loop ((xs xs) (map-acc '()) (fold-acc init)) (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))) (() (values (reverse! map-acc) fold-acc))))) @@ -237,7 +234,7 @@ the same number of times.)" (linebreak complete-commands linebreak) : (if (null? (cdr $2)) (car $2) (reverse! $2)) (linebreak) - : (eof-object)) + : the-eof-object) (complete-commands (complete-commands newline-list complete-command) @@ -469,16 +466,16 @@ the same number of times.)" `( ,$2) `( ,assignments ,$2)))))) (cmd-prefix) - : (let*-values (((redirects assignments*) (partition io-redirect? $1)) - ((assignments) (map split-assignment assignments*))) - (match redirects - (() `( ,@assignments)) - (_ `( ,redirects - ,(if (null? assignments) - #f - `( ,@assignments)))))) + : (receive (redirects assignments*) (partition io-redirect? $1) + (let ((assignments (map split-assignment assignments*))) + (match redirects + (() `( ,@assignments)) + (_ `( ,redirects + ,(if (null? assignments) + #f + `( ,@assignments))))))) (cmd-name cmd-suffix) - : (let-values (((redirects args) (partition io-redirect? $2))) + : (receive (redirects args) (partition io-redirect? $2) (match redirects (() `( ,$1 ,@args)) (_ `( ,redirects @@ -725,8 +722,7 @@ ignored." (set! here-docs (append-reverse docs here-docs))) (define (insert-here-docs exp) - (let-values (((exp here-docs*) - (merge-here-docs exp (reverse here-docs)))) + (receive (exp here-docs*) (merge-here-docs exp (reverse here-docs)) (unless (null? here-docs*) (error "Unused here-documents")) (set! here-docs '()) @@ -774,7 +770,7 @@ treat the double quote character as escapable." ;; get-char (lambda () (match (lookahead-char port) - (#\` (eof-object)) + (#\` the-eof-object) (#\\ (begin (get-char port) (match (lookahead-char port) diff --git a/mes/gash.mes b/mes/gash.mes new file mode 100644 index 0000000..ce60d63 --- /dev/null +++ b/mes/gash.mes @@ -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 + (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)