From 45f584674ad9c29d6bc63f83cc3b05e7c81f1357 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2011 13:47:24 +0100 Subject: [PATCH] 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. --- module/ice-9/psyntax.scm | 243 ++++++++++++++++++--------------------- 1 file changed, 114 insertions(+), 129 deletions(-) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 4b02d6427..3b2951ff9 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -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)