mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 21:40:33 +02:00
Code Activity

Add docstring support

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2008-08-03 14:33:02 +02:00
parent 96969dc1d6
commit fbde2b915b
6 changed files with 36 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

12
module/language/scheme/translate.scm
View file

@ -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)))

12
module/system/il/compile.scm
View file

@ -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))

5
module/system/il/ghil.scm
View file

@ -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)))

7
module/system/il/glil.scm
View file

@ -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))

12
module/system/vm/assemble.scm
View file

@ -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))))))))))

7
module/system/vm/core.scm
View file

@ -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 '())))