+ (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)
+ (expand-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 (parse-when-list e #'(x ...)))
+ (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
+ (expand-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
+ (expand-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 (expand-install-global n (expand 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 (expand-install-global n (expand e r w mod))
+ exps))
+ (values exps))))
+ ((c&e)
+ (let ((e (expand-install-global n (expand e r w mod))))
+ (top-level-eval-hook e mod)
+ (values (cons e exps))))
+ (else
+ (if (memq 'eval esew)
+ (top-level-eval-hook
+ (expand-install-global n (expand 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 (expand e r w mod))))
+ (top-level-eval-hook x mod)
+ x)
+ (lambda ()
+ (build-global-definition s n (expand 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 (expand-expr type value e r w s mod)))
+ (top-level-eval-hook x mod)
+ x)
+ (lambda ()
+ (expand-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 expand-install-global