;;
(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)
HCoop / bpt / guile.git / commitdiff