remove useless <glil-vars> helper type, serialize GHIL more strictly

* module/language/ghil.scm (parse-ghil, unparse-ghil): Rework to make the
  parse format correspond more closely with the object representation, so
  that I only have to document it once in the manual. The salient change
  is that no expression is self-quoting, and that variable references
  should go through `(ref FOO)'. Rename `set!' to `set'.

* module/language/ghil/compile-glil.scm: Add a couple of compilers for
  unquote and unquote-splicing, that just raise an error. This way I can
  document unquote and unquote-splicing as normal ghil expressions,
  except that it's the compiler that catches them if they're outside a
  quasiquote.
  (codegen): Adapt to change in <glil-asm>.

* module/language/ghil/spec.scm (parse): Fix parser typo bug.

* module/language/glil.scm (<glil-asm>): Remove useless <glil-vars>
  structure, which also had a confusing name. Just put the nargs, nrest,
  nlocs, and nexts in the <glil-asm> directly.
  (parse-glil, unparse-glil): Serialize `asm' more straightforwardly.

* module/language/glil/compile-objcode.scm (<bytespec>): Remove
  <glil-vars>, as with <glil-asm>.
  (preprocess, make-meta, codegen, dump-object!): Adapt to change in
  <glil-asm>.

diff --git a/module/language/ghil.scm b/module/language/ghil.scm
index 336cd95..728c696 100644 (file)
--- a/module/language/ghil.scm
+++ b/module/language/ghil.scm
@@ -349,11 +349,8 @@
   (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))
+     ((ref ,sym) (guard (symbol? sym))
+      (make-ghil-ref env #f (ghil-var-for-ref! env sym)))
 
      (('quote ,exp) (make-ghil-quote #:env env #:loc loc #:obj exp))
 
@@ -380,7 +377,7 @@
           (let ((vals (map (lambda (exp) (parse-ghil env exp)) exprs)))
             (make-ghil-bind env loc vars vals (retrans `(begin ,@body)))))))
 
-     ((set! ,sym ,val)
+     ((set ,sym ,val)
       (make-ghil-set env loc (ghil-var-for-set! env sym) (retrans val)))
 
      ((define ,sym ,val)
@@ -430,9 +427,7 @@
     ((<ghil-void> env loc)
      '(void))
     ((<ghil-quote> env loc obj)
-     (if (symbol? obj)
-         `(,'quote ,obj)
-         obj))
+     `(,'quote ,obj))
     ((<ghil-quasiquote> env loc exp)
      `(,'quasiquote ,(map unparse-ghil exp)))
     ((<ghil-unquote> env loc exp)
@@ -441,9 +436,9 @@
      `(,'unquote-splicing ,(unparse-ghil exp)))
   ;; Variables
     ((<ghil-ref> env loc var)
-     (ghil-var-name var))
+     `(ref ,(ghil-var-name var)))
     ((<ghil-set> env loc var val)
-     `(set! ,(ghil-var-name var) ,(unparse-ghil val)))
+     `(set ,(ghil-var-name var) ,(unparse-ghil val)))
     ((<ghil-define> env loc var val)
      `(define ,(ghil-var-name var) ,(unparse-ghil val)))
   ;; Controls

diff --git a/module/language/ghil/compile-glil.scm b/module/language/ghil/compile-glil.scm
index ae68f14..b8259f8 100644 (file)
--- a/module/language/ghil/compile-glil.scm
+++ b/module/language/ghil/compile-glil.scm
@@ -216,6 +216,12 @@
         (maybe-drop)
         (maybe-return))
 
+       ((<ghil-unquote> env loc exp)
+         (error "unquote outside of quasiquote" exp))
+
+       ((<ghil-unquote-splicing> env loc exp)
+         (error "unquote-splicing outside of quasiquote" exp))
+
        ((<ghil-ref> env loc var)
         (return-code! loc (make-glil-var 'ref env var)))
 
@@ -428,11 +434,9 @@
         ;; compile body
         (comp body #t #f)
         ;; create GLIL
-        (let ((vars (make-glil-vars #:nargs (length vars)
-                                     #:nrest (if rest 1 0)
-                                     #:nlocs (length locs)
-                                     #:nexts (length exts))))
-          (make-glil-asm vars meta (reverse! stack))))))))
+         (make-glil-asm
+          (length vars) (if rest 1 0) (length locs) (length exts)
+          meta (reverse! stack)))))))
 
 (define (finalize-index! list)
   (do ((n 0 (1+ n))

diff --git a/module/language/ghil/spec.scm b/module/language/ghil/spec.scm
index 1f346f0..bac1387 100644 (file)
--- a/module/language/ghil/spec.scm
+++ b/module/language/ghil/spec.scm
@@ -31,7 +31,7 @@
   (apply write (unparse-ghil exp) port))
 
 (define (parse x)
-  (call-with-ghil-environment (make-ghil-toplevel-env e) '()
+  (call-with-ghil-environment (make-ghil-toplevel-env (current-module)) '()
     (lambda (env vars)
       (make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
 

diff --git a/module/language/glil.scm b/module/language/glil.scm
index 7844ad3..32f9403 100644 (file)
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -23,11 +23,9 @@
   #:use-module (system base syntax)
   #:use-module (system base pmatch)
   #:export
-  (<glil-vars> make-glil-vars
-   glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
-
-   <glil-asm> make-glil-asm glil-asm?
-   glil-asm-vars glil-asm-meta glil-asm-body
+  (<glil-asm> make-glil-asm glil-asm?
+   glil-asm-nargs glil-asm-nrest glil-asm-nlocs glil-asm-nexts
+   glil-asm-meta glil-asm-body
 
    <glil-bind> make-glil-bind glil-bind?
    glil-bind-vars
@@ -74,14 +72,12 @@
 
    parse-glil unparse-glil))
 
-(define-record <glil-vars> nargs nrest nlocs nexts)
-
 (define (print-glil x port)
   (format port "#<glil ~s>" (unparse-glil x)))
 
 (define-type (<glil> #:printer print-glil)
   ;; Meta operations
-  (<glil-asm> vars meta body)
+  (<glil-asm> nargs nrest nlocs nexts meta body)
   (<glil-bind> vars)
   (<glil-mv-bind> vars rest)
   (<glil-unbind>)
@@ -104,9 +100,8 @@
 \f
 (define (parse-glil x)
   (pmatch x
-    ((asm (,nargs ,nrest ,nlocs ,next) ,meta . ,body)
-     (make-glil-asm (make-glil-vars nargs nrest nlocs next)
-                    meta (map parse-glil body)))
+    ((asm ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
+     (make-glil-asm nargs nrest nlocs nexts meta (map parse-glil body)))
     ((bind . ,vars) (make-glil-bind vars))
     ((mv-bind ,vars . ,rest) (make-glil-mv-bind vars (map parse-glil rest)))
     ((unbind) (make-glil-unbind))
@@ -128,11 +123,8 @@
 (define (unparse-glil glil)
   (record-case glil
     ;; meta
-    ((<glil-asm> vars meta body)
-     `(asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
-            ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
-           ,meta
-           ,@(map unparse-glil body)))
+    ((<glil-asm> nargs nrest nlocs nexts meta body)
+     `(asm ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
     ((<glil-bind> vars) `(bind ,@vars))
     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,@rest))
     ((<glil-unbind>) `(unbind))

diff --git a/module/language/glil/compile-objcode.scm b/module/language/glil/compile-objcode.scm
index 5259ca0..d8b86e7 100644 (file)
--- a/module/language/glil/compile-objcode.scm
+++ b/module/language/glil/compile-objcode.scm
@@ -46,7 +46,7 @@
 (define-record <vlink-now> key)
 (define-record <vlink-later> key)
 (define-record <vdefine> name)
-(define-record <bytespec> vars bytes meta objs closure?)
+(define-record <bytespec> nargs nrest nlocs nexts bytes meta objs closure?)
 
 \f
 ;;;
@@ -55,8 +55,8 @@
 
 (define (preprocess x e)
   (record-case x
-    ((<glil-asm> vars meta body)
-     (let* ((venv (make-venv #:parent e #:nexts (glil-vars-nexts vars) #:closure? #f))
+    ((<glil-asm> nargs nrest nlocs nexts meta body)
+     (let* ((venv (make-venv #:parent e #:nexts nexts #:closure? #f))
            (body (map (lambda (x) (preprocess x venv)) body)))
        (make-vm-asm #:venv venv #:glil x #:body body)))
     ((<glil-external> op depth index)
@@ -89,7 +89,7 @@
           (push (code->bytes code) stack))
         (dump-object! push-code! `(,bindings ,sources ,@tail))
         (push-code! '(return))
-        (make-bytespec #:vars (make-glil-vars 0 0 0 0)
+        (make-bytespec #:nargs 0 #:nrest 0 #:nlocs 0 #:nexts 0
                        #:bytes (stack->bytes (reverse! stack) '())
                        #:meta #f #:objs #f #:closure? #f))))
 
@@ -109,7 +109,7 @@
 
 (define (codegen glil toplevel)
   (record-case glil
-    ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
+    ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> nargs nrest nlocs nexts meta) ; body?
      (let ((stack '())
           (open-bindings '())
           (closed-bindings '())
@@ -168,11 +168,11 @@
            (push-object! (codegen x #f))
            (if (venv-closure? venv) (push-code! `(make-closure))))
 
-          ((<glil-bind> (binds vars))
-            (push-bindings! (munge-bindings binds (glil-vars-nargs vars))))
+          ((<glil-bind> vars)
+            (push-bindings! (munge-bindings vars nargs)))
 
-          ((<glil-mv-bind> (binds vars) rest)
-            (push-bindings! (munge-bindings binds (glil-vars-nargs vars)))
+          ((<glil-mv-bind> vars rest)
+            (push-bindings! (munge-bindings vars nargs))
             (push-code! `(truncate-values ,(length binds) ,(if rest 1 0))))
 
           ((<glil-unbind>)
@@ -194,8 +194,8 @@
 
           ((<glil-local> op index)
            (if (eq? op 'ref)
-               (push-code! `(local-ref ,(+ (glil-vars-nargs vars) index)))
-               (push-code! `(local-set ,(+ (glil-vars-nargs vars) index)))))
+               (push-code! `(local-ref ,(+ nargs index)))
+               (push-code! `(local-set ,(+ nargs index)))))
 
           ((<glil-external> op depth index)
            (do ((e venv (venv-parent e))
@@ -281,8 +281,9 @@
 ;       (format #t "codegen: stack = ~a~%" (reverse stack))
        (let ((bytes (stack->bytes (reverse! stack) label-alist)))
         (if toplevel
-            (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
-            (make-bytespec #:vars vars #:bytes bytes
+            (bytecode->objcode bytes nlocs nexts)
+            (make-bytespec #:nargs nargs #:nrest nrest #:nlocs nlocs
+                            #:nexts nexts #:bytes bytes
                             #:meta (make-meta closed-bindings
                                               (reverse! source-alist)
                                               meta)
@@ -343,28 +344,26 @@
      ((object->code x) => push-code!)
      ((record? x)
       (record-case x
-       ((<bytespec> vars bytes meta objs closure?)
-        ;; dump parameters
-        (let ((nargs (glil-vars-nargs vars)) (nrest (glil-vars-nrest vars))
-              (nlocs (glil-vars-nlocs vars)) (nexts (glil-vars-nexts vars)))
-          (cond
-            ((and (< nargs 16) (< nlocs 128) (< nexts 16))
-             ;; 16-bit representation
-             (let ((x (logior
-                        (ash nargs 12) (ash nrest 11) (ash nlocs 4) nexts)))
-               (push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8)))))))
-            (else
-             ;; Other cases
-              (if (> (+ nargs nlocs) 255)
-                  (error "too many locals" nargs nlocs))
-              ;; really it should be a flag..
-              (if (> nrest 1) (error "nrest should be 0 or 1" nrest))
-              (if (> nexts 255) (error "too many externals" nexts))
-             (push-code! (object->code nargs))
-             (push-code! (object->code nrest))
-             (push-code! (object->code nlocs))
-             (push-code! (object->code nexts))
-             (push-code! (object->code #f)))))
+        ((<bytespec> nargs nrest nlocs nexts bytes meta objs closure?)
+         ;; dump parameters
+         (cond
+          ((and (< nargs 16) (< nlocs 128) (< nexts 16))
+           ;; 16-bit representation
+           (let ((x (logior
+                     (ash nargs 12) (ash nrest 11) (ash nlocs 4) nexts)))
+             (push-code! `(make-int16 ,(ash x -8) ,(logand x (1- (ash 1 8)))))))
+          (else
+           ;; Other cases
+           (if (> (+ nargs nlocs) 255)
+               (error "too many locals" nargs nlocs))
+           ;; really it should be a flag..
+           (if (> nrest 1) (error "nrest should be 0 or 1" nrest))
+           (if (> nexts 255) (error "too many externals" nexts))
+           (push-code! (object->code nargs))
+           (push-code! (object->code nrest))
+           (push-code! (object->code nlocs))
+           (push-code! (object->code nexts))
+           (push-code! (object->code #f))))
         ;; dump object table
         (if objs (dump! objs))
         ;; dump meta data