mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
Code Activity

psyntax: Cosmetic change to overriden globals

Browse source 
* module/ice-9/psyntax.scm (define/override, define*/override): Use
instead of set! on globals.
($sc-dispatch): Renest.  Will compile to the same thing as before.
* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2024-11-20 15:55:44 +01:00
parent 2395f3b74c
commit 2f175f3453
2 changed files with 260 additions and 248 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -105,6 +105,8 @@
(fk))))) (fk)))))
(top-level-eval (lambda (x mod) (primitive-eval x))) (top-level-eval (lambda (x mod) (primitive-eval x)))
(local-eval (lambda (x mod) (primitive-eval x))) (local-eval (lambda (x mod) (primitive-eval x)))
(global-extend
(lambda (type sym val) (module-define! (current-module) sym (make-syntax-transformer sym type val))))
(sourcev-filename (lambda (s) (vector-ref s 0))) (sourcev-filename (lambda (s) (vector-ref s 0)))
(sourcev-line (lambda (s) (vector-ref s 1))) (sourcev-line (lambda (s) (vector-ref s 1)))
(sourcev-column (lambda (s) (vector-ref s 2))) (sourcev-column (lambda (s) (vector-ref s 2)))
@ -306,8 +308,6 @@
(fk)))) (fk))))
(fk)))))) (fk))))))
(if (null? v) '() (fk))))) (if (null? v) '() (fk)))))
(global-extend
(lambda (type sym val) (module-define! (current-module) sym (make-syntax-transformer sym type val))))
(nonsymbol-id? (lambda (x) (and (syntax? x) (symbol? (syntax-expression x))))) (nonsymbol-id? (lambda (x) (and (syntax? x) (symbol? (syntax-expression x)))))
(id? (lambda (x) (if (symbol? x) #t (and (syntax? x) (symbol? (syntax-expression x)))))) (id? (lambda (x) (if (symbol? x) #t (and (syntax? x) (symbol? (syntax-expression x))))))
(id-sym-name (lambda (x) (if (syntax? x) (syntax-expression x) x))) (id-sym-name (lambda (x) (if (syntax? x) (syntax-expression x) x)))
@ -1196,11 +1196,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-c86 transformer-environment) (let* ((t-680b775fb37a463-cbb transformer-environment)
(t-680b775fb37a463-c87 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-cbc (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-c86 t-680b775fb37a463-cbb
t-680b775fb37a463-c87 t-680b775fb37a463-cbc
(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)
@ -1731,11 +1731,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-f0f (map (lambda (tmp-680b775fb37a463-f44
tmp-680b775fb37a463-f0e tmp-680b775fb37a463-f43
tmp-680b775fb37a463-f0d) tmp-680b775fb37a463-f42)
(cons tmp-680b775fb37a463-f0d (cons tmp-680b775fb37a463-f42
(cons tmp-680b775fb37a463-f0e tmp-680b775fb37a463-f0f))) (cons tmp-680b775fb37a463-f43 tmp-680b775fb37a463-f44)))
e2* e2*
e1* e1*
args*))) args*)))
@ -2008,8 +2008,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-11a9
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) tmp-680b775fb37a463-11a8
tmp-680b775fb37a463-11a7)
(cons tmp-680b775fb37a463-11a7
(cons tmp-680b775fb37a463-11a8 tmp-680b775fb37a463-11a9)))
e2 e2
e1 e1
args))) args)))
@ -2019,9 +2022,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-11bf
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-11be
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-118a))) tmp-680b775fb37a463-11bd)
(cons tmp-680b775fb37a463-11bd
(cons tmp-680b775fb37a463-11be tmp-680b775fb37a463-11bf)))
e2 e2
e1 e1
args))) args)))
@ -2039,11 +2044,11 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-11aa (map (lambda (tmp-680b775fb37a463-11df
tmp-680b775fb37a463-11a9 tmp-680b775fb37a463-11de
tmp-680b775fb37a463-11a8) tmp-680b775fb37a463-11dd)
(cons tmp-680b775fb37a463-11a8 (cons tmp-680b775fb37a463-11dd
(cons tmp-680b775fb37a463-11a9 tmp-680b775fb37a463-11aa))) (cons tmp-680b775fb37a463-11de tmp-680b775fb37a463-11df)))
e2 e2
e1 e1
args))) args)))
@ -2053,11 +2058,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-11c0 (map (lambda (tmp-680b775fb37a463-11f5
tmp-680b775fb37a463-11bf tmp-680b775fb37a463-11f4
tmp-680b775fb37a463-11be) tmp-680b775fb37a463-11f3)
(cons tmp-680b775fb37a463-11be (cons tmp-680b775fb37a463-11f3
(cons tmp-680b775fb37a463-11bf tmp-680b775fb37a463-11c0))) (cons tmp-680b775fb37a463-11f4 tmp-680b775fb37a463-11f5)))
e2 e2
e1 e1
args))) args)))
@ -2620,6 +2625,8 @@
(define! '%syntax-module %syntax-module) (define! '%syntax-module %syntax-module)
(define! 'syntax-local-binding syntax-local-binding) (define! 'syntax-local-binding syntax-local-binding)
(define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers)) (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
(set! $sc-dispatch
(lambda (e p)
(letrec* ((match-each (letrec* ((match-each
(lambda (e p w mod) (lambda (e p w mod)
(cond (cond
@ -2628,7 +2635,11 @@
(and first (let ((rest (match-each (cdr e) p w mod))) (and rest (cons first rest)))))) (and first (let ((rest (match-each (cdr e) p w mod))) (and rest (cons first rest))))))
((null? e) '()) ((null? e) '())
((syntax? e) ((syntax? e)
(match-each (syntax-expression e) p (join-wraps w (syntax-wrap e)) (or (syntax-module e) mod))) (match-each
(syntax-expression e)
p
(join-wraps w (syntax-wrap e))
(or (syntax-module e) mod)))
(else #f)))) (else #f))))
(match-each+ (match-each+
(lambda (e x-pat y-pat z-pat w r mod) (lambda (e x-pat y-pat z-pat w r mod)
@ -2688,22 +2699,29 @@
(if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))))) (if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
((memv key '(each+)) ((memv key '(each+))
(call-with-values (call-with-values
(lambda () (match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod)) (lambda ()
(match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
(lambda (xr* y-pat r) (lambda (xr* y-pat r)
(and r (null? y-pat) (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) (and r
(null? y-pat)
(if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
((memv key '(free-id)) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) ((memv key '(free-id)) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r)) ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r))
((memv key '(vector)) (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) ((memv key '(vector))
(and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
(match (lambda (e p w r mod) (match (lambda (e p w r mod)
(cond (cond
((not r) #f) ((not r) #f)
((eq? p '_) r) ((eq? p '_) r)
((eq? p 'any) (cons (wrap e w mod) r)) ((eq? p 'any) (cons (wrap e w mod) r))
((syntax? e) ((syntax? e)
(match* (syntax-expression e) p (join-wraps w (syntax-wrap e)) r (or (syntax-module e) mod))) (match*
(syntax-expression e)
p
(join-wraps w (syntax-wrap e))
r
(or (syntax-module e) mod)))
(else (match* e p w r mod)))))) (else (match* e p w r mod))))))
(set! $sc-dispatch
(lambda (e p)
(cond (cond
((eq? p 'any) (list e)) ((eq? p 'any) (list e))
((eq? p '_) '()) ((eq? p '_) '())
@ -2867,9 +2885,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-149e tmp-680b775fb37a463-149d tmp-680b775fb37a463-149c) (map (lambda (tmp-680b775fb37a463-14d3 tmp-680b775fb37a463-14d2 tmp-680b775fb37a463-14d1)
(list (cons tmp-680b775fb37a463-149c tmp-680b775fb37a463-149d) (list (cons tmp-680b775fb37a463-14d1 tmp-680b775fb37a463-14d2)
tmp-680b775fb37a463-149e)) tmp-680b775fb37a463-14d3))
template template
pattern pattern
keyword))) keyword)))
@ -2884,11 +2902,11 @@
#f #f
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-14b7 (map (lambda (tmp-680b775fb37a463-14ec
tmp-680b775fb37a463-14b6 tmp-680b775fb37a463-14eb
tmp-680b775fb37a463-14b5) tmp-680b775fb37a463-14ea)
(list (cons tmp-680b775fb37a463-14b5 tmp-680b775fb37a463-14b6) (list (cons tmp-680b775fb37a463-14ea tmp-680b775fb37a463-14eb)
tmp-680b775fb37a463-14b7)) tmp-680b775fb37a463-14ec))
template template
pattern pattern
keyword))) keyword)))
@ -2900,11 +2918,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-14d0 (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-14cf (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-14ce) tmp-680b775fb37a463-2))
(list (cons tmp-680b775fb37a463-14ce tmp-680b775fb37a463-14cf)
tmp-680b775fb37a463-14d0))
template template
pattern pattern
keyword))) keyword)))
@ -2920,11 +2936,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-14ef (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-14ee tmp-680b775fb37a463-1
tmp-680b775fb37a463-14ed) tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463-14ed tmp-680b775fb37a463-14ee) (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)
tmp-680b775fb37a463-14ef)) tmp-680b775fb37a463-2))
template template
pattern pattern
keyword))) keyword)))
@ -3052,9 +3068,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-159c) (map (lambda (tmp-680b775fb37a463-15d1)
(list "value" (list "value"
tmp-680b775fb37a463-159c)) tmp-680b775fb37a463-15d1))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3080,9 +3096,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-15a1) (map (lambda (tmp-680b775fb37a463-15d6)
(list "value" (list "value"
tmp-680b775fb37a463-15a1)) tmp-680b775fb37a463-15d6))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3118,8 +3134,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-15b7) (map (lambda (tmp-680b775fb37a463-15ec)
(list "value" tmp-680b775fb37a463-15b7)) (list "value" tmp-680b775fb37a463-15ec))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3139,8 +3155,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-15bc) (map (lambda (tmp-680b775fb37a463-15f1)
(list "value" tmp-680b775fb37a463-15bc)) (list "value" tmp-680b775fb37a463-15f1))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3222,7 +3238,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) (cons "vector" t-680b775fb37a463)) (apply (lambda (t-680b775fb37a463-163a)
(cons "vector" t-680b775fb37a463-163a))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3256,9 +3273,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-162f) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-162f)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3293,12 +3310,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-164f) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-164f)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3311,12 +3328,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-165b) (apply (lambda (t-680b775fb37a463)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-165b)) t-680b775fb37a463))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3327,12 +3344,12 @@
(if tmp-1 (if tmp-1
(apply (lambda (x) (apply (lambda (x)
(let ((tmp (emit x))) (let ((tmp (emit x)))
(let ((t-680b775fb37a463 tmp)) (let ((t-680b775fb37a463-169c tmp))
(list (make-syntax (list (make-syntax
'list->vector 'list->vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463)))) t-680b775fb37a463-169c))))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
(if tmp-1 (if tmp-1

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

@ -2588,6 +2588,14 @@
(global-extend 'eval-when 'eval-when '()) (global-extend 'eval-when 'eval-when '())
(global-extend 'core 'syntax-case expand-syntax-case) (global-extend 'core 'syntax-case expand-syntax-case)
(define-syntax define/override
(syntax-rules ()
((_ (id . args) . body) (define/override id (lambda args . body)))
((_ id exp) (set! id exp))))
(define-syntax define*/override
(syntax-rules ()
((_ (id . args) . body) (define/override id (lambda* args . body)))))
;; The portable macroexpand seeds expand-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
@ -2597,8 +2605,7 @@
;; syntactic definitions are evaluated immediately after they are ;; syntactic definitions are evaluated immediately after they are
;; expanded, and the expanded definitions are also residualized into ;; expanded, and the expanded definitions are also residualized into
;; the object file if we are compiling a file. ;; the object file if we are compiling a file.
(set! macroexpand (define*/override (macroexpand x #:optional (m 'e) (esew '(eval)))
(lambda* (x #:optional (m 'e) (esew '(eval)))
(define (unstrip x) (define (unstrip x)
(define (annotate result) (define (annotate result)
(let ((props (source-properties x))) (let ((props (source-properties x)))
@ -2614,14 +2621,12 @@
((syntax? x) x) ((syntax? x) x)
(else (annotate x)))) (else (annotate x))))
(expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
(cons 'hygiene (module-name (current-module)))))) (cons 'hygiene (module-name (current-module)))))
(set! identifier? (define/override (identifier? x)
(lambda (x) (nonsymbol-id? x))
(nonsymbol-id? x)))
(set! datum->syntax (define*/override (datum->syntax id datum #:key source)
(lambda* (id datum #:key source)
(define (props->sourcev alist) (define (props->sourcev alist)
(and (pair? alist) (and (pair? alist)
(vector (assq-ref alist 'filename) (vector (assq-ref alist 'filename)
@ -2641,36 +2646,31 @@
(props->sourcev source)) (props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) ((and (vector? source) (= 3 (vector-length source)))
source) source)
(else (syntax-sourcev source)))))) (else (syntax-sourcev source)))))
(set! syntax->datum (define/override (syntax->datum x)
;; accepts any object, since syntax objects may consist partially ;; accepts any object, since syntax objects may consist partially
;; or entirely of unwrapped, nonsymbolic data ;; or entirely of unwrapped, nonsymbolic data
(lambda (x) (strip x))
(strip x)))
(set! generate-temporaries (define/override (generate-temporaries ls)
(lambda (ls)
(arg-check list? ls 'generate-temporaries) (arg-check list? ls 'generate-temporaries)
(let ((mod (cons 'hygiene (module-name (current-module))))) (let ((mod (cons 'hygiene (module-name (current-module)))))
(map (lambda (x) (map (lambda (x)
(wrap (gen-var 't) top-wrap mod)) (wrap (gen-var 't) top-wrap mod))
ls)))) ls)))
(set! free-identifier=? (define/override (free-identifier=? x y)
(lambda (x y)
(arg-check nonsymbol-id? x 'free-identifier=?) (arg-check nonsymbol-id? x 'free-identifier=?)
(arg-check nonsymbol-id? y 'free-identifier=?) (arg-check nonsymbol-id? y 'free-identifier=?)
(free-id=? x y))) (free-id=? x y))
(set! bound-identifier=? (define/override (bound-identifier=? x y)
(lambda (x y)
(arg-check nonsymbol-id? x 'bound-identifier=?) (arg-check nonsymbol-id? x 'bound-identifier=?)
(arg-check nonsymbol-id? y 'bound-identifier=?) (arg-check nonsymbol-id? y 'bound-identifier=?)
(bound-id=? x y))) (bound-id=? x y))
(set! syntax-violation (define*/override (syntax-violation who message form #:optional subform)
(lambda* (who message form #:optional subform)
(arg-check (lambda (x) (or (not x) (string? x) (symbol? x))) (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
who 'syntax-violation) who 'syntax-violation)
(arg-check string? message 'syntax-violation) (arg-check string? message 'syntax-violation)
@ -2679,7 +2679,7 @@
(or (source-annotation subform) (or (source-annotation subform)
(source-annotation form))) (source-annotation form)))
(strip form) (strip form)
(strip subform)))) (strip subform)))
(let () (let ()
(define (%syntax-module id) (define (%syntax-module id)
@ -2737,11 +2737,10 @@
(define! 'syntax-local-binding syntax-local-binding) (define! 'syntax-local-binding syntax-local-binding)
(define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers)) (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers))
(define/override ($sc-dispatch e p)
;; $sc-dispatch expects an expression and a pattern. If the expression ;; $sc-dispatch expects an expression and a pattern. If the expression
;; matches the pattern a list of the matching expressions for each ;; matches the pattern a list of the matching expressions for each
;; "any" is returned. Otherwise, #f is returned. (This use of #f will ;; "any" is returned. Otherwise, #f is returned.
;; not work on r4rs implementations that violate the ieee requirement
;; that #f and () be distinct.)
;; The expression is matched with the pattern as follows: ;; The expression is matched with the pattern as follows:
@ -2760,8 +2759,6 @@
;; not, should convert to: ;; not, should convert to:
;; #(vector <pattern>*) #(<pattern>*) ;; #(vector <pattern>*) #(<pattern>*)
(let ()
(define (match-each e p w mod) (define (match-each e p w mod)
(cond (cond
((pair? e) ((pair? e)
@ -2884,15 +2881,13 @@
(or (syntax-module e) mod))) (or (syntax-module e) mod)))
(else (match* e p w r mod)))) (else (match* e p w r mod))))
(set! $sc-dispatch
(lambda (e p)
(cond (cond
((eq? p 'any) (list e)) ((eq? p 'any) (list e))
((eq? p '_) '()) ((eq? p '_) '())
((syntax? e) ((syntax? e)
(match* (syntax-expression e) (match* (syntax-expression e)
p (syntax-wrap e) '() (syntax-module e))) p (syntax-wrap e) '() (syntax-module e)))
(else (match* e p empty-wrap '() #f))))))) (else (match* e p empty-wrap '() #f)))))
(define-syntax with-syntax (define-syntax with-syntax