mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 05:50:26 +02:00
chi-top-sequence refactor
* 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
parent
f698b7286f
commit
45f584674a
1 changed files with 114 additions and 129 deletions
|
|
@ -910,135 +910,120 @@
|
|||
;;
|
||||
(define chi-top-sequence
|
||||
(lambda (body r w s m esew mod)
|
||||
(define (scan body r w s m esew mod exps)
|
||||
(cond
|
||||
((null? body)
|
||||
;; in reversed order
|
||||
exps)
|
||||
(else
|
||||
(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
|
||||
(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))))))))))
|
||||
(let* ((r (cons '("placeholder" . (placeholder)) r))
|
||||
(ribcage (make-empty-ribcage))
|
||||
(w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
|
||||
(define (record-definition! id label)
|
||||
(extend-ribcage! ribcage id label))
|
||||
(define (parse body r w s m esew mod)
|
||||
(let lp ((body body) (exps '()))
|
||||
(if (null? body)
|
||||
exps
|
||||
(lp (cdr body)
|
||||
(append (parse1 (car body) r w s m esew mod)
|
||||
exps)))))
|
||||
(define (parse1 x r w s m esew mod)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(syntax-type x r w (source-annotation x) ribcage mod #f))
|
||||
(lambda (type value e w s mod)
|
||||
(case type
|
||||
((define-form)
|
||||
(let* ((id (wrap value w mod))
|
||||
(label (gen-label))
|
||||
(var (syntax-object-expression id)))
|
||||
(record-definition! id var)
|
||||
(list
|
||||
(if (eq? m 'c&e)
|
||||
(let ((x (build-global-definition s var (chi e r w mod))))
|
||||
(top-level-eval-hook x mod)
|
||||
(lambda () x))
|
||||
(lambda ()
|
||||
(build-global-definition s var (chi e r w mod)))))))
|
||||
((define-syntax-form)
|
||||
(let* ((id (wrap value w mod))
|
||||
(label (gen-label))
|
||||
(var (syntax-object-expression id)))
|
||||
(record-definition! id var)
|
||||
(case m
|
||||
((c)
|
||||
(cond
|
||||
((memq 'compile esew)
|
||||
(let ((e (chi-install-global var (chi e r w mod))))
|
||||
(top-level-eval-hook e mod)
|
||||
(if (memq 'load esew)
|
||||
(list (lambda () e))
|
||||
'())))
|
||||
((memq 'load esew)
|
||||
(list (lambda ()
|
||||
(chi-install-global var (chi e r w mod)))))
|
||||
(else '())))
|
||||
((c&e)
|
||||
(let ((e (chi-install-global var (chi e r w mod))))
|
||||
(top-level-eval-hook e mod)
|
||||
(list (lambda () e))))
|
||||
(else
|
||||
(if (memq 'eval esew)
|
||||
(top-level-eval-hook
|
||||
(chi-install-global var (chi e r w mod))
|
||||
mod))
|
||||
'()))))
|
||||
((begin-form)
|
||||
(syntax-case e ()
|
||||
((_ e1 ...)
|
||||
(parse #'(e1 ...) r w s m esew mod))))
|
||||
((local-syntax-form)
|
||||
(chi-local-syntax value e r w s mod
|
||||
(lambda (forms r w s mod)
|
||||
(parse forms r w s m esew mod))))
|
||||
((eval-when-form)
|
||||
(syntax-case e ()
|
||||
((_ (x ...) e1 e2 ...)
|
||||
(let ((when-list (chi-when-list e #'(x ...) w))
|
||||
(body #'(e1 e2 ...)))
|
||||
(define (recurse m esew)
|
||||
(parse body r w s m esew mod))
|
||||
(cond
|
||||
((eq? m 'e)
|
||||
(if (memq 'eval when-list)
|
||||
(recurse (if (memq 'expand when-list) 'c&e 'e)
|
||||
'(eval))
|
||||
(begin
|
||||
(if (memq 'expand when-list)
|
||||
(top-level-eval-hook
|
||||
(chi-top-sequence body r w s 'e '(eval) mod)
|
||||
mod))
|
||||
'())))
|
||||
((memq 'load when-list)
|
||||
(if (or (memq 'compile when-list)
|
||||
(memq 'expand when-list)
|
||||
(and (eq? m 'c&e) (memq 'eval when-list)))
|
||||
(recurse 'c&e '(compile load))
|
||||
(if (memq m '(c c&e))
|
||||
(recurse 'c '(load))
|
||||
'())))
|
||||
((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)
|
||||
'())
|
||||
(else
|
||||
'()))))))
|
||||
(else
|
||||
(list
|
||||
(if (eq? m 'c&e)
|
||||
(let ((x (chi-expr type value e r w s mod)))
|
||||
(top-level-eval-hook x mod)
|
||||
(lambda () x))
|
||||
(lambda ()
|
||||
(chi-expr type value e r w s mod)))))))))
|
||||
(let ((exps (map (lambda (x) (x))
|
||||
(reverse (parse body r w s m esew mod)))))
|
||||
(if (null? exps)
|
||||
(build-void s)
|
||||
(build-sequence s exps))))))
|
||||
|
||||
(define chi-install-global
|
||||
(lambda (name e)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue