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

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

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.)"
                      `(<sh-exec> ,$2)
                      `(<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))))))
+    : (receive (redirects assignments*) (partition io-redirect? $1)
+        (let ((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)))
+    : (receive (redirects args) (partition io-redirect? $2)
         (match redirects
           (() `(<sh-exec> ,$1 ,@args))
           (_ `(<sh-with-redirects> ,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)

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 <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)