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