add parsers and unparser for ghil; ,language ghil works now

* module/system/repl/common.scm (repl-print): Slightly refine the meaning
  of "language-printer": a language printer prints an expression of a
  language, not the result of evaluation. `write' prints values.

* module/language/ghil/spec.scm (ghil): Define a language printer, and a
  translator for turning s-expressions (not scheme, mind you) into GHIL.

* module/language/scheme/translate.scm (quote, quasiquote): Add some
  #:keyword action, so that we can (quote #:keywords).

* module/system/base/language.scm (<language>):
* module/system/base/compile.scm (read-file-in): Don't require that a
  language have a read-file; instead error when read-file is called.
  (compile-passes, compile-in): Refactor to call a helper method to turn
  the language + set of options into a set of compiler passes.

* module/system/base/syntax.scm (define-type): Allow the type to be a
  list, with the car being the name and the cdr being keyword options.
  Interpret #:printer as a printer, and pass it down to...
  (define-record): Here.

* module/system/il/ghil.scm (print-ghil, <ghil>): New printer for GHIL,
  yay!
  (parse-ghil, unparse-ghil): New lovely functions. Will document them in
  the manual.

module/language/ghil/spec.scm

@@ -21,12 +21,21 @@
 
 (define-module (language ghil spec)
   #:use-module (system base language)
+  #:use-module (system il ghil)
   #:export (ghil))
 
+(define (write-ghil exp . port)
+  (apply write (unparse-ghil exp) port))
+
+(define (translate x e)
+  (call-with-ghil-environment e '()
+    (lambda (env vars)
+      (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
+
 (define-language ghil
   #:title	"Guile High Intermediate Language (GHIL)"
   #:version	"0.3"
   #:reader	read
-  #:printer	write
-;;  #:environment	(make-vmodule)
+  #:printer	write-ghil
+  #:translator  translate
   )

module/language/scheme/translate.scm

@@ -136,11 +136,11 @@
 
 (define-scheme-translator quote
   ;; (quote OBJ)
-  ((,obj) (make-ghil-quote e l obj)))
+  ((,obj) (make-ghil-quote e l #:obj obj)))
     
 (define-scheme-translator quasiquote
   ;; (quasiquote OBJ)
-  ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
+  ((,obj) (make-ghil-quasiquote e l #:exp (trans-quasiquote e l obj 0))))
 
 (define-scheme-translator define
   ;; (define NAME VAL)

module/system/base/compile.scm

@@ -30,6 +30,7 @@
   #:use-module (system vm vm) ;; for compile-time evaluation
   #:use-module (ice-9 regex)
   #:use-module (ice-9 optargs)
+  #:use-module ((srfi srfi-1) #:select (fold))
   #:export (syntax-error compile-file load-source-file load-file
             *current-language*
             compiled-file-name
@@ -197,27 +198,35 @@ time. Useful for supporting some forms of dynamic compilation. Returns
 ;;;
 
 (define (read-file-in file lang)
-  (call-with-input-file file (language-read-file lang)))
+  (call-with-input-file file (or (language-read-file lang)
+                                 (error "language has no #:read-file" lang))))
+
+;;; FIXME: fold run-pass x (compile-passes lang opts) 
+(define (compile-passes lang opts)
+  (let lp ((passes (list
+                    (language-expander lang)
+                    (language-translator lang)
+                    (lambda (x e) (apply compile-il x e opts))
+                    (lambda (x e) (apply assemble x e opts))))
+           (keys '(#f #:e #:t #:c))
+           (out '()))
+    (if (or (null? keys)
+            (and (car keys) (memq (car keys) opts)))
+        (reverse! out)
+        (lp (cdr passes) (cdr keys)
+            (if (car passes)
+                (cons (car passes) out)
+                out)))))
 
 (define (compile-in x e lang . opts)
   (save-module-excursion
    (lambda ()
-     (catch 'result
-      (lambda ()
-        (and=> (cenv-module e) set-current-module)
-        (set! e (cenv-ghil-env e))
-        ;; expand
-        (set! x ((language-expander lang) x e))
-        (if (memq #:e opts) (throw 'result x))
-        ;; translate
-        (set! x ((language-translator lang) x e))
-        (if (memq #:t opts) (throw 'result x))
-        ;; compile
-        (set! x (apply compile-il x e opts))
-        (if (memq #:c opts) (throw 'result x))
-        ;; assemble
-        (apply assemble x e opts))
-      (lambda (key val) val)))))
+     (and=> (cenv-module e) set-current-module)
+     (let ((env (cenv-ghil-env e)))
+       (fold (lambda (pass exp)
+               (pass exp env))
+             x
+             (compile-passes lang opts))))))
 
 ;;;
 ;;;

module/system/base/language.scm

@@ -31,9 +31,10 @@
 ;;; Language class
 ;;;
 
-(define-record (<language> name title version reader printer read-file
-			   (expander (lambda (x e) x))
-			   (translator (lambda (x e) x))
+(define-record (<language> name title version reader printer
+                           (read-file #f)
+			   (expander #f)
+			   (translator #f)
 			   (evaluator #f)
 			   (environment #f)
 			   ))

module/system/base/syntax.scm

@@ -29,7 +29,12 @@
 ;;;
 
 (define-macro (define-type name . rest)
-  `(begin ,@(map (lambda (def) `(define-record ,def)) rest)))
+  (let ((name (if (pair? name) (car name) name))
+        (opts (if (pair? name) (cdr name) '())))
+    (let ((printer (kw-arg-ref opts #:printer)))
+      `(begin ,@(map (lambda (def) `(define-record ,def
+                                      ,@(if printer (list printer) '())))
+                     rest)))))
 
 
 ;;;
@@ -39,13 +44,14 @@
 (define (symbol-trim-both sym pred)
   (string->symbol (string-trim-both (symbol->string sym) pred)))
 
-(define-macro (define-record def)
+(define-macro (define-record def . printer)
   (let* ((name (car def)) (slots (cdr def))
          (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
                           slots))
          (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
     `(begin
-       (define ,name (make-record-type ,(symbol->string name) ',slot-names))
+       (define ,name (make-record-type ,(symbol->string name) ',slot-names
+                                       ,@printer))
        (define ,(symbol-append 'make- stem)
          (let ((slots (list ,@(map (lambda (slot)
                                      (if (pair? slot)

module/system/il/ghil.scm

@@ -20,7 +20,8 @@
 ;;; Code:
 
 (define-module (system il ghil)
-  #:use-syntax (system base syntax)
+  #:use-module (system base syntax)
+  #:use-module (system base pmatch)
   #:use-module (ice-9 regex)
   #:export
   (<ghil-void> make-ghil-void ghil-void?
@@ -100,14 +101,19 @@
    ghil-env-reify ghil-env-dereify
    ghil-var-is-bound? ghil-var-for-ref! ghil-var-for-set! ghil-var-define!
    ghil-var-at-module!
-   call-with-ghil-environment call-with-ghil-bindings))
+   call-with-ghil-environment call-with-ghil-bindings
+
+   parse-ghil unparse-ghil))
 
 
 ;;;
 ;;; Parse tree
 ;;;
 
-(define-type <ghil>
+(define (print-ghil x port)
+  (format port "#<ghil ~s>" (unparse-ghil x)))
+
+(define-type (<ghil> #:printer print-ghil)
   ;; Objects
   (<ghil-void> env loc)
   (<ghil-quote> env loc obj)
@@ -309,156 +315,162 @@
 ;;; Parser
 ;;;
 
-;;; (define-public (parse-ghil x e)
-;;;   (parse `(@lambda () ,x) (make-ghil-mod e)))
-;;; 
-;;; (define (parse x e)
-;;;   (cond ((pair? x) (parse-pair x e))
-;;; 	((symbol? x)
-;;; 	 (let ((str (symbol->string x)))
-;;; 	   (case (string-ref str 0)
-;;; 	     ((#\@) (error "Invalid use of IL primitive" x))
-;;; 	     ((#\:) (let ((sym (string->symbol (substring str 1))))
-;;; 		      (<ghil-quote> (symbol->keyword sym))))
-;;; 	     (else (<ghil-ref> e (ghil-lookup e x))))))
-;;; 	(else (<ghil-quote> x))))
-;;; 
-;;; (define (map-parse x e)
-;;;   (map (lambda (x) (parse x e)) x))
-;;; 
-;;; (define (parse-pair x e)
-;;;   (let ((head (car x)) (tail (cdr x)))
-;;;     (if (and (symbol? head) (eq? (string-ref (symbol->string head) 0) #\@))
-;;; 	(if (ghil-primitive-macro? head)
-;;; 	    (parse (apply (ghil-macro-expander head) tail) e)
-;;; 	    (parse-primitive head tail e))
-;;; 	(<ghil-call> e (parse head e) (map-parse tail e)))))
-;;; 
-;;; (define (parse-primitive prim args e)
-;;;   (case prim
-;;;     ;; (@ IDENTIFIER)
-;;;     ((@)
-;;;      (match args
-;;;        (()
-;;; 	(<ghil-ref> e (make-ghil-var '@ '@ 'module)))
-;;;        ((identifier)
-;;; 	(receive (module name) (identifier-split identifier)
-;;; 	  (<ghil-ref> e (make-ghil-var module name 'module))))))
-;;; 
-;;;     ;; (@@ OP ARGS...)
-;;;     ((@@)
-;;;      (match args
-;;;        ((op . args)
-;;; 	(<ghil-inline> op (map-parse args e)))))
-;;; 
-;;;     ;; (@void)
-;;;     ((@void)
-;;;      (match args
-;;;        (() (<ghil-void>))))
-;;; 
-;;;     ;; (@quote OBJ)
-;;;     ((@quote)
-;;;      (match args
-;;;        ((obj)
-;;; 	(<ghil-quote> obj))))
-;;; 
-;;;     ;; (@define NAME VAL)
-;;;     ((@define)
-;;;      (match args
-;;;        ((name val)
-;;; 	(let ((v (ghil-lookup e name)))
-;;; 	  (<ghil-set> e v (parse val e))))))
-;;; 
-;;;     ;; (@set! NAME VAL)
-;;;     ((@set!)
-;;;      (match args
-;;;        ((name val)
-;;; 	(let ((v (ghil-lookup e name)))
-;;; 	  (<ghil-set> e v (parse val e))))))
-;;; 
-;;;     ;; (@if TEST THEN [ELSE])
-;;;     ((@if)
-;;;      (match args
-;;;        ((test then)
-;;; 	(<ghil-if> (parse test e) (parse then e) (<ghil-void>)))
-;;;        ((test then else)
-;;; 	(<ghil-if> (parse test e) (parse then e) (parse else e)))))
-;;; 
-;;;     ;; (@begin BODY...)
-;;;     ((@begin)
-;;;      (parse-body args e))
-;;; 
-;;;     ;; (@let ((SYM INIT)...) BODY...)
-;;;     ((@let)
-;;;      (match args
-;;;        ((((sym init) ...) body ...)
-;;; 	(let* ((vals (map-parse init e))
-;;; 	       (vars (map (lambda (s)
-;;; 			    (let ((v (make-ghil-var e s 'local)))
-;;; 			      (ghil-env-add! e v) v))
-;;; 			  sym))
-;;; 	       (body (parse-body body e)))
-;;; 	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
-;;; 	  (<ghil-bind> e vars vals body)))))
-;;; 
-;;;     ;; (@letrec ((SYM INIT)...) BODY...)
-;;;     ((@letrec)
-;;;      (match args
-;;;        ((((sym init) ...) body ...)
-;;; 	(let* ((vars (map (lambda (s)
-;;; 			    (let ((v (make-ghil-var e s 'local)))
-;;; 			      (ghil-env-add! e v) v))
-;;; 			  sym))
-;;; 	       (vals (map-parse init e))
-;;; 	       (body (parse-body body e)))
-;;; 	  (for-each (lambda (v) (ghil-env-remove! e v)) vars)
-;;; 	  (<ghil-bind> e vars vals body)))))
-;;; 
-;;;     ;; (@lambda FORMALS BODY...)
-;;;     ((@lambda)
-;;;      (match args
-;;;        ((formals . body)
-;;; 	(receive (syms rest) (parse-formals formals)
-;;; 	  (let* ((e (make-ghil-env e))
-;;; 		 (vars (map (lambda (s)
-;;; 			      (let ((v (make-ghil-var e s 'argument)))
-;;; 				(ghil-env-add! e v) v))
-;;; 			    syms)))
-;;; 	    (<ghil-lambda> e vars rest (parse-body body e)))))))
-;;; 
-;;;     ;; (@eval-case CLAUSE...)
-;;;     ((@eval-case)
-;;;      (let loop ((clauses args))
-;;;        (cond ((null? clauses) (<ghil-void>))
-;;; 	     ((or (eq? (caar clauses) '@else)
-;;; 		  (and (memq 'load-toplevel (caar clauses))
-;;; 		       (ghil-env-toplevel? e)))
-;;; 	      (parse-body (cdar clauses) e))
-;;; 	     (else
-;;; 	      (loop (cdr clauses))))))
-;;; 
-;;;     (else (error "Unknown primitive:" prim))))
-;;; 
-;;; (define (parse-body x e)
-;;;   (<ghil-begin> (map-parse x e)))
-;;; 
-;;; (define (parse-formals formals)
-;;;   (cond
-;;;    ;; (@lambda x ...)
-;;;    ((symbol? formals) (values (list formals) #t))
-;;;    ;; (@lambda (x y z) ...)
-;;;    ((list? formals) (values formals #f))
-;;;    ;; (@lambda (x y . z) ...)
-;;;    ((pair? formals)
-;;;     (let loop ((l formals) (v '()))
-;;;       (if (pair? l)
-;;; 	  (loop (cdr l) (cons (car l) v))
-;;; 	  (values (reverse! (cons l v)) #t))))
-;;;    (else (error "Invalid formals:" formals))))
-;;; 
-;;; (define (identifier-split identifier)
-;;;   (let ((m (string-match "::([^:]*)$" (symbol->string identifier))))
-;;;     (if m
-;;; 	(values (string->symbol (match:prefix m))
-;;; 		(string->symbol (match:substring m 1)))
-;;; 	(values #f identifier))))
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (not (null? props))
+	      (vector (assq-ref props 'line)
+                      (assq-ref props 'column)
+                      (assq-ref props 'filename))))))
+
+(define (parse-quasiquote e x level)
+  (cond ((not (pair? x)) x)
+	((memq (car x) '(unquote unquote-splicing))
+	 (let ((l (location x)))
+	   (pmatch (cdr x)
+	     ((,obj)
+              (cond
+               ((zero? level) 
+                (if (eq? (car x) 'unquote)
+                    (make-ghil-unquote e l (parse-ghil e obj))
+                    (make-ghil-unquote-splicing e l (parse-ghil e obj))))
+               (else
+                (list (car x) (parse-quasiquote e obj (1- level))))))
+	     (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+        ((eq? (car x) 'quasiquote)
+	 (let ((l (location x)))
+	   (pmatch (cdr x)
+	     ((,obj) (list 'quasiquote (parse-quasiquote e obj (1+ level))))
+             (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+	(else (cons (parse-quasiquote e (car x) level)
+		    (parse-quasiquote e (cdr x) level)))))
+
+(define (parse-ghil env exp)
+  (let ((loc (location exp))
+        (retrans (lambda (x) (parse-ghil env x))))
+    (pmatch exp
+     (,exp (guard (symbol? exp))
+           (make-ghil-ref env #f (ghil-var-for-ref! env exp)))
+
+     (,exp (guard (not (pair? exp)))
+           (make-ghil-quote #:env env #:loc #f #:obj exp))
+
+     (('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
+
+     ((void) (make-ghil-void env loc))
+
+     ((lambda ,syms ,rest ,meta . ,body)
+      (call-with-ghil-environment env syms
+        (lambda (env vars)
+          (make-ghil-lambda env loc vars rest meta
+                            (parse-ghil env `(begin ,@body))))))
+
+     ((begin . ,body)
+      (make-ghil-begin env loc (map retrans body)))
+
+     ((bind ,syms ,exprs . ,body)
+      (let ((vals (map retrans exprs)))
+        (call-with-ghil-bindings env syms
+          (lambda (vars)
+            (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
+
+     ((bindrec ,syms ,exprs . ,body)
+      (call-with-ghil-bindings env syms
+        (lambda (vars)
+          (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
+            (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
+
+     ((set! ,sym ,val)
+      (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
+
+     ((define ,sym ,val)
+      (make-ghil-define env loc (ghil-var-define! env sym) (retrans val)))
+
+     ((if ,test ,then ,else)
+      (make-ghil-if env loc (retrans test) (retrans then) (retrans else)))
+
+     ((and . ,exps)
+      (make-ghil-and env loc (map retrans exps)))
+
+     ((or . ,exps)
+      (make-ghil-or env loc (map retrans exps)))
+
+     ((mv-bind ,syms ,rest ,producer . ,body)
+      (call-with-ghil-bindings env syms
+        (lambda (vars)
+          (make-ghil-mv-bind env loc (retrans producer) vars rest
+                             (map retrans body)))))
+
+     ((call ,proc . ,args)
+      (make-ghil-call env loc (retrans proc) (map retrans args)))
+
+     ((mv-call ,producer . ,consumer)
+      (make-ghil-mv-call env loc (retrans producer) (retrans consumer)))
+
+     ((inline ,op . ,args)
+      (make-ghil-inline env loc op (map retrans args)))
+
+     ((values . ,values)
+      (make-ghil-values env loc (map retrans values)))
+
+     ((values* . ,values)
+      (make-ghil-values env loc (map retrans values)))
+
+     ((compile-time-environment)
+      (make-ghil-reified-env env loc))
+
+     ((quasiquote ,exp)
+      (make-ghil-quasiquote env loc #:exp (parse-quasiquote env exp 0)))
+
+     (else
+      (error "unrecognized GHIL" exp)))))
+
+(define (unparse-ghil ghil)
+  (record-case ghil
+    ((<ghil-void> env loc)
+     '(void))
+    ((<ghil-quote> env loc obj)
+     `(quote ,obj))
+    ((<ghil-quasiquote> env loc exp)
+     `(quasiquote ,(map unparse-ghil exp)))
+    ((<ghil-unquote> env loc exp)
+     `(unquote ,(unparse-ghil exp)))
+    ((<ghil-unquote-splicing> env loc exp)
+     `(unquote-splicing ,(unparse-ghil exp)))
+  ;; Variables
+    ((<ghil-ref> env loc var)
+     (ghil-var-name var))
+    ((<ghil-set> env loc var val)
+     `(set! ,(ghil-var-name var) ,(unparse-ghil val)))
+    ((<ghil-define> env loc var val)
+     `(define ,(ghil-var-name var) ,(unparse-ghil val)))
+  ;; Controls
+    ((<ghil-if> env loc test then else)
+     `(if ,(unparse-ghil test) ,(unparse-ghil then) ,(unparse-ghil else)))
+    ((<ghil-and> env loc exps)
+     `(and ,@(map unparse-ghil exps)))
+    ((<ghil-or> env loc exps)
+     `(or ,@(map unparse-ghil exps)))
+    ((<ghil-begin> env loc exps)
+     `(begin ,@(map unparse-ghil exps)))
+    ((<ghil-bind> env loc vars vals body)
+     `(bind ,(map ghil-var-name vars) ,(map unparse-ghil vals)
+            ,@(map unparse-ghil body)))
+    ((<ghil-mv-bind> env loc producer vars rest body)
+     `(mv-bind ,(map ghil-var-name vars) ,rest
+               ,(unparse-ghil producer) ,@(map unparse-ghil body)))
+    ((<ghil-lambda> env loc vars rest meta body)
+     `(lambda ,(map ghil-var-name vars) ,rest ,meta
+              ,(unparse-ghil body)))
+    ((<ghil-call> env loc proc args)
+     `(call ,(unparse-ghil proc) ,@(map unparse-ghil args)))
+    ((<ghil-mv-call> env loc producer consumer)
+     `(mv-call ,(unparse-ghil producer) ,(unparse-ghil consumer)))
+    ((<ghil-inline> env loc inline args)
+     `(inline ,inline (map unparse-ghil args)))
+    ((<ghil-values> env loc values)
+     `(values (map unparse-ghil values)))
+    ((<ghil-values*> env loc values)
+     `(values* (map unparse-ghil values)))
+    ((<ghil-reified-env> env loc)
+     `(compile-time-environment))))

module/system/repl/common.scm

@@ -78,7 +78,11 @@
 (define (repl-print repl val)
   (if (not (eq? val *unspecified*))
       (begin
-	((language-printer (repl-language repl)) val)
+        ;; The result of an evaluation is representable in scheme, and
+        ;; should be printed with the generic printer, `write'. The
+        ;; language-printer is something else: it prints expressions of
+        ;; a given language, not the result of evaluation.
+	(write val)
 	(newline))))
 
 (define (repl-option-ref repl key)