diff options
-rw-r--r-- | module/language/scheme/translate.scm | 12 | ||||
-rw-r--r-- | module/system/il/compile.scm | 12 | ||||
-rw-r--r-- | module/system/il/ghil.scm | 5 | ||||
-rw-r--r-- | module/system/il/glil.scm | 7 | ||||
-rw-r--r-- | module/system/vm/assemble.scm | 12 | ||||
-rw-r--r-- | module/system/vm/core.scm | 7 |
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 '()))) |