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

chi-top-sequence refactor

Browse source 
* module/ice-9/psyntax.scm (chi-top-sequence): Reimplement, more like
  chi-body.  Instead of adding empty definitions to the toplevel, add
  toplevel definitions to the wrap shared by all forms in the sequence.
This commit is contained in:
Andy Wingo 2011-11-04 13:47:24 +01:00
parent f698b7286f
commit 45f584674a
1 changed files with 114 additions and 129 deletions
Download patch file Download diff file Expand all files Collapse all files

243
module/ice-9/psyntax.scm
View file

@ -910,135 +910,120 @@
;; ;;
(define chi-top-sequence (define chi-top-sequence
(lambda (body r w s m esew mod) (lambda (body r w s m esew mod)
(define (scan body r w s m esew mod exps) (let* ((r (cons '("placeholder" . (placeholder)) r))
(cond (ribcage (make-empty-ribcage))
((null? body) (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
;; in reversed order (define (record-definition! id label)
exps) (extend-ribcage! ribcage id label))
(else (define (parse body r w s m esew mod)
(scan (let lp ((body body) (exps '()))
(cdr body) r w s m esew mod (if (null? body)
(call-with-values exps
(lambda () (lp (cdr body)
(let ((e (car body))) (append (parse1 (car body) r w s m esew mod)
(syntax-type e r w (or (source-annotation e) s) #f mod #f))) exps)))))
(lambda (type value e w s mod) (define (parse1 x r w s m esew mod)
(case type (call-with-values
((begin-form) (lambda ()
(syntax-case e () (syntax-type x r w (source-annotation x) ribcage mod #f))
((_) exps) (lambda (type value e w s mod)
((_ e1 e2 ...) (case type
(scan #'(e1 e2 ...) r w s m esew mod exps)))) ((define-form)
((local-syntax-form) (let* ((id (wrap value w mod))
(chi-local-syntax value e r w s mod (label (gen-label))
(lambda (body r w s mod) (var (syntax-object-expression id)))
(scan body r w s m esew mod exps)))) (record-definition! id var)
((eval-when-form) (list
(syntax-case e () (if (eq? m 'c&e)
((_ (x ...) e1 e2 ...) (let ((x (build-global-definition s var (chi e r w mod))))
(let ((when-list (chi-when-list e #'(x ...) w)) (top-level-eval-hook x mod)
(body #'(e1 e2 ...))) (lambda () x))
(cond (lambda ()
((eq? m 'e) (build-global-definition s var (chi e r w mod)))))))
(if (memq 'eval when-list) ((define-syntax-form)
(scan body r w s (let* ((id (wrap value w mod))
(if (memq 'expand when-list) 'c&e 'e) (label (gen-label))
'(eval) (var (syntax-object-expression id)))
mod exps) (record-definition! id var)
(begin (case m
(if (memq 'expand when-list) ((c)
(top-level-eval-hook (cond
(chi-top-sequence body r w s 'e '(eval) mod) ((memq 'compile esew)
mod)) (let ((e (chi-install-global var (chi e r w mod))))
exps))) (top-level-eval-hook e mod)
((memq 'load when-list) (if (memq 'load esew)
(if (or (memq 'compile when-list) (list (lambda () e))
(memq 'expand when-list) '())))
(and (eq? m 'c&e) (memq 'eval when-list))) ((memq 'load esew)
(scan body r w s 'c&e '(compile load) mod exps) (list (lambda ()
(if (memq m '(c c&e)) (chi-install-global var (chi e r w mod)))))
(scan body r w s 'c '(load) mod exps) (else '())))
exps))) ((c&e)
((or (memq 'compile when-list) (let ((e (chi-install-global var (chi e r w mod))))
(memq 'expand when-list) (top-level-eval-hook e mod)
(and (eq? m 'c&e) (memq 'eval when-list))) (list (lambda () e))))
(top-level-eval-hook (else
(chi-top-sequence body r w s 'e '(eval) mod) (if (memq 'eval esew)
mod) (top-level-eval-hook
exps) (chi-install-global var (chi e r w mod))
(else mod))
exps)))))) '()))))
((define-syntax-form) ((begin-form)
(let ((n (id-var-name value w)) (r (macros-only-env r))) (syntax-case e ()
(case m ((_ e1 ...)
((c) (parse #'(e1 ...) r w s m esew mod))))
(if (memq 'compile esew) ((local-syntax-form)
(let ((e (chi-install-global n (chi e r w mod)))) (chi-local-syntax value e r w s mod
(top-level-eval-hook e mod) (lambda (forms r w s mod)
(if (memq 'load esew) (parse forms r w s m esew mod))))
(cons e exps) ((eval-when-form)
exps)) (syntax-case e ()
(if (memq 'load esew) ((_ (x ...) e1 e2 ...)
(cons (chi-install-global n (chi e r w mod)) (let ((when-list (chi-when-list e #'(x ...) w))
exps) (body #'(e1 e2 ...)))
exps))) (define (recurse m esew)
((c&e) (parse body r w s m esew mod))
(let ((e (chi-install-global n (chi e r w mod)))) (cond
(top-level-eval-hook e mod) ((eq? m 'e)
(cons e exps))) (if (memq 'eval when-list)
(else (recurse (if (memq 'expand when-list) 'c&e 'e)
(if (memq 'eval esew) '(eval))
(top-level-eval-hook (begin
(chi-install-global n (chi e r w mod)) (if (memq 'expand when-list)
mod)) (top-level-eval-hook
exps)))) (chi-top-sequence body r w s 'e '(eval) mod)
((define-form) mod))
(let* ((n (id-var-name value w)) '())))
;; Lookup the name in the module of the define form. ((memq 'load when-list)
(type (binding-type (lookup n r mod)))) (if (or (memq 'compile when-list)
(case type (memq 'expand when-list)
((global core macro module-ref) (and (eq? m 'c&e) (memq 'eval when-list)))
;; affect compile-time environment (once we have booted) (recurse 'c&e '(compile load))
(if (and (memq m '(c c&e)) (if (memq m '(c c&e))
(not (module-local-variable (current-module) n)) (recurse 'c '(load))
(current-module)) '())))
(let ((old (module-variable (current-module) n))) ((or (memq 'compile when-list)
;; use value of the same-named imported variable, if (memq 'expand when-list)
;; any (and (eq? m 'c&e) (memq 'eval when-list)))
(if (and (variable? old) (variable-bound? old)) (top-level-eval-hook
(module-define! (current-module) n (variable-ref old)) (chi-top-sequence body r w s 'e '(eval) mod)
(module-add! (current-module) n (make-undefined-variable))))) mod)
(cons (if (eq? m 'c&e) '())
(let ((x (build-global-definition s n (chi e r w mod)))) (else
(top-level-eval-hook x mod) '()))))))
x) (else
(lambda () (list
(build-global-definition s n (chi e r w mod)))) (if (eq? m 'c&e)
exps)) (let ((x (chi-expr type value e r w s mod)))
((displaced-lexical) (top-level-eval-hook x mod)
(syntax-violation #f "identifier out of context" (lambda () x))
e (wrap value w mod))) (lambda ()
(else (chi-expr type value e r w s mod)))))))))
(syntax-violation #f "cannot define keyword at top level" (let ((exps (map (lambda (x) (x))
e (wrap value w mod)))))) (reverse (parse body r w s m esew mod)))))
(else (if (null? exps)
(cons (if (eq? m 'c&e) (build-void s)
(let ((x (chi-expr type value e r w s mod))) (build-sequence s exps))))))
(top-level-eval-hook x mod)
x)
(lambda ()
(chi-expr type value e r w s mod)))
exps)))))))))
(let ((exps (scan body r w s m esew mod '())))
(if (null? exps)
(build-void s)
(build-sequence
s
(let lp ((in exps) (out '()))
(if (null? in) out
(let ((e (car in)))
(lp (cdr in)
(cons (if (procedure? e) (e) e) out))))))))))
(define chi-install-global (define chi-install-global
(lambda (name e) (lambda (name e)