mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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

249
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 ()
(cons 'hygiene (module-name (current-module))) (let ((fk (lambda () (error "value failed to match" v)))) mod))))
mod))))) (if (pair? v)
(let ((vx (car v)) (vy (cdr v)))
(if (eq? vx 'hygiene)
(cons 'hygiene (module-name (current-module)))
(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))