summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/scheme/translate.scm12
-rw-r--r--module/system/il/compile.scm12
-rw-r--r--module/system/il/ghil.scm5
-rw-r--r--module/system/il/glil.scm7
-rw-r--r--module/system/vm/assemble.scm12
-rw-r--r--module/system/vm/core.scm7
6 files changed, 36 insertions, 19 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 07fc2070f..24d3eadc5 100644
--- 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)))))
;;;
@@ -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 c74fe8a87..233147e25 100644
--- 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 12c2b6254..9fab56952 100644
--- 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 5afa6fe3e..1b93bd149 100644
--- 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 cbb193e0f..897a386af 100644
--- 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 f9e31fcc0..36f1815f1 100644
--- 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 '())))