Add docstring support

* module/language/scheme/translate.scm (translate): Adapt to lambda
  having a `meta' slot now.
  (primitive-syntax-table, parse-lambda-meta): Parse out a docstring from
  lambda forms, putting in the <ghil-lambda>'s meta slot.

* module/system/il/compile.scm (optimize, codegen): Passthrough for the
  `meta' slot to the <glil-asm> object.

* module/system/il/ghil.scm (<ghil-lambda>): Add meta slot.

* module/system/il/glil.scm (<glil-asm>): Add meta slot.
  (unparse): Unparse meta.

* module/system/vm/assemble.scm (preprocess): Pass through the meta slot.
  (codegen): So, set the bytespec's meta slot as a list: bindings, source
  info, then the tail is the meta-info, which should be an alist.
  Currently the only defined key is `documentation', but `name' could
  come in the future.

* module/system/vm/core.scm (program-sources): Sources are now in the
  cadr...
  (program-property): And here we have access to the cddr.

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 07fc207..24d3ead 100644 (file)
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -33,7 +33,7 @@
 (define (translate x e)
   (call-with-ghil-environment (make-ghil-mod e) '()
     (lambda (env vars)
-      (make-ghil-lambda env #f vars #f (trans env (location x) x)))))
+      (make-ghil-lambda env #f vars #f '() (trans env (location x) x)))))
 
 \f
 ;;;
@@ -259,7 +259,9 @@
       (receive (syms rest) (parse-formals formals)
         (call-with-ghil-environment e syms
        (lambda (env vars)
-            (make-ghil-lambda env l vars rest (trans-body env l body)))))))
+         (receive (meta body) (parse-lambda-meta body)
+            (make-ghil-lambda env l vars rest meta
+                              (trans-body env l body))))))))
 
     (eval-case
      (,clauses
@@ -336,6 +338,12 @@
          (values (reverse! (cons l v)) #t))))
    (else (syntax-error (location formals) "bad formals" formals))))
 
+(define (parse-lambda-meta body)
+  (cond ((or (null? body) (null? (cdr body))) (values '() body))
+        ((string? (car body))
+         (values `((documentation . ,(car body))) (cdr body)))
+        (else (values '() body))))
+
 (define (location x)
   (and (pair? x)
        (let ((props (source-properties x)))

diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index c74fe8a..233147e 100644 (file)
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -49,8 +49,8 @@
     ((<ghil-bind> env loc vars vals body)
      (make-ghil-bind env loc vars (map optimize vals) (optimize body)))
 
-    ((<ghil-lambda> env loc vars rest body)
-     (make-ghil-lambda env loc vars rest (optimize body)))
+    ((<ghil-lambda> env loc vars rest meta body)
+     (make-ghil-lambda env loc vars rest meta (optimize body)))
 
     ((<ghil-inline> env loc instruction args)
      (make-ghil-inline env loc instruction (map optimize args)))
@@ -60,7 +60,7 @@
        (record-case proc
          ;; ((@lambda (VAR...) BODY...) ARG...) =>
          ;;   (@let ((VAR ARG) ...) BODY...)
-         ((<ghil-lambda> env loc vars rest body)
+         ((<ghil-lambda> env loc vars rest meta body)
           (cond
            ((not rest)
             (for-each (lambda (v)
@@ -275,7 +275,7 @@
         (comp-tail body)
         (push-code! #f (make-glil-unbind)))
 
-       ((<ghil-lambda> env loc vars rest body)
+       ((<ghil-lambda> env loc vars rest meta body)
         (return-code! loc (codegen tree)))
 
        ((<ghil-inline> env loc inline args)
@@ -295,7 +295,7 @@
     ;;
     ;; main
     (record-case ghil
-      ((<ghil-lambda> env loc vars rest body)
+      ((<ghil-lambda> env loc vars rest meta body)
        (let* ((evars (ghil-env-variables env))
              (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
              (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
@@ -321,7 +321,7 @@
                                      :nrest (if rest 1 0)
                                      :nlocs (length locs)
                                      :nexts (length exts))))
-          (make-glil-asm vars (reverse! stack))))))))
+          (make-glil-asm vars meta (reverse! stack))))))))
 
 (define (finalize-index! list)
   (do ((n 0 (1+ n))

diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 12c2b62..9fab569 100644 (file)
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -63,7 +63,8 @@
    ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
 
    <ghil-lambda> make-ghil-lambda ghil-lambda?
-   ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body
+   ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest
+   ghil-lambda-meta ghil-lambda-body
 
    <ghil-inline> make-ghil-inline ghil-inline?
    ghil-inline-env ghil-inline-loc ghil-inline-inline ghil-inline-args
@@ -108,7 +109,7 @@
    (<ghil-or> env loc exps)
    (<ghil-begin> env loc exps)
    (<ghil-bind> env loc vars vals body)
-   (<ghil-lambda> env loc vars rest body)
+   (<ghil-lambda> env loc vars rest meta body)
    (<ghil-call> env loc proc args)
    (<ghil-inline> env loc inline args)))
 

diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
index 5afa6fe..1b93bd1 100644 (file)
--- a/module/system/il/glil.scm
+++ b/module/system/il/glil.scm
@@ -27,7 +27,7 @@
    glil-vars-nargs glil-vars-nrest glil-vars-nlocs glil-vars-nexts
 
    <glil-asm> make-glil-asm glil-asm?
-   glil-asm-vars glil-asm-body
+   glil-asm-vars glil-asm-meta glil-asm-body
 
    <glil-bind> make-glil-bind glil-bind?
    glil-bind-vars
@@ -71,7 +71,7 @@
 (define-type <glil>
   (|
    ;; Meta operations
-   (<glil-asm> vars body)
+   (<glil-asm> vars meta body)
    (<glil-bind> vars)
    (<glil-unbind>)
    (<glil-source> loc)
@@ -166,9 +166,10 @@
 (define (unparse glil)
   (record-case glil
     ;; meta
-    ((<glil-asm> vars body)
+    ((<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 body)))
     ((<glil-bind> vars) `(@bind ,@vars))
     ((<glil-unbind>) `(@unbind))

diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index cbb193e..897a386 100644 (file)
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -56,7 +56,7 @@
 
 (define (preprocess x e)
   (record-case x
-    ((<glil-asm> vars body)
+    ((<glil-asm> vars meta body)
      (let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f))
            (body (map (lambda (x) (preprocess x venv)) body)))
        (make-vm-asm :venv venv :glil x :body body)))
@@ -75,7 +75,7 @@
 
 (define (codegen glil toplevel)
   (record-case glil
-    ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars)
+    ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
      (let ((stack '())
           (binding-alist '())
           (source-alist '())
@@ -198,10 +198,12 @@
             (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
             (make-bytespec :vars vars :bytes bytes
                             :meta (if (and (null? binding-alist)
-                                           (null? source-alist))
+                                           (null? source-alist)
+                                           (null? meta))
                                       #f
-                                      (cons (reverse! binding-alist)
-                                            (reverse! source-alist)))
+                                      (cons* (reverse! binding-alist)
+                                             (reverse! source-alist)
+                                             meta))
                             :objs (let ((objs (map car (reverse! object-alist))))
                                     (if (null? objs) #f (list->vector objs)))
                             :closure? (venv-closure? venv))))))))))

diff --git a/module/system/vm/core.scm b/module/system/vm/core.scm
index f9e31fc..36f1815 100644 (file)
--- a/module/system/vm/core.scm
+++ b/module/system/vm/core.scm
@@ -63,7 +63,12 @@
        (else '())))
 
 (define (program-sources prog)
-  (cond ((program-meta prog) => cdr)
+  (cond ((program-meta prog) => cadr)
+       (else '())))
+
+(define (program-property prog prop)
+  (cond ((program-meta prog) => (lambda (x)
+                                  (assq-ref (cddr x) prop)))
        (else '())))
 
 \f