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.scm284
1 files changed, 163 insertions, 121 deletions
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index fa63fd657..17acf3ff9 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -278,10 +278,10 @@
;; hooks to nonportable run-time helpers
(begin
- (define fx+ +)
- (define fx- -)
- (define fx= =)
- (define fx< <)
+ (define-syntax fx+ (identifier-syntax +))
+ (define-syntax fx- (identifier-syntax -))
+ (define-syntax fx= (identifier-syntax =))
+ (define-syntax fx< (identifier-syntax <))
(define top-level-eval-hook
(lambda (x mod)
@@ -521,7 +521,7 @@
;; (define-syntax) define-syntax
;; (local-syntax . rec?) let-syntax/letrec-syntax
;; (eval-when) eval-when
- ;; #'. (<var> . <level>) pattern variables
+ ;; (syntax . (<var> . <level>)) pattern variables
;; (global) assumed global variable
;; (lexical . <var>) lexical variables
;; (displaced-lexical) displaced lexicals
@@ -897,16 +897,160 @@
(let ((first (chi (car body) r w mod)))
(cons first (dobody (cdr body) r w mod))))))))
+ ;; At top-level, we allow mixed definitions and expressions. Like
+ ;; chi-body we expand in two passes.
+ ;;
+ ;; First, from left to right, we expand just enough to know what
+ ;; expressions are definitions, syntax definitions, and splicing
+ ;; statements (`begin'). If we anything needs evaluating at
+ ;; expansion-time, it is expanded directly.
+ ;;
+ ;; Otherwise we collect expressions to expand, in thunks, and then
+ ;; expand them all at the end. This allows all syntax expanders
+ ;; visible in a toplevel sequence to be visible during the
+ ;; expansions of all normal definitions and expressions in the
+ ;; sequence.
+ ;;
(define chi-top-sequence
(lambda (body r w s m esew mod)
- (build-sequence s
- (let dobody ((body body) (r r) (w w) (m m) (esew esew)
- (mod mod) (out '()))
- (if (null? body)
- (reverse out)
- (dobody (cdr body) r w m esew mod
- (cons (chi-top (car body) r w m esew mod) out)))))))
-
+ (define (scan body r w s m esew mod exps)
+ (cond
+ ((null? body)
+ ;; 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))))))
+ (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)))))))))))
+
(define chi-install-global
(lambda (name e)
(build-global-definition
@@ -1054,109 +1198,6 @@
((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod)))))
- (define chi-top
- (lambda (e r w m esew mod)
- (define-syntax eval-if-c&e
- (syntax-rules ()
- ((_ m e mod)
- (let ((x e))
- (if (eq? m 'c&e) (top-level-eval-hook x mod))
- x))))
- (call-with-values
- (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
- (lambda (type value e w s mod)
- (case type
- ((begin-form)
- (syntax-case e ()
- ((_) (chi-void))
- ((_ e1 e2 ...)
- (chi-top-sequence #'(e1 e2 ...) r w s m esew mod))))
- ((local-syntax-form)
- (chi-local-syntax value e r w s mod
- (lambda (body r w s mod)
- (chi-top-sequence body 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 ...)))
- (cond
- ((eq? m 'e)
- (if (memq 'eval when-list)
- (chi-top-sequence body r w s
- (if (memq 'expand when-list) 'c&e 'e)
- '(eval)
- mod)
- (begin
- (if (memq 'expand when-list)
- (top-level-eval-hook
- (chi-top-sequence body r w s 'e '(eval) mod)
- mod))
- (chi-void))))
- ((memq 'load when-list)
- (if (or (memq 'compile when-list)
- (memq 'expand when-list)
- (and (eq? m 'c&e) (memq 'eval when-list)))
- (chi-top-sequence body r w s 'c&e '(compile load) mod)
- (if (memq m '(c c&e))
- (chi-top-sequence body r w s 'c '(load) mod)
- (chi-void))))
- ((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)
- (chi-void))
- (else (chi-void)))))))
- ((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) e (chi-void)))
- (if (memq 'load esew)
- (chi-install-global n (chi e r w mod))
- (chi-void))))
- ((c&e)
- (let ((e (chi-install-global n (chi e r w mod))))
- (top-level-eval-hook e mod)
- e))
- (else
- (if (memq 'eval esew)
- (top-level-eval-hook
- (chi-install-global n (chi e r w mod))
- mod))
- (chi-void)))))
- ((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)))))
- (eval-if-c&e m
- (build-global-definition s n (chi e r w mod))
- mod))
- ((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 (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
-
(define chi
(lambda (e r w mod)
(call-with-values
@@ -2375,8 +2416,8 @@
;; the object file if we are compiling a file.
(set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval)))
- (chi-top x null-env top-wrap m esew
- (cons 'hygiene (module-name (current-module))))))
+ (chi-top-sequence (list x) null-env top-wrap #f m esew
+ (cons 'hygiene (module-name (current-module))))))
(set! identifier?
(lambda (x)
@@ -2591,12 +2632,13 @@
(lambda (x)
(syntax-case x ()
((_ () e1 e2 ...)
- #'(begin e1 e2 ...))
+ #'(let () e1 e2 ...))
((_ ((out in)) e1 e2 ...)
- #'(syntax-case in () (out (begin e1 e2 ...))))
+ #'(syntax-case in ()
+ (out (let () e1 e2 ...))))
((_ ((out in) ...) e1 e2 ...)
#'(syntax-case (list in ...) ()
- ((out ...) (begin e1 e2 ...)))))))
+ ((out ...) (let () e1 e2 ...)))))))
(define-syntax syntax-rules
(lambda (x)