mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00
Code Activity

psyntax: s/chi/expand/g

Browse source 
* module/ice-9/psyntax.scm: Rename all instances of "chi" to "expand".
  Addded a hack to expand-eval-when that will be fixed later.
* module/ice-9/psyntax-pp.scm: Regenerated.
This commit is contained in:
Andy Wingo 2011-11-16 20:08:40 +01:00
parent 46e0923d35
commit 78a474558a
2 changed files with 6855 additions and 18800 deletions
Download patch file Download diff file Expand all files Collapse all files

25315
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

340
module/ice-9/psyntax.scm
View file

@ -857,17 +857,17 @@
;; expanding ;; expanding
(define chi-sequence (define expand-sequence
(lambda (body r w s mod) (lambda (body r w s mod)
(build-sequence s (build-sequence s
(let dobody ((body body) (r r) (w w) (mod mod)) (let dobody ((body body) (r r) (w w) (mod mod))
(if (null? body) (if (null? body)
'() '()
(let ((first (chi (car body) r w mod))) (let ((first (expand (car body) r w mod)))
(cons first (dobody (cdr body) r w mod)))))))) (cons first (dobody (cdr body) r w mod))))))))
;; At top-level, we allow mixed definitions and expressions. Like ;; At top-level, we allow mixed definitions and expressions. Like
;; chi-body we expand in two passes. ;; expand-body we expand in two passes.
;; ;;
;; First, from left to right, we expand just enough to know what ;; First, from left to right, we expand just enough to know what
;; expressions are definitions, syntax definitions, and splicing ;; expressions are definitions, syntax definitions, and splicing
@ -880,7 +880,7 @@
;; expansions of all normal definitions and expressions in the ;; expansions of all normal definitions and expressions in the
;; sequence. ;; sequence.
;; ;;
(define chi-top-sequence (define expand-top-sequence
(lambda (body r w s m esew mod) (lambda (body r w s m esew mod)
(define (scan body r w s m esew mod exps) (define (scan body r w s m esew mod exps)
(cond (cond
@ -902,13 +902,13 @@
((_ e1 e2 ...) ((_ e1 e2 ...)
(scan #'(e1 e2 ...) r w s m esew mod exps)))) (scan #'(e1 e2 ...) r w s m esew mod exps))))
((local-syntax-form) ((local-syntax-form)
(chi-local-syntax value e r w s mod (expand-local-syntax value e r w s mod
(lambda (body r w s mod) (lambda (body r w s mod)
(scan body r w s m esew mod exps)))) (scan body r w s m esew mod exps))))
((eval-when-form) ((eval-when-form)
(syntax-case e () (syntax-case e ()
((_ (x ...) e1 e2 ...) ((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e #'(x ...) w)) (let ((when-list (expand-when-list e #'(x ...) w))
(body #'(e1 e2 ...))) (body #'(e1 e2 ...)))
(cond (cond
((eq? m 'e) ((eq? m 'e)
@ -920,7 +920,7 @@
(begin (begin
(if (memq 'expand when-list) (if (memq 'expand when-list)
(top-level-eval-hook (top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod) (expand-top-sequence body r w s 'e '(eval) mod)
mod)) mod))
(values exps)))) (values exps))))
((memq 'load when-list) ((memq 'load when-list)
@ -935,7 +935,7 @@
(memq 'expand when-list) (memq 'expand when-list)
(and (eq? m 'c&e) (memq 'eval when-list))) (and (eq? m 'c&e) (memq 'eval when-list)))
(top-level-eval-hook (top-level-eval-hook
(chi-top-sequence body r w s 'e '(eval) mod) (expand-top-sequence body r w s 'e '(eval) mod)
mod) mod)
(values exps)) (values exps))
(else (else
@ -945,23 +945,23 @@
(case m (case m
((c) ((c)
(if (memq 'compile esew) (if (memq 'compile esew)
(let ((e (chi-install-global n (chi e r w mod)))) (let ((e (expand-install-global n (expand e r w mod))))
(top-level-eval-hook e mod) (top-level-eval-hook e mod)
(if (memq 'load esew) (if (memq 'load esew)
(values (cons e exps)) (values (cons e exps))
(values exps))) (values exps)))
(if (memq 'load esew) (if (memq 'load esew)
(values (cons (chi-install-global n (chi e r w mod)) (values (cons (expand-install-global n (expand e r w mod))
exps)) exps))
(values exps)))) (values exps))))
((c&e) ((c&e)
(let ((e (chi-install-global n (chi e r w mod)))) (let ((e (expand-install-global n (expand e r w mod))))
(top-level-eval-hook e mod) (top-level-eval-hook e mod)
(values (cons e exps)))) (values (cons e exps))))
(else (else
(if (memq 'eval esew) (if (memq 'eval esew)
(top-level-eval-hook (top-level-eval-hook
(chi-install-global n (chi e r w mod)) (expand-install-global n (expand e r w mod))
mod)) mod))
(values exps))))) (values exps)))))
((define-form) ((define-form)
@ -983,11 +983,11 @@
(values (values
(cons (cons
(if (eq? m 'c&e) (if (eq? m 'c&e)
(let ((x (build-global-definition s n (chi e r w mod)))) (let ((x (build-global-definition s n (expand e r w mod))))
(top-level-eval-hook x mod) (top-level-eval-hook x mod)
x) x)
(lambda () (lambda ()
(build-global-definition s n (chi e r w mod)))) (build-global-definition s n (expand e r w mod))))
exps))) exps)))
((displaced-lexical) ((displaced-lexical)
(syntax-violation #f "identifier out of context" (syntax-violation #f "identifier out of context"
@ -998,11 +998,11 @@
(else (else
(values (cons (values (cons
(if (eq? m 'c&e) (if (eq? m 'c&e)
(let ((x (chi-expr type value e r w s mod))) (let ((x (expand-expr type value e r w s mod)))
(top-level-eval-hook x mod) (top-level-eval-hook x mod)
x) x)
(lambda () (lambda ()
(chi-expr type value e r w s mod))) (expand-expr type value e r w s mod)))
exps))))))) exps)))))))
(lambda (exps) (lambda (exps)
(scan (cdr body) r w s m esew mod exps)))))) (scan (cdr body) r w s m esew mod exps))))))
@ -1020,7 +1020,7 @@
(lp (cdr in) (lp (cdr in)
(cons (if (procedure? e) (e) e) out))))))))))) (cons (if (procedure? e) (e) e) out)))))))))))
(define chi-install-global (define expand-install-global
(lambda (name e) (lambda (name e)
(build-global-definition (build-global-definition
no-source no-source
@ -1032,7 +1032,7 @@
(build-data no-source 'macro) (build-data no-source 'macro)
e))))) e)))))
(define chi-when-list (define expand-when-list
(lambda (e when-list w) (lambda (e when-list w)
;; when-list is syntax'd version of list of situations ;; when-list is syntax'd version of list of situations
(let f ((when-list when-list) (situations '())) (let f ((when-list when-list) (situations '()))
@ -1044,7 +1044,7 @@
((free-id=? x #'compile) 'compile) ((free-id=? x #'compile) 'compile)
((free-id=? x #'load) 'load) ((free-id=? x #'load) 'load)
((free-id=? x #'eval) 'eval) ((free-id=? x #'eval) 'eval)
((free-id=? x #'expand) 'expand) ((eq? (syntax->datum x) 'expand) 'expand)
(else (syntax-violation 'eval-when (else (syntax-violation 'eval-when
"invalid situation" "invalid situation"
e (wrap x w #f))))) e (wrap x w #f)))))
@ -1099,7 +1099,7 @@
((macro) ((macro)
(if for-car? (if for-car?
(values type (binding-value b) e w s mod) (values type (binding-value b) e w s mod)
(syntax-type (chi-macro (binding-value b) e r w s rib mod) (syntax-type (expand-macro (binding-value b) e r w s rib mod)
r empty-wrap s rib mod #f))) r empty-wrap s rib mod #f)))
(else (values type (binding-value b) e w s mod))))) (else (values type (binding-value b) e w s mod)))))
((pair? e) ((pair? e)
@ -1117,7 +1117,7 @@
(values 'global-call (make-syntax-object fval w fmod) (values 'global-call (make-syntax-object fval w fmod)
e w s mod)) e w s mod))
((macro) ((macro)
(syntax-type (chi-macro fval e r w s rib mod) (syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?)) r empty-wrap s rib mod for-car?))
((module-ref) ((module-ref)
(call-with-values (lambda () (fval e r w)) (call-with-values (lambda () (fval e r w))
@ -1167,14 +1167,14 @@
((self-evaluating? e) (values 'constant #f e w s mod)) ((self-evaluating? e) (values 'constant #f e w s mod))
(else (values 'other #f e w s mod))))) (else (values 'other #f e w s mod)))))
(define chi (define expand
(lambda (e r w mod) (lambda (e r w mod)
(call-with-values (call-with-values
(lambda () (syntax-type e r w (source-annotation e) #f mod #f)) (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
(lambda (type value e w s mod) (lambda (type value e w s mod)
(chi-expr type value e r w s mod))))) (expand-expr type value e r w s mod)))))
(define chi-expr (define expand-expr
(lambda (type value e r w s mod) (lambda (type value e r w s mod)
(case type (case type
((lexical) ((lexical)
@ -1185,9 +1185,9 @@
((module-ref) ((module-ref)
(call-with-values (lambda () (value e r w)) (call-with-values (lambda () (value e r w))
(lambda (e r w s mod) (lambda (e r w s mod)
(chi e r w mod)))) (expand e r w mod))))
((lexical-call) ((lexical-call)
(chi-application (expand-application
(let ((id (car e))) (let ((id (car e)))
(build-lexical-reference 'fun (source-annotation id) (build-lexical-reference 'fun (source-annotation id)
(if (syntax-object? id) (if (syntax-object? id)
@ -1196,7 +1196,7 @@
value)) value))
e r w s mod)) e r w s mod))
((global-call) ((global-call)
(chi-application (expand-application
(build-global-reference (source-annotation (car e)) (build-global-reference (source-annotation (car e))
(if (syntax-object? value) (if (syntax-object? value)
(syntax-object-expression value) (syntax-object-expression value)
@ -1207,19 +1207,19 @@
e r w s mod)) e r w s mod))
((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod)) ((global) (build-global-reference s value mod))
((call) (chi-application (chi (car e) r w mod) e r w s mod)) ((call) (expand-application (expand (car e) r w mod) e r w s mod))
((begin-form) ((begin-form)
(syntax-case e () (syntax-case e ()
((_ e1 e2 ...) (chi-sequence #'(e1 e2 ...) r w s mod)))) ((_ e1 e2 ...) (expand-sequence #'(e1 e2 ...) r w s mod))))
((local-syntax-form) ((local-syntax-form)
(chi-local-syntax value e r w s mod chi-sequence)) (expand-local-syntax value e r w s mod expand-sequence))
((eval-when-form) ((eval-when-form)
(syntax-case e () (syntax-case e ()
((_ (x ...) e1 e2 ...) ((_ (x ...) e1 e2 ...)
(let ((when-list (chi-when-list e #'(x ...) w))) (let ((when-list (expand-when-list e #'(x ...) w)))
(if (memq 'eval when-list) (if (memq 'eval when-list)
(chi-sequence #'(e1 e2 ...) r w s mod) (expand-sequence #'(e1 e2 ...) r w s mod)
(chi-void)))))) (expand-void))))))
((define-form define-syntax-form) ((define-form define-syntax-form)
(syntax-violation #f "definition in expression context" (syntax-violation #f "definition in expression context"
e (wrap value w mod))) e (wrap value w mod)))
@ -1232,12 +1232,12 @@
(else (syntax-violation #f "unexpected syntax" (else (syntax-violation #f "unexpected syntax"
(source-wrap e w s mod)))))) (source-wrap e w s mod))))))
(define chi-application (define expand-application
(lambda (x e r w s mod) (lambda (x e r w s mod)
(syntax-case e () (syntax-case e ()
((e0 e1 ...) ((e0 e1 ...)
(build-application s x (build-application s x
(map (lambda (e) (chi e r w mod)) #'(e1 ...))))))) (map (lambda (e) (expand e r w mod)) #'(e1 ...)))))))
;; (What follows is my interpretation of what's going on here -- Andy) ;; (What follows is my interpretation of what's going on here -- Andy)
;; ;;
@ -1272,7 +1272,7 @@
;; really nice if we could also annotate introduced expressions with the ;; really nice if we could also annotate introduced expressions with the
;; locations corresponding to the macro definition, but that is not yet ;; locations corresponding to the macro definition, but that is not yet
;; possible. ;; possible.
(define chi-macro (define expand-macro
(lambda (p e r w s rib mod) (lambda (p e r w s rib mod)
(define rebuild-macro-output (define rebuild-macro-output
(lambda (x m) (lambda (x m)
@ -1313,7 +1313,7 @@
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
(new-mark)))) (new-mark))))
(define chi-body (define expand-body
;; In processing the forms of the body, we create a new, empty wrap. ;; In processing the forms of the body, we create a new, empty wrap.
;; This wrap is augmented (destructively) each time we discover that ;; This wrap is augmented (destructively) each time we discover that
;; the next form is a definition. This is done: ;; the next form is a definition. This is done:
@ -1393,19 +1393,19 @@
(f (cdr forms))))) (f (cdr forms)))))
ids labels var-ids vars vals bindings)))) ids labels var-ids vars vals bindings))))
((local-syntax-form) ((local-syntax-form)
(chi-local-syntax value e er w s mod (expand-local-syntax value e er w s mod
(lambda (forms er w s mod) (lambda (forms er w s mod)
(parse (let f ((forms forms)) (parse (let f ((forms forms))
(if (null? forms) (if (null? forms)
(cdr body) (cdr body)
(cons (cons er (wrap (car forms) w mod)) (cons (cons er (wrap (car forms) w mod))
(f (cdr forms))))) (f (cdr forms)))))
ids labels var-ids vars vals bindings)))) ids labels var-ids vars vals bindings))))
(else ; found a non-definition (else ; found a non-definition
(if (null? ids) (if (null? ids)
(build-sequence no-source (build-sequence no-source
(map (lambda (x) (map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod)) (expand (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s mod)) (cons (cons er (source-wrap e w s mod))
(cdr body)))) (cdr body))))
(begin (begin
@ -1424,7 +1424,7 @@
(macros-only-env er)))) (macros-only-env er))))
(set-cdr! b (set-cdr! b
(eval-local-transformer (eval-local-transformer
(chi (cddr b) r-cache empty-wrap mod) (expand (cddr b) r-cache empty-wrap mod)
mod)) mod))
(loop (cdr bs) er r-cache)) (loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache))))) (loop (cdr bs) er-cache r-cache)))))
@ -1433,15 +1433,15 @@
(reverse (map syntax->datum var-ids)) (reverse (map syntax->datum var-ids))
(reverse vars) (reverse vars)
(map (lambda (x) (map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod)) (expand (cdr x) (car x) empty-wrap mod))
(reverse vals)) (reverse vals))
(build-sequence no-source (build-sequence no-source
(map (lambda (x) (map (lambda (x)
(chi (cdr x) (car x) empty-wrap mod)) (expand (cdr x) (car x) empty-wrap mod))
(cons (cons er (source-wrap e w s mod)) (cons (cons er (source-wrap e w s mod))
(cdr body))))))))))))))))) (cdr body)))))))))))))))))
(define chi-local-syntax (define expand-local-syntax
(lambda (rec? e r w s mod k) (lambda (rec? e r w s mod k)
(syntax-case e () (syntax-case e ()
((_ ((id val) ...) e1 e2 ...) ((_ ((id val) ...) e1 e2 ...)
@ -1458,7 +1458,7 @@
(map (lambda (x) (map (lambda (x)
(make-binding 'macro (make-binding 'macro
(eval-local-transformer (eval-local-transformer
(chi x trans-r w mod) (expand x trans-r w mod)
mod))) mod)))
#'(val ...))) #'(val ...)))
r) r)
@ -1475,7 +1475,7 @@
p p
(syntax-violation #f "nonprocedure transformer" p))))) (syntax-violation #f "nonprocedure transformer" p)))))
(define chi-void (define expand-void
(lambda () (lambda ()
(build-void no-source))) (build-void no-source)))
@ -1505,7 +1505,7 @@
orig-args)))) orig-args))))
(req orig-args '()))) (req orig-args '())))
(define chi-simple-lambda (define expand-simple-lambda
(lambda (e r w s mod req rest meta body) (lambda (e r w s mod req rest meta body)
(let* ((ids (if rest (append req (list rest)) req)) (let* ((ids (if rest (append req (list rest)) req))
(vars (map gen-var ids)) (vars (map gen-var ids))
@ -1514,10 +1514,10 @@
s s
(map syntax->datum req) (and rest (syntax->datum rest)) vars (map syntax->datum req) (and rest (syntax->datum rest)) vars
meta meta
(chi-body body (source-wrap e w s mod) (expand-body body (source-wrap e w s mod)
(extend-var-env labels vars r) (extend-var-env labels vars r)
(make-binding-wrap ids labels w) (make-binding-wrap ids labels w)
mod))))) mod)))))
(define lambda*-formals (define lambda*-formals
(lambda (orig-args) (lambda (orig-args)
@ -1600,16 +1600,16 @@
orig-args)))) orig-args))))
(req orig-args '()))) (req orig-args '())))
(define chi-lambda-case (define expand-lambda-case
(lambda (e r w s mod get-formals clauses) (lambda (e r w s mod get-formals clauses)
(define (expand-req req opt rest kw body) (define (parse-req req opt rest kw body)
(let ((vars (map gen-var req)) (let ((vars (map gen-var req))
(labels (gen-labels req))) (labels (gen-labels req)))
(let ((r* (extend-var-env labels vars r)) (let ((r* (extend-var-env labels vars r))
(w* (make-binding-wrap req labels w))) (w* (make-binding-wrap req labels w)))
(expand-opt (map syntax->datum req) (parse-opt (map syntax->datum req)
opt rest kw body (reverse vars) r* w* '() '())))) opt rest kw body (reverse vars) r* w* '() '()))))
(define (expand-opt req opt rest kw body vars r* w* out inits) (define (parse-opt req opt rest kw body vars r* w* out inits)
(cond (cond
((pair? opt) ((pair? opt)
(syntax-case (car opt) () (syntax-case (car opt) ()
@ -1618,27 +1618,27 @@
(l (gen-labels (list v))) (l (gen-labels (list v)))
(r** (extend-var-env l (list v) r*)) (r** (extend-var-env l (list v) r*))
(w** (make-binding-wrap (list #'id) l w*))) (w** (make-binding-wrap (list #'id) l w*)))
(expand-opt req (cdr opt) rest kw body (cons v vars) (parse-opt req (cdr opt) rest kw body (cons v vars)
r** w** (cons (syntax->datum #'id) out) r** w** (cons (syntax->datum #'id) out)
(cons (chi #'i r* w* mod) inits)))))) (cons (expand #'i r* w* mod) inits))))))
(rest (rest
(let* ((v (gen-var rest)) (let* ((v (gen-var rest))
(l (gen-labels (list v))) (l (gen-labels (list v)))
(r* (extend-var-env l (list v) r*)) (r* (extend-var-env l (list v) r*))
(w* (make-binding-wrap (list rest) l w*))) (w* (make-binding-wrap (list rest) l w*)))
(expand-kw req (if (pair? out) (reverse out) #f) (parse-kw req (if (pair? out) (reverse out) #f)
(syntax->datum rest) (syntax->datum rest)
(if (pair? kw) (cdr kw) kw) (if (pair? kw) (cdr kw) kw)
body (cons v vars) r* w* body (cons v vars) r* w*
(if (pair? kw) (car kw) #f) (if (pair? kw) (car kw) #f)
'() inits))) '() inits)))
(else (else
(expand-kw req (if (pair? out) (reverse out) #f) #f (parse-kw req (if (pair? out) (reverse out) #f) #f
(if (pair? kw) (cdr kw) kw) (if (pair? kw) (cdr kw) kw)
body vars r* w* body vars r* w*
(if (pair? kw) (car kw) #f) (if (pair? kw) (car kw) #f)
'() inits)))) '() inits))))
(define (expand-kw req opt rest kw body vars r* w* aok out inits) (define (parse-kw req opt rest kw body vars r* w* aok out inits)
(cond (cond
((pair? kw) ((pair? kw)
(syntax-case (car kw) () (syntax-case (car kw) ()
@ -1647,31 +1647,31 @@
(l (gen-labels (list v))) (l (gen-labels (list v)))
(r** (extend-var-env l (list v) r*)) (r** (extend-var-env l (list v) r*))
(w** (make-binding-wrap (list #'id) l w*))) (w** (make-binding-wrap (list #'id) l w*)))
(expand-kw req opt rest (cdr kw) body (cons v vars) (parse-kw req opt rest (cdr kw) body (cons v vars)
r** w** aok r** w** aok
(cons (list (syntax->datum #'k) (cons (list (syntax->datum #'k)
(syntax->datum #'id) (syntax->datum #'id)
v) v)
out) out)
(cons (chi #'i r* w* mod) inits)))))) (cons (expand #'i r* w* mod) inits))))))
(else (else
(expand-body req opt rest (parse-body req opt rest
(if (or aok (pair? out)) (cons aok (reverse out)) #f) (if (or aok (pair? out)) (cons aok (reverse out)) #f)
body (reverse vars) r* w* (reverse inits) '())))) body (reverse vars) r* w* (reverse inits) '()))))
(define (expand-body req opt rest kw body vars r* w* inits meta) (define (parse-body req opt rest kw body vars r* w* inits meta)
(syntax-case body () (syntax-case body ()
((docstring e1 e2 ...) (string? (syntax->datum #'docstring)) ((docstring e1 e2 ...) (string? (syntax->datum #'docstring))
(expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
(append meta (append meta
`((documentation `((documentation
. ,(syntax->datum #'docstring)))))) . ,(syntax->datum #'docstring))))))
((#((k . v) ...) e1 e2 ...) ((#((k . v) ...) e1 e2 ...)
(expand-body req opt rest kw #'(e1 e2 ...) vars r* w* inits (parse-body req opt rest kw #'(e1 e2 ...) vars r* w* inits
(append meta (syntax->datum #'((k . v) ...))))) (append meta (syntax->datum #'((k . v) ...)))))
((e1 e2 ...) ((e1 e2 ...)
(values meta req opt rest kw inits vars (values meta req opt rest kw inits vars
(chi-body #'(e1 e2 ...) (source-wrap e w s mod) (expand-body #'(e1 e2 ...) (source-wrap e w s mod)
r* w* mod))))) r* w* mod)))))
(syntax-case clauses () (syntax-case clauses ()
(() (values '() #f)) (() (values '() #f))
@ -1679,12 +1679,12 @@
(call-with-values (lambda () (get-formals #'args)) (call-with-values (lambda () (get-formals #'args))
(lambda (req opt rest kw) (lambda (req opt rest kw)
(call-with-values (lambda () (call-with-values (lambda ()
(expand-req req opt rest kw #'(e1 e2 ...))) (parse-req req opt rest kw #'(e1 e2 ...)))
(lambda (meta req opt rest kw inits vars body) (lambda (meta req opt rest kw inits vars body)
(call-with-values (call-with-values
(lambda () (lambda ()
(chi-lambda-case e r w s mod get-formals (expand-lambda-case e r w s mod get-formals
#'((args* e1* e2* ...) ...))) #'((args* e1* e2* ...) ...)))
(lambda (meta* else*) (lambda (meta* else*)
(values (values
(append meta meta*) (append meta meta*)
@ -1768,7 +1768,7 @@
(source-wrap id w s mod))))) (source-wrap id w s mod)))))
#'(var ...) #'(var ...)
names) names)
(chi-body (expand-body
#'(e1 e2 ...) #'(e1 e2 ...)
(source-wrap e w s mod) (source-wrap e w s mod)
(extend-env (extend-env
@ -1776,7 +1776,7 @@
(let ((trans-r (macros-only-env r))) (let ((trans-r (macros-only-env r)))
(map (lambda (x) (map (lambda (x)
(make-binding 'macro (make-binding 'macro
(eval-local-transformer (chi x trans-r w mod) (eval-local-transformer (expand x trans-r w mod)
mod))) mod)))
#'(val ...))) #'(val ...)))
r) r)
@ -1970,7 +1970,7 @@
((#((k . v) ...) e1 e2 ...) ((#((k . v) ...) e1 e2 ...)
(lp #'(e1 e2 ...) (lp #'(e1 e2 ...)
(append meta (syntax->datum #'((k . v) ...))))) (append meta (syntax->datum #'((k . v) ...)))))
(_ (chi-simple-lambda e r w s mod req rest meta body))))))) (_ (expand-simple-lambda e r w s mod req rest meta body)))))))
(_ (syntax-violation 'lambda "bad lambda" e))))) (_ (syntax-violation 'lambda "bad lambda" e)))))
(global-extend 'core 'lambda* (global-extend 'core 'lambda*
@ -1979,8 +1979,8 @@
((_ args e1 e2 ...) ((_ args e1 e2 ...)
(call-with-values (call-with-values
(lambda () (lambda ()
(chi-lambda-case e r w s mod (expand-lambda-case e r w s mod
lambda*-formals #'((args e1 e2 ...)))) lambda*-formals #'((args e1 e2 ...))))
(lambda (meta lcase) (lambda (meta lcase)
(build-case-lambda s meta lcase)))) (build-case-lambda s meta lcase))))
(_ (syntax-violation 'lambda "bad lambda*" e))))) (_ (syntax-violation 'lambda "bad lambda*" e)))))
@ -1991,9 +1991,9 @@
((_ (args e1 e2 ...) (args* e1* e2* ...) ...) ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values (call-with-values
(lambda () (lambda ()
(chi-lambda-case e r w s mod (expand-lambda-case e r w s mod
lambda-formals lambda-formals
#'((args e1 e2 ...) (args* e1* e2* ...) ...))) #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(lambda (meta lcase) (lambda (meta lcase)
(build-case-lambda s meta lcase)))) (build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda" e))))) (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
@ -2004,16 +2004,16 @@
((_ (args e1 e2 ...) (args* e1* e2* ...) ...) ((_ (args e1 e2 ...) (args* e1* e2* ...) ...)
(call-with-values (call-with-values
(lambda () (lambda ()
(chi-lambda-case e r w s mod (expand-lambda-case e r w s mod
lambda*-formals lambda*-formals
#'((args e1 e2 ...) (args* e1* e2* ...) ...))) #'((args e1 e2 ...) (args* e1* e2* ...) ...)))
(lambda (meta lcase) (lambda (meta lcase)
(build-case-lambda s meta lcase)))) (build-case-lambda s meta lcase))))
(_ (syntax-violation 'case-lambda "bad case-lambda*" e))))) (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
(global-extend 'core 'let (global-extend 'core 'let
(let () (let ()
(define (chi-let e r w s mod constructor ids vals exps) (define (expand-let e r w s mod constructor ids vals exps)
(if (not (valid-bound-ids? ids)) (if (not (valid-bound-ids? ids))
(syntax-violation 'let "duplicate bound variable" e) (syntax-violation 'let "duplicate bound variable" e)
(let ((labels (gen-labels ids)) (let ((labels (gen-labels ids))
@ -2023,25 +2023,25 @@
(constructor s (constructor s
(map syntax->datum ids) (map syntax->datum ids)
new-vars new-vars
(map (lambda (x) (chi x r w mod)) vals) (map (lambda (x) (expand x r w mod)) vals)
(chi-body exps (source-wrap e nw s mod) (expand-body exps (source-wrap e nw s mod)
nr nw mod)))))) nr nw mod))))))
(lambda (e r w s mod) (lambda (e r w s mod)
(syntax-case e () (syntax-case e ()
((_ ((id val) ...) e1 e2 ...) ((_ ((id val) ...) e1 e2 ...)
(and-map id? #'(id ...)) (and-map id? #'(id ...))
(chi-let e r w s mod (expand-let e r w s mod
build-let build-let
#'(id ...) #'(id ...)
#'(val ...) #'(val ...)
#'(e1 e2 ...))) #'(e1 e2 ...)))
((_ f ((id val) ...) e1 e2 ...) ((_ f ((id val) ...) e1 e2 ...)
(and (id? #'f) (and-map id? #'(id ...))) (and (id? #'f) (and-map id? #'(id ...)))
(chi-let e r w s mod (expand-let e r w s mod
build-named-let build-named-let
#'(f id ...) #'(f id ...)
#'(val ...) #'(val ...)
#'(e1 e2 ...))) #'(e1 e2 ...)))
(_ (syntax-violation 'let "bad let" (source-wrap e w s mod))))))) (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))
@ -2060,9 +2060,9 @@
(build-letrec s #f (build-letrec s #f
(map syntax->datum ids) (map syntax->datum ids)
new-vars new-vars
(map (lambda (x) (chi x r w mod)) #'(val ...)) (map (lambda (x) (expand x r w mod)) #'(val ...))
(chi-body #'(e1 e2 ...) (expand-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod))))))) (source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
@ -2081,9 +2081,9 @@
(build-letrec s #t (build-letrec s #t
(map syntax->datum ids) (map syntax->datum ids)
new-vars new-vars
(map (lambda (x) (chi x r w mod)) #'(val ...)) (map (lambda (x) (expand x r w mod)) #'(val ...))
(chi-body #'(e1 e2 ...) (expand-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod))))))) (source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) (_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
@ -2103,15 +2103,15 @@
(build-lexical-assignment s (build-lexical-assignment s
(syntax->datum #'id) (syntax->datum #'id)
(binding-value b) (binding-value b)
(chi #'val r w mod))) (expand #'val r w mod)))
((global) ((global)
(build-global-assignment s n (chi #'val r w mod) id-mod)) (build-global-assignment s n (expand #'val r w mod) id-mod))
((macro) ((macro)
(let ((p (binding-value b))) (let ((p (binding-value b)))
(if (procedure-property p 'variable-transformer) (if (procedure-property p 'variable-transformer)
;; As syntax-type does, call chi-macro with ;; As syntax-type does, call expand-macro with
;; the mod of the expression. Hmm. ;; the mod of the expression. Hmm.
(chi (chi-macro p e r w s #f mod) r empty-wrap mod) (expand (expand-macro p e r w s #f mod) r empty-wrap mod)
(syntax-violation 'set! "not a variable transformer" (syntax-violation 'set! "not a variable transformer"
(wrap e w mod) (wrap e w mod)
(wrap #'id w id-mod))))) (wrap #'id w id-mod)))))
@ -2126,7 +2126,7 @@
(lambda (type value ee ww ss modmod) (lambda (type value ee ww ss modmod)
(case type (case type
((module-ref) ((module-ref)
(let ((val (chi #'val r w mod))) (let ((val (expand #'val r w mod)))
(call-with-values (lambda () (value #'(head tail ...) r w)) (call-with-values (lambda () (value #'(head tail ...) r w))
(lambda (e r w s* mod) (lambda (e r w s* mod)
(syntax-case e () (syntax-case e ()
@ -2135,8 +2135,8 @@
val mod))))))) val mod)))))))
(else (else
(build-application s (build-application s
(chi #'(setter head) r w mod) (expand #'(setter head) r w mod)
(map (lambda (e) (chi e r w mod)) (map (lambda (e) (expand e r w mod))
#'(tail ... val)))))))) #'(tail ... val))))))))
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
@ -2182,15 +2182,15 @@
((_ test then) ((_ test then)
(build-conditional (build-conditional
s s
(chi #'test r w mod) (expand #'test r w mod)
(chi #'then r w mod) (expand #'then r w mod)
(build-void no-source))) (build-void no-source)))
((_ test then else) ((_ test then else)
(build-conditional (build-conditional
s s
(chi #'test r w mod) (expand #'test r w mod)
(chi #'then r w mod) (expand #'then r w mod)
(chi #'else r w mod)))))) (expand #'else r w mod))))))
(global-extend 'core 'with-fluids (global-extend 'core 'with-fluids
(lambda (e r w s mod) (lambda (e r w s mod)
@ -2198,10 +2198,10 @@
((_ ((fluid val) ...) b b* ...) ((_ ((fluid val) ...) b b* ...)
(build-dynlet (build-dynlet
s s
(map (lambda (x) (chi x r w mod)) #'(fluid ...)) (map (lambda (x) (expand x r w mod)) #'(fluid ...))
(map (lambda (x) (chi x r w mod)) #'(val ...)) (map (lambda (x) (expand x r w mod)) #'(val ...))
(chi-body #'(b b* ...) (expand-body #'(b b* ...)
(source-wrap e w s mod) r w mod)))))) (source-wrap e w s mod) r w mod))))))
(global-extend 'begin 'begin '()) (global-extend 'begin 'begin '())
@ -2289,16 +2289,16 @@
(build-application no-source (build-application no-source
(build-primref no-source 'apply) (build-primref no-source 'apply)
(list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '() (list (build-simple-lambda no-source (map syntax->datum ids) #f new-vars '()
(chi exp (expand exp
(extend-env (extend-env
labels labels
(map (lambda (var level) (map (lambda (var level)
(make-binding 'syntax `(,var . ,level))) (make-binding 'syntax `(,var . ,level)))
new-vars new-vars
(map cdr pvars)) (map cdr pvars))
r) r)
(make-binding-wrap ids labels empty-wrap) (make-binding-wrap ids labels empty-wrap)
mod)) mod))
y)))))) y))))))
(define gen-clause (define gen-clause
@ -2350,20 +2350,20 @@
(and-map (lambda (x) (not (free-id=? #'pat x))) (and-map (lambda (x) (not (free-id=? #'pat x)))
(cons #'(... ...) keys))) (cons #'(... ...) keys)))
(if (free-id=? #'pad #'_) (if (free-id=? #'pad #'_)
(chi #'exp r empty-wrap mod) (expand #'exp r empty-wrap mod)
(let ((labels (list (gen-label))) (let ((labels (list (gen-label)))
(var (gen-var #'pat))) (var (gen-var #'pat)))
(build-application no-source (build-application no-source
(build-simple-lambda (build-simple-lambda
no-source (list (syntax->datum #'pat)) #f (list var) no-source (list (syntax->datum #'pat)) #f (list var)
'() '()
(chi #'exp (expand #'exp
(extend-env labels (extend-env labels
(list (make-binding 'syntax `(,var . 0))) (list (make-binding 'syntax `(,var . 0)))
r) r)
(make-binding-wrap #'(pat) (make-binding-wrap #'(pat)
labels empty-wrap) labels empty-wrap)
mod)) mod))
(list x)))) (list x))))
(gen-clause x keys (cdr clauses) r (gen-clause x keys (cdr clauses) r
#'pat #t #'exp mod))) #'pat #t #'exp mod)))
@ -2388,10 +2388,10 @@
#'(key ...) #'(m ...) #'(key ...) #'(m ...)
r r
mod)) mod))
(list (chi #'val r empty-wrap mod)))) (list (expand #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e)))))))) (syntax-violation 'syntax-case "invalid literals list" e))))))))
;; The portable macroexpand seeds chi-top's mode m with 'e (for ;; The portable macroexpand seeds expand-top's mode m with 'e (for
;; evaluating) and esew (which stands for "eval syntax expanders ;; evaluating) and esew (which stands for "eval syntax expanders
;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
;; if we are compiling a file, and esew is set to ;; if we are compiling a file, and esew is set to
@ -2402,8 +2402,8 @@
;; the object file if we are compiling a file. ;; the object file if we are compiling a file.
(set! macroexpand (set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval))) (lambda* (x #:optional (m 'e) (esew '(eval)))
(chi-top-sequence (list x) null-env top-wrap #f m esew (expand-top-sequence (list x) null-env top-wrap #f m esew
(cons 'hygiene (module-name (current-module)))))) (cons 'hygiene (module-name (current-module))))))
(set! identifier? (set! identifier?
(lambda (x) (lambda (x)