mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

declaration parsing

Browse source 
* module/language/elisp/compile-tree-il.scm (parse-body-1, parse-body)
  (parse-lambda-body, parse-declaration): New procedures.
  (generate-let, generate-let*): Use `parse-body'.
  (compile-lambda): Use `parse-lambda-body'.
This commit is contained in:
BT Templeton 2011-08-05 16:14:42 -04:00
parent 1631817977
commit 805b821189
1 changed files with 147 additions and 105 deletions
Download patch file Download diff file Expand all files Collapse all files

252
module/language/elisp/compile-tree-il.scm
View file

@ -239,6 +239,42 @@
(fluid-ref lexical-binding) (fluid-ref lexical-binding)
(not (global? (fluid-ref bindings-data) sym module))))))) (not (global? (fluid-ref bindings-data) sym module)))))))
(define (parse-declaration expr)
(pmatch expr
((lexical . ,vars)
(map (cut cons <> 'lexical) vars))
((special . ,vars)
(map (cut cons <> 'special) vars))
(else
'())))
(define (parse-body-1 body lambda?)
(let loop ((lst body)
(decls '())
(intspec #f)
(doc #f))
(pmatch lst
(((declare . ,x) . ,tail)
(loop tail (append-reverse x decls) intspec doc))
(((interactive . ,x) . ,tail)
(guard lambda? (not intspec))
(loop tail decls x doc))
((,x . ,tail)
(guard lambda? (string? x) (not doc) (not (null? tail)))
(loop tail decls intspec x))
(else
(values (append-map parse-declaration decls)
intspec
doc
lst)))))
(define (parse-lambda-body body)
(parse-body-1 body #t))
(define (parse-body body)
(receive (decls intspec doc body) (parse-body-1 body #f)
(values decls body)))
(define (split-let-bindings bindings module) (define (split-let-bindings bindings module)
(let iterate ((tail bindings) (let iterate ((tail bindings)
(lexical '()) (lexical '())
@ -264,80 +300,82 @@
(define (generate-let loc module bindings body) (define (generate-let loc module bindings body)
(let ((bind (process-let-bindings loc bindings))) (let ((bind (process-let-bindings loc bindings)))
(call-with-values (receive (decls forms) (parse-body body)
(lambda () (split-let-bindings bind module)) (call-with-values
(lambda (lexical dynamic) (lambda () (split-let-bindings bind module))
(for-each (lambda (sym) (lambda (lexical dynamic)
(mark-global! (fluid-ref bindings-data) (for-each (lambda (sym)
sym (mark-global! (fluid-ref bindings-data)
module)) sym
(map car dynamic)) module))
(let ((make-values (lambda (for) (map car dynamic))
(map (lambda (el) (compile-expr (cdr el))) (let ((make-values (lambda (for)
for))) (map (lambda (el) (compile-expr (cdr el)))
(make-body (lambda () (compile-expr `(progn ,@body))))) for)))
(if (null? lexical) (make-body (lambda () (compile-expr `(progn ,@forms)))))
(let-dynamic loc (map car dynamic) module (if (null? lexical)
(make-values dynamic) (make-body)) (let-dynamic loc (map car dynamic) module
(let* ((lexical-syms (map (lambda (el) (gensym)) lexical)) (make-values dynamic) (make-body))
(dynamic-syms (map (lambda (el) (gensym)) dynamic)) (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
(all-syms (append lexical-syms dynamic-syms)) (dynamic-syms (map (lambda (el) (gensym)) dynamic))
(vals (append (make-values lexical) (all-syms (append lexical-syms dynamic-syms))
(make-values dynamic)))) (vals (append (make-values lexical)
(make-let loc (make-values dynamic))))
all-syms (make-let loc
all-syms all-syms
vals all-syms
(with-lexical-bindings vals
(fluid-ref bindings-data) (with-lexical-bindings
(map car lexical) lexical-syms (fluid-ref bindings-data)
(lambda () (map car lexical) lexical-syms
(if (null? dynamic) (lambda ()
(make-body) (if (null? dynamic)
(let-dynamic loc (make-body)
(map car dynamic) (let-dynamic loc
module (map car dynamic)
(map module
(lambda (sym) (map
(make-lexical-ref loc (lambda (sym)
sym (make-lexical-ref loc
sym)) sym
dynamic-syms) sym))
(make-body))))))))))))) dynamic-syms)
(make-body))))))))))))))
;;; Let* is compiled to a cascaded set of "small lets" for each binding ;;; Let* is compiled to a cascaded set of "small lets" for each binding
;;; in turn so that each one already sees the preceding bindings. ;;; in turn so that each one already sees the preceding bindings.
(define (generate-let* loc module bindings body) (define (generate-let* loc module bindings body)
(let ((bind (process-let-bindings loc bindings))) (let ((bind (process-let-bindings loc bindings)))
(begin (receive (decls forms) (parse-body body)
(for-each (lambda (sym) (begin
(if (not (bind-lexically? sym module)) (for-each (lambda (sym)
(mark-global! (fluid-ref bindings-data) (if (not (bind-lexically? sym module))
sym (mark-global! (fluid-ref bindings-data)
module))) sym
(map car bind)) module)))
(let iterate ((tail bind)) (map car bind))
(if (null? tail) (let iterate ((tail bind))
(compile-expr `(progn ,@body)) (if (null? tail)
(let ((sym (caar tail)) (compile-expr `(progn ,@forms))
(value (compile-expr (cdar tail)))) (let ((sym (caar tail))
(if (bind-lexically? sym module) (value (compile-expr (cdar tail))))
(let ((target (gensym))) (if (bind-lexically? sym module)
(make-let loc (let ((target (gensym)))
`(,target) (make-let loc
`(,target) `(,target)
`(,value) `(,target)
(with-lexical-bindings `(,value)
(fluid-ref bindings-data) (with-lexical-bindings
`(,sym) (fluid-ref bindings-data)
`(,target) `(,sym)
(lambda () (iterate (cdr tail)))))) `(,target)
(let-dynamic loc (lambda () (iterate (cdr tail))))))
`(,(caar tail)) (let-dynamic loc
module `(,(caar tail))
`(,value) module
(iterate (cdr tail)))))))))) `(,value)
(iterate (cdr tail)))))))))))
;;; Partition the argument list of a lambda expression into required, ;;; Partition the argument list of a lambda expression into required,
;;; optional and rest arguments. ;;; optional and rest arguments.
@ -393,43 +431,47 @@
opt-ids opt-ids
(or (and=> rest-id list) '()))) (or (and=> rest-id list) '())))
(all-vars (map (lambda (ignore) (gensym)) all-ids))) (all-vars (map (lambda (ignore) (gensym)) all-ids)))
(receive (lexical dynamic) (let*-values (((decls intspec doc forms)
(partition (compose (cut bind-lexically? <> value-slot) car) (parse-lambda-body body))
(map list all-ids all-vars)) ((lexical dynamic)
(receive (lexical-ids lexical-vars) (unzip2 lexical) (partition
(receive (dynamic-ids dynamic-vars) (unzip2 dynamic) (compose (cut bind-lexically? <> value-slot)
(with-dynamic-bindings car)
(fluid-ref bindings-data) (map list all-ids all-vars)))
dynamic-ids ((lexical-ids lexical-vars) (unzip2 lexical))
(lambda () ((dynamic-ids dynamic-vars) (unzip2 dynamic)))
(with-lexical-bindings (with-dynamic-bindings
(fluid-ref bindings-data) (fluid-ref bindings-data)
lexical-ids dynamic-ids
lexical-vars (lambda ()
(lambda () (with-lexical-bindings
(let* ((tree-il (compile-expr `(progn ,@body))) (fluid-ref bindings-data)
(full-body lexical-ids
(if (null? dynamic) lexical-vars
tree-il (lambda ()
(let-dynamic loc (let* ((tree-il (compile-expr `(progn ,@forms)))
dynamic-ids (full-body
value-slot (if (null? dynamic)
(map (cut make-lexical-ref tree-il
loc (let-dynamic loc
<> dynamic-ids
<>) value-slot
dynamic-ids (map (cut make-lexical-ref
dynamic-vars) loc
tree-il)))) <>
(make-simple-lambda loc <>)
meta dynamic-ids
req-ids dynamic-vars)
opt-ids tree-il))))
(map (const (nil-value loc)) (make-simple-lambda loc
opt-ids) meta
rest-id req-ids
all-vars opt-ids
full-body)))))))))) (map (const (nil-value loc))
opt-ids)
rest-id
all-vars
full-body))))))))
(report-error "invalid function" `(lambda ,args ,@body))))) (report-error "invalid function" `(lambda ,args ,@body)))))
;;; Handle the common part of defconst and defvar, that is, checking for ;;; Handle the common part of defconst and defvar, that is, checking for