mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

psyntax: Match when rebuilding macro output

Browse source 
* module/ice-9/psyntax.scm (expand-macro): Use match.
(eval-local-transformer): Use unless for side effect.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-18 15:06:22 +01:00
parent b4aebbd7a5
commit 522b0b4510
2 changed files with 176 additions and 87 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -69,7 +69,7 @@
(build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev fun-exp arg-exps))) (build-call (lambda (sourcev fun-exp arg-exps) (make-call sourcev fun-exp arg-exps)))
(build-conditional (build-conditional
(lambda (sourcev test-exp then-exp else-exp) (make-conditional sourcev test-exp then-exp else-exp))) (lambda (sourcev test-exp then-exp else-exp) (make-conditional sourcev test-exp then-exp else-exp)))
(build-lexical-reference (lambda (type sourcev name var) (make-lexical-ref sourcev name var))) (build-lexical-reference (lambda (sourcev name var) (make-lexical-ref sourcev name var)))
(build-lexical-assignment (build-lexical-assignment
(lambda (sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp)))) (lambda (sourcev name var exp) (make-lexical-set sourcev name var (maybe-name-value name exp))))
(analyze-variable (analyze-variable
@ -171,7 +171,7 @@
(list (maybe-name-value f-name proc)) (list (maybe-name-value f-name proc))
(build-call (build-call
src src
(build-lexical-reference 'fun src f-name f) (build-lexical-reference src f-name f)
(map maybe-name-value ids val-exps))))) (map maybe-name-value ids val-exps)))))
(fk)))) (fk))))
(fk))))) (fk)))))
@ -645,14 +645,37 @@
(eq? i j)))) (eq? i j))))
(valid-bound-ids? (valid-bound-ids?
(lambda (ids) (lambda (ids)
(and (let all-ids? ((ids ids)) (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids))))) (and (let all-ids? ((ids ids))
(let* ((v ids)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((id vx) (ids vy)) (and (id? id) (all-ids? ids))))
(fk))))))
(if (null? v) #t (fk))))
(distinct-bound-ids? ids)))) (distinct-bound-ids? ids))))
(distinct-bound-ids? (distinct-bound-ids?
(lambda (ids) (lambda (ids)
(let distinct? ((ids ids)) (let distinct? ((ids ids))
(or (null? ids) (and (not (bound-id-member? (car ids) (cdr ids))) (distinct? (cdr ids))))))) (let* ((v ids)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((id vx) (ids vy)) (and (not (bound-id-member? id ids)) (distinct? ids))))
(fk))))))
(if (null? v) #t (fk))))))
(bound-id-member? (bound-id-member?
(lambda (x list) (and (not (null? list)) (or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) (lambda (x ids)
(let* ((v ids)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((id vx) (ids vy)) (or (bound-id=? x id) (bound-id-member? x ids))))
(fk))))))
(if (null? v) #f (fk)))))
(wrap (lambda (x w defmod) (source-wrap x w #f defmod))) (wrap (lambda (x w defmod) (source-wrap x w #f defmod)))
(wrap-syntax (wrap-syntax
(lambda (x w defmod) (lambda (x w defmod)
@ -668,10 +691,15 @@
(lambda (body r w s mod) (lambda (body r w s mod)
(build-sequence (build-sequence
s s
(let dobody ((body body) (r r) (w w) (mod mod)) (let lp ((body body))
(if (null? body) (let* ((v body)
'() (fk (lambda ()
(let ((first (expand (car body) r w mod))) (cons first (dobody (cdr body) r w mod)))))))) (let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((head vx) (tail vy) (expr (expand head r w mod))) (cons expr (lp tail))))
(fk))))))
(if (null? v) '() (fk)))))))
(expand-top-sequence (expand-top-sequence
(lambda (body r w s m esew mod) (lambda (body r w s m esew mod)
(let* ((r (cons '("placeholder" placeholder) r)) (let* ((r (cons '("placeholder" placeholder) r))
@ -688,9 +716,19 @@
(letrec* ((ribcage-has-var? (letrec* ((ribcage-has-var?
(lambda (var) (lambda (var)
(let lp ((labels (ribcage-labels ribcage))) (let lp ((labels (ribcage-labels ribcage)))
(and (pair? labels) (let* ((v labels)
(let ((wrapped (cdar labels))) (fk (lambda ()
(or (eq? (syntax-expression wrapped) var) (lp (cdr labels))))))))) (let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy-1 (cdr v)))
(if (pair? vx)
(let ((vx (car vx)) (vy (cdr vx)))
(let* ((wrapped vy) (labels vy-1))
(or (eq? (syntax-expression wrapped) var)
(lp labels))))
(fk)))
(fk))))))
(if (null? v) #f (fk)))))))
(let lp ((unique var) (n 1)) (let lp ((unique var) (n 1))
(if (ribcage-has-var? unique) (if (ribcage-has-var? unique)
(let ((tail (string->symbol (number->string n)))) (let ((tail (string->symbol (number->string n))))
@ -705,18 +743,31 @@
(string->symbol (string->symbol
(number->string (hash (syntax->datum orig-form) most-positive-fixnum) 16)))))) (number->string (hash (syntax->datum orig-form) most-positive-fixnum) 16))))))
(parse (lambda (body r w s m esew mod) (parse (lambda (body r w s m esew mod)
(let lp ((body body) (exps '())) (let lp ((body body))
(if (null? body) (let* ((v body)
exps (fk (lambda ()
(lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps)))))) (let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((head vx)
(tail vy)
(thunks (parse1 head r w s m esew mod)))
(append thunks (lp tail))))
(fk))))))
(if (null? v) '() (fk))))))
(parse1 (parse1
(lambda (x r w s m esew mod) (lambda (x r w s m esew mod)
(letrec* ((current-module-for-expansion (letrec* ((current-module-for-expansion
(lambda (mod) (lambda (mod)
(let ((key (car mod))) (let* ((v mod)
(if (memv key '(hygiene)) (fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v)))) mod))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(if (eq? vx 'hygiene)
(cons 'hygiene (module-name (current-module))) (cons 'hygiene (module-name (current-module)))
mod))))) (fk)))
(fk))))))
(call-with-values (call-with-values
(lambda () (lambda ()
(let ((mod (current-module-for-expansion mod))) (let ((mod (current-module-for-expansion mod)))
@ -832,8 +883,19 @@
(top-level-eval x mod) (top-level-eval x mod)
(lambda () x)) (lambda () x))
(lambda () (expand-expr type value form e r w s mod))))))))))))) (lambda () (expand-expr type value form e r w s mod)))))))))))))
(let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) (let* ((v (let lp ((thunks (parse body r w s m esew mod)))
(if (null? exps) (build-void s) (build-sequence s exps))))))) (let* ((v thunks)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((thunk vx) (thunks vy)) (cons (thunk) (lp thunks))))
(fk))))))
(if (null? v) '() (fk)))))
(fk (lambda ()
(let* ((fk (lambda () (error "value failed to match" v))) (exps v))
(build-sequence s exps)))))
(if (null? v) (build-void s) (fk)))))))
(expand-install-global (expand-install-global
(lambda (mod name type e) (lambda (mod name type e)
(build-global-definition (build-global-definition
@ -850,10 +912,29 @@
(lambda (e when-list) (lambda (e when-list)
(let ((result (strip when-list))) (let ((result (strip when-list)))
(let lp ((l result)) (let lp ((l result))
(cond (let* ((v l)
((null? l) result) (fk (lambda ()
((memq (car l) '(compile load eval expand)) (lp (cdr l))) (let ((fk (lambda () (error "value failed to match" v))))
(else (syntax-violation 'eval-when "invalid situation" e (car l)))))))) (if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((x vx)
(l vy)
(v x)
(fk (lambda ()
(let ((fk (lambda () (error "value failed to match" v))))
(syntax-violation 'eval-when "invalid situation" e x))))
(tk (lambda () (lp l))))
(if (eq? v 'compile)
(tk)
(let ((tk (lambda () (tk))))
(if (eq? v 'load)
(tk)
(let ((tk (lambda () (tk))))
(if (eq? v 'eval)
(tk)
(let ((tk (lambda () (tk)))) (if (eq? v 'expand) (tk) (fk))))))))))
(fk))))))
(if (null? v) result (fk)))))))
(syntax-type (syntax-type
(lambda (e r w s rib mod for-car?) (lambda (e r w s rib mod for-car?)
(cond (cond
@ -960,18 +1041,14 @@
(lambda (type value form e r w s mod) (lambda (type value form e r w s mod)
(let ((key type)) (let ((key type))
(cond (cond
((memv key '(lexical)) (build-lexical-reference 'value s e value)) ((memv key '(lexical)) (build-lexical-reference s e value))
((memv key '(core core-form)) (value e r w s mod)) ((memv key '(core core-form)) (value e r w s mod))
((memv key '(module-ref)) ((memv key '(module-ref))
(call-with-values (lambda () (value e r w mod)) (lambda (e r w s mod) (expand e r w mod)))) (call-with-values (lambda () (value e r w mod)) (lambda (e r w s mod) (expand e r w mod))))
((memv key '(lexical-call)) ((memv key '(lexical-call))
(expand-call (expand-call
(let ((id (car e))) (let ((id (car e)))
(build-lexical-reference (build-lexical-reference (source-annotation id) (if (syntax? id) (syntax->datum id) id) value))
'fun
(source-annotation id)
(if (syntax? id) (syntax->datum id) id)
value))
e e
r r
w w
@ -1035,7 +1112,17 @@
(lambda (p e r w s rib mod) (lambda (p e r w s rib mod)
(letrec* ((decorate-source (lambda (x) (source-wrap x empty-wrap s #f))) (letrec* ((decorate-source (lambda (x) (source-wrap x empty-wrap s #f)))
(map* (lambda (f x) (map* (lambda (f x)
(cond ((null? x) x) ((pair? x) (cons (f (car x)) (map* f (cdr x)))) (else (f x))))) (let* ((v x)
(fk (lambda ()
(let ((fk (lambda ()
(let* ((fk (lambda () (error "value failed to match" v)))
(x v))
(f x)))))
(if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(let* ((x vx) (x* vy)) (cons (f x) (map* f x*))))
(fk))))))
(if (null? v) '() (fk)))))
(rebuild-macro-output (rebuild-macro-output
(lambda (x m) (lambda (x m)
(cond (cond
@ -1065,11 +1152,11 @@
(source-wrap e w (wrap-subst w) mod) (source-wrap e w (wrap-subst w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-fef transformer-environment) (let* ((t-680b775fb37a463-10d6 transformer-environment)
(t-680b775fb37a463-ff0 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-10d7 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-fef t-680b775fb37a463-10d6
t-680b775fb37a463-ff0 t-680b775fb37a463-10d7
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -1221,7 +1308,8 @@
(eval-local-transformer (eval-local-transformer
(lambda (expanded mod) (lambda (expanded mod)
(let ((p (local-eval expanded mod))) (let ((p (local-eval expanded mod)))
(if (procedure? p) p (syntax-violation #f "nonprocedure transformer" p))))) (if (not (procedure? p)) (syntax-violation #f "nonprocedure transformer" p))
p)))
(expand-void (lambda () (build-void #f))) (expand-void (lambda () (build-void #f)))
(ellipsis? (ellipsis?
(lambda (e r mod) (lambda (e r mod)
@ -1599,11 +1687,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-125d (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463-125c tmp-680b775fb37a463
tmp-680b775fb37a463-125b) tmp-680b775fb37a463-135f)
(cons tmp-680b775fb37a463-125b (cons tmp-680b775fb37a463-135f
(cons tmp-680b775fb37a463-125c tmp-680b775fb37a463-125d))) (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1805,7 +1893,7 @@
(regen (lambda (x) (regen (lambda (x)
(let ((key (car x))) (let ((key (car x)))
(cond (cond
((memv key '(ref)) (build-lexical-reference 'value #f (cadr x) (cadr x))) ((memv key '(ref)) (build-lexical-reference #f (cadr x) (cadr x)))
((memv key '(primitive)) (build-primref #f (cadr x))) ((memv key '(primitive)) (build-primref #f (cadr x)))
((memv key '(quote)) (build-data #f (cadr x))) ((memv key '(quote)) (build-data #f (cadr x)))
((memv key '(lambda)) ((memv key '(lambda))
@ -2262,7 +2350,7 @@
#f #f
(list y) (list y)
'() '()
(let ((y (build-lexical-reference 'value #f 'tmp y))) (let ((y (build-lexical-reference #f 'tmp y)))
(build-conditional (build-conditional
#f #f
(let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
@ -2331,7 +2419,7 @@
#f #f
(list x) (list x)
'() '()
(gen-syntax-case (build-lexical-reference 'value #f 'tmp x) key m r mod)) (gen-syntax-case (build-lexical-reference #f 'tmp x) key m r mod))
(list (expand 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)))
tmp) tmp)
@ -2698,8 +2786,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-147c tmp-680b775fb37a463-147b tmp-680b775fb37a463-147a)
(list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2)) (list (cons tmp-680b775fb37a463-147a tmp-680b775fb37a463-147b)
tmp-680b775fb37a463-147c))
template template
pattern pattern
keyword))) keyword)))
@ -2714,8 +2803,8 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-138f) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-138f tmp-680b775fb37a463) tmp-680b775fb37a463-1)) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -2727,11 +2816,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-13aa (map (lambda (tmp-680b775fb37a463-14ae
tmp-680b775fb37a463-13a9 tmp-680b775fb37a463-14ad
tmp-680b775fb37a463-13a8) tmp-680b775fb37a463-14ac)
(list (cons tmp-680b775fb37a463-13a8 tmp-680b775fb37a463-13a9) (list (cons tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad)
tmp-680b775fb37a463-13aa)) tmp-680b775fb37a463-14ae))
template template
pattern pattern
keyword))) keyword)))
@ -2747,11 +2836,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-13c9 (map (lambda (tmp-680b775fb37a463-14cd
tmp-680b775fb37a463-13c8 tmp-680b775fb37a463-14cc
tmp-680b775fb37a463-13c7) tmp-680b775fb37a463-14cb)
(list (cons tmp-680b775fb37a463-13c7 tmp-680b775fb37a463-13c8) (list (cons tmp-680b775fb37a463-14cb tmp-680b775fb37a463-14cc)
tmp-680b775fb37a463-13c9)) tmp-680b775fb37a463-14cd))
template template
pattern pattern
keyword))) keyword)))
@ -2879,8 +2968,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-157a)
(list "value" tmp-680b775fb37a463)) (list "value"
tmp-680b775fb37a463-157a))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2906,9 +2996,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-147b) (map (lambda (tmp-680b775fb37a463-157f)
(list "value" (list "value"
tmp-680b775fb37a463-147b)) tmp-680b775fb37a463-157f))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -2965,8 +3055,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-159a)
(list "value" tmp-680b775fb37a463)) (list "value" tmp-680b775fb37a463-159a))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3048,8 +3138,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-14df) (apply (lambda (t-680b775fb37a463-15e3)
(cons "vector" t-680b775fb37a463-14df)) (cons "vector" t-680b775fb37a463-15e3))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3059,8 +3149,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-14eb) (k (map (lambda (tmp-680b775fb37a463-15ef)
(list "quote" tmp-680b775fb37a463-14eb)) (list "quote" tmp-680b775fb37a463-15ef))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3071,8 +3161,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-14fa tmp)) (let ((t-680b775fb37a463-15fe tmp))
(list "list->vector" t-680b775fb37a463-14fa))))))))))))))))) (list "list->vector" t-680b775fb37a463-15fe)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3084,9 +3174,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-160d)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-160d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3102,14 +3192,13 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-151d (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463)
t-680b775fb37a463-151c)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-151d t-680b775fb37a463-1
t-680b775fb37a463-151c)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3122,12 +3211,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-162d)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)) t-680b775fb37a463-162d))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

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

@ -1422,10 +1422,10 @@
(define (decorate-source x) (define (decorate-source x)
(source-wrap x empty-wrap s #f)) (source-wrap x empty-wrap s #f))
(define (map* f x) (define (map* f x)
(cond (match x
((null? x) x) (() '())
((pair? x) (cons (f (car x)) (map* f (cdr x)))) ((x . x*) (cons (f x) (map* f x*)))
(else (f x)))) (x (f x))))
(define rebuild-macro-output (define rebuild-macro-output
(lambda (x m) (lambda (x m)
(cond ((pair? x) (cond ((pair? x)
@ -1663,9 +1663,9 @@
(define (eval-local-transformer expanded mod) (define (eval-local-transformer expanded mod)
(let ((p (local-eval expanded mod))) (let ((p (local-eval expanded mod)))
(if (procedure? p) (unless (procedure? p)
p (syntax-violation #f "nonprocedure transformer" p))
(syntax-violation #f "nonprocedure transformer" p)))) p))
(define (expand-void) (define (expand-void)
(build-void no-source)) (build-void no-source))