summaryrefslogtreecommitdiff
path: root/module/ice-9/psyntax.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/psyntax.scm')
-rw-r--r--module/ice-9/psyntax.scm250
1 files changed, 121 insertions, 129 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 1717ba506..07bb0e4ed 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -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)
+ (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
- ((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))))))
+ ((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
- (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)))))))))))
+ (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)