mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

refactor chi-top-sequence

Browse source 
* module/ice-9/psyntax.scm (chi-top-sequence): Refactor slightly.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2011-10-28 12:14:00 +02:00
parent dd64fe65fd
commit 148dfc2409
2 changed files with 8926 additions and 8951 deletions
Download patch file Download diff file Expand all files Collapse all files

17625
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

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

@ -916,137 +916,129 @@
;; in reversed order
exps)
(else
(call-with-values
(lambda ()
(call-with-values
(lambda ()
(let ((e (car body)))
(syntax-type e r w (or (source-annotation e) s) #f mod #f)))
(lambda (type value e w s mod)
(case type
((begin-form)
(syntax-case e ()
((_) exps)
((_ e1 e2 ...)
(scan #'(e1 e2 ...) r w s m esew mod exps))))
((local-syntax-form)
(chi-local-syntax value e r w s mod
(lambda (body r w s mod)
(scan body r w s m esew mod exps))))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e #'(x ...) w))
(body #'(e1 e2 ...)))
(cond
((eq? m 'e)
(if (memq 'eval when-list)
(scan body r w s
(if (memq 'expand when-list) 'c&e 'e)
'(eval)
mod exps)
(begin
(if (memq 'expand when-list)
(top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod)
mod))
(values exps))))
((memq 'load when-list)
(if (or (memq 'compile when-list)
(memq 'expand when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(scan body r w s 'c&e '(compile load) mod exps)
(if (memq m '(c c&e))
(scan body r w s 'c '(load) mod exps)
(values exps))))
((or (memq 'compile when-list)
(memq 'expand when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod)
mod)
(values exps))
(else
(values exps)))))))
((define-syntax-form)
(let ((n (id-var-name value w)) (r (macros-only-env r)))
(case m
((c)
(if (memq 'compile esew)
(let ((e (chi-install-global n (chi e r w mod))))
(top-level-eval-hook e mod)
(if (memq 'load esew)
(values (cons e exps))
(values exps)))
(if (memq 'load esew)
(values (cons (chi-install-global n (chi e r w mod))
exps))
(values exps))))
((c&e)
(let ((e (chi-install-global n (chi e r w mod))))
(top-level-eval-hook e mod)
(values (cons e exps))))
(else
(if (memq 'eval esew)
(top-level-eval-hook
(chi-install-global n (chi e r w mod))
mod))
(values exps)))))
((define-form)
(let* ((n (id-var-name value w))
;; Lookup the name in the module of the define form.
(type (binding-type (lookup n r mod))))
(case type
((global core macro module-ref)
;; affect compile-time environment (once we have booted)
(if (and (memq m '(c c&e))
(not (module-local-variable (current-module) n))
(current-module))
(let ((old (module-variable (current-module) n)))
;; use value of the same-named imported variable, if
;; any
(if (and (variable? old) (variable-bound? old))
(module-define! (current-module) n (variable-ref old))
(module-add! (current-module) n (make-undefined-variable)))))
(values
(cons
(if (eq? m 'c&e)
(let ((x (build-global-definition s n (chi e r w mod))))
(top-level-eval-hook x mod)
x)
(lambda ()
(build-global-definition s n (chi e r w mod))))
exps)))
((displaced-lexical)
(syntax-violation #f "identifier out of context"
e (wrap value w mod)))
(else
(syntax-violation #f "cannot define keyword at top level"
e (wrap value w mod))))))
(scan
(cdr body) r w s m esew mod
(call-with-values
(lambda ()
(let ((e (car body)))
(syntax-type e r w (or (source-annotation e) s) #f mod #f)))
(lambda (type value e w s mod)
(case type
((begin-form)
(syntax-case e ()
((_) exps)
((_ e1 e2 ...)
(scan #'(e1 e2 ...) r w s m esew mod exps))))
((local-syntax-form)
(chi-local-syntax value e r w s mod
(lambda (body r w s mod)
(scan body r w s m esew mod exps))))
((eval-when-form)
(syntax-case e ()
((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e #'(x ...) w))
(body #'(e1 e2 ...)))
(cond
((eq? m 'e)
(if (memq 'eval when-list)
(scan body r w s
(if (memq 'expand when-list) 'c&e 'e)
'(eval)
mod exps)
(begin
(if (memq 'expand when-list)
(top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod)
mod))
exps)))
((memq 'load when-list)
(if (or (memq 'compile when-list)
(memq 'expand when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(scan body r w s 'c&e '(compile load) mod exps)
(if (memq m '(c c&e))
(scan body r w s 'c '(load) mod exps)
exps)))
((or (memq 'compile when-list)
(memq 'expand when-list)
(and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod)
mod)
exps)
(else
exps))))))
((define-syntax-form)
(let ((n (id-var-name value w)) (r (macros-only-env r)))
(case m
((c)
(if (memq 'compile esew)
(let ((e (chi-install-global n (chi e r w mod))))
(top-level-eval-hook e mod)
(if (memq 'load esew)
(cons e exps)
exps))
(if (memq 'load esew)
(cons (chi-install-global n (chi e r w mod))
exps)
exps)))
((c&e)
(let ((e (chi-install-global n (chi e r w mod))))
(top-level-eval-hook e mod)
(cons e exps)))
(else
(values (cons
(if (eq? m 'c&e)
(let ((x (chi-expr type value e r w s mod)))
(top-level-eval-hook x mod)
x)
(lambda ()
(chi-expr type value e r w s mod)))
exps)))))))
(lambda (exps)
(scan (cdr body) r w s m esew mod exps))))))
(call-with-values (lambda ()
(scan body r w s m esew mod '()))
(lambda (exps)
(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)))))))))))
(if (memq 'eval esew)
(top-level-eval-hook
(chi-install-global n (chi e r w mod))
mod))
exps))))
((define-form)
(let* ((n (id-var-name value w))
;; Lookup the name in the module of the define form.
(type (binding-type (lookup n r mod))))
(case type
((global core macro module-ref)
;; affect compile-time environment (once we have booted)
(if (and (memq m '(c c&e))
(not (module-local-variable (current-module) n))
(current-module))
(let ((old (module-variable (current-module) n)))
;; use value of the same-named imported variable, if
;; any
(if (and (variable? old) (variable-bound? old))
(module-define! (current-module) n (variable-ref old))
(module-add! (current-module) n (make-undefined-variable)))))
(cons (if (eq? m 'c&e)
(let ((x (build-global-definition s n (chi e r w mod))))
(top-level-eval-hook x mod)
x)
(lambda ()
(build-global-definition s n (chi e r w mod))))
exps))
((displaced-lexical)
(syntax-violation #f "identifier out of context"
e (wrap value w mod)))
(else
(syntax-violation #f "cannot define keyword at top level"
e (wrap value w mod))))))
(else
(cons (if (eq? m 'c&e)
(let ((x (chi-expr type value e r w s mod)))
(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
(lambda (name e)