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: 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

301
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,90 +2625,103 @@
(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))
(letrec* ((match-each (set! $sc-dispatch
(lambda (e p w mod) (lambda (e p)
(cond (letrec* ((match-each
((pair? e) (lambda (e p w mod)
(let ((first (match (car e) p w '() mod))) (cond
(and first (let ((rest (match-each (cdr e) p w mod))) (and rest (cons first rest)))))) ((pair? e)
((null? e) '()) (let ((first (match (car e) p w '() mod)))
((syntax? e) (and first (let ((rest (match-each (cdr e) p w mod))) (and rest (cons first rest))))))
(match-each (syntax-expression e) p (join-wraps w (syntax-wrap e)) (or (syntax-module e) mod))) ((null? e) '())
(else #f)))) ((syntax? e)
(match-each+ (match-each
(lambda (e x-pat y-pat z-pat w r mod) (syntax-expression e)
(let f ((e e) (w w)) p
(cond (join-wraps w (syntax-wrap e))
((pair? e) (or (syntax-module e) mod)))
(call-with-values (else #f))))
(lambda () (f (cdr e) w)) (match-each+
(lambda (xr* y-pat r) (lambda (e x-pat y-pat z-pat w r mod)
(if r (let f ((e e) (w w))
(if (null? y-pat)
(let ((xr (match (car e) x-pat w '() mod)))
(if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
(values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
(values #f #f #f)))))
((syntax? e) (f (syntax-expression e) (join-wraps w (syntax-wrap e))))
(else (values '() y-pat (match e z-pat w r mod)))))))
(match-each-any
(lambda (e w mod)
(cond
((pair? e) (let ((l (match-each-any (cdr e) w mod))) (and l (cons (wrap (car e) w mod) l))))
((null? e) '())
((syntax? e) (match-each-any (syntax-expression e) (join-wraps w (syntax-wrap e)) mod))
(else #f))))
(match-empty
(lambda (p r)
(cond
((null? p) r)
((eq? p '_) r)
((eq? p 'any) (cons '() r))
((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
((eq? p 'each-any) (cons '() r))
(else (let ((key (vector-ref p 0)))
(cond (cond
((memv key '(each)) (match-empty (vector-ref p 1) r)) ((pair? e)
((memv key '(each+))
(match-empty
(vector-ref p 1)
(match-empty (reverse (vector-ref p 2)) (match-empty (vector-ref p 3) r))))
((memv key '(free-id atom)) r)
((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
(combine (lambda (r* r) (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
(match*
(lambda (e p w r mod)
(cond
((null? p) (and (null? e) r))
((pair? p) (and (pair? e) (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
((eq? p 'each-any) (let ((l (match-each-any e w mod))) (and l (cons l r))))
(else (let ((key (vector-ref p 0)))
(cond
((memv key '(each))
(if (null? e)
(match-empty (vector-ref p 1) r)
(let ((l (match-each e (vector-ref p 1) w mod)))
(and l
(let collect ((l l))
(if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
((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 () (f (cdr e) w))
(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)))))) (if r
((memv key '(free-id)) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) (if (null? y-pat)
((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e)) r)) (let ((xr (match (car e) x-pat w '() mod)))
((memv key '(vector)) (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) (if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
(match (lambda (e p w r mod) (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
(cond (values #f #f #f)))))
((not r) #f) ((syntax? e) (f (syntax-expression e) (join-wraps w (syntax-wrap e))))
((eq? p '_) r) (else (values '() y-pat (match e z-pat w r mod)))))))
((eq? p 'any) (cons (wrap e w mod) r)) (match-each-any
((syntax? e) (lambda (e w mod)
(match* (syntax-expression e) p (join-wraps w (syntax-wrap e)) r (or (syntax-module e) mod))) (cond
(else (match* e p w r mod)))))) ((pair? e) (let ((l (match-each-any (cdr e) w mod))) (and l (cons (wrap (car e) w mod) l))))
(set! $sc-dispatch ((null? e) '())
(lambda (e p) ((syntax? e) (match-each-any (syntax-expression e) (join-wraps w (syntax-wrap e)) mod))
(else #f))))
(match-empty
(lambda (p r)
(cond
((null? p) r)
((eq? p '_) r)
((eq? p 'any) (cons '() r))
((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
((eq? p 'each-any) (cons '() r))
(else (let ((key (vector-ref p 0)))
(cond
((memv key '(each)) (match-empty (vector-ref p 1) r))
((memv key '(each+))
(match-empty
(vector-ref p 1)
(match-empty (reverse (vector-ref p 2)) (match-empty (vector-ref p 3) r))))
((memv key '(free-id atom)) r)
((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
(combine (lambda (r* r) (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
(match*
(lambda (e p w r mod)
(cond
((null? p) (and (null? e) r))
((pair? p) (and (pair? e) (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
((eq? p 'each-any) (let ((l (match-each-any e w mod))) (and l (cons l r))))
(else (let ((key (vector-ref p 0)))
(cond
((memv key '(each))
(if (null? e)
(match-empty (vector-ref p 1) r)
(let ((l (match-each e (vector-ref p 1) w mod)))
(and l
(let collect ((l l))
(if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
((memv key '(each+))
(call-with-values
(lambda ()
(match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
(lambda (xr* y-pat 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 '(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)))))))))
(match (lambda (e p w r mod)
(cond
((not r) #f)
((eq? p '_) r)
((eq? p 'any) (cons (wrap e w mod) r))
((syntax? e)
(match*
(syntax-expression e)
p
(join-wraps w (syntax-wrap e))
r
(or (syntax-module e) mod)))
(else (match* e p w r mod))))))
(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

207
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,89 +2605,81 @@
;; 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))) (if (pair? props)
(if (pair? props) (datum->syntax #f result #:source props)
(datum->syntax #f result #:source props) result)))
result))) (cond
(cond ((pair? x)
((pair? x) (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
(annotate (cons (unstrip (car x)) (unstrip (cdr x))))) ((vector? x)
((vector? x) (let ((v (make-vector (vector-length x))))
(let ((v (make-vector (vector-length x)))) (annotate (list->vector (map unstrip (vector->list x))))))
(annotate (list->vector (map unstrip (vector->list x)))))) ((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) (assq-ref alist 'line)
(assq-ref alist 'line) (assq-ref alist 'column))))
(assq-ref alist 'column)))) (make-syntax datum
(make-syntax datum (if id
(if id (syntax-wrap id)
(syntax-wrap id) empty-wrap)
empty-wrap) (if id
(if id (syntax-module id)
(syntax-module id) #f)
#f) (cond
(cond ((not source)
((not source) (props->sourcev (source-properties datum)))
(props->sourcev (source-properties datum))) ((and (list? source) (and-map pair? source))
((and (list? source) (and-map pair? source)) (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) (throw 'syntax-error who message
(throw 'syntax-error who message (sourcev->alist
(sourcev->alist (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,30 +2737,27 @@
(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))
;; $sc-dispatch expects an expression and a pattern. If the expression (define/override ($sc-dispatch e p)
;; matches the pattern a list of the matching expressions for each ;; $sc-dispatch expects an expression and a pattern. If the expression
;; "any" is returned. Otherwise, #f is returned. (This use of #f will ;; matches the pattern a list of the matching expressions for each
;; not work on r4rs implementations that violate the ieee requirement ;; "any" is returned. Otherwise, #f is returned.
;; that #f and () be distinct.)
;; The expression is matched with the pattern as follows: ;; The expression is matched with the pattern as follows:
;; pattern: matches: ;; pattern: matches:
;; () empty list ;; () empty list
;; any anything ;; any anything
;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2) ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
;; each-any (any*) ;; each-any (any*)
;; #(free-id <key>) <key> with free-identifier=? ;; #(free-id <key>) <key> with free-identifier=?
;; #(each <pattern>) (<pattern>*) ;; #(each <pattern>) (<pattern>*)
;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
;; #(vector <pattern>) (list->vector <pattern>) ;; #(vector <pattern>) (list->vector <pattern>)
;; #(atom <object>) <object> with "equal?" ;; #(atom <object>) <object> with "equal?"
;; Vector cops out to pair under assumption that vectors are rare. If ;; Vector cops out to pair under assumption that vectors are rare. If
;; 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
@ -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 (cond
(lambda (e p) ((eq? p 'any) (list e))
(cond ((eq? p '_) '())
((eq? p 'any) (list e)) ((syntax? e)
((eq? p '_) '()) (match* (syntax-expression e)
((syntax? e) p (syntax-wrap e) '() (syntax-module e)))
(match* (syntax-expression e) (else (match* e p empty-wrap '() #f)))))
p (syntax-wrap e) '() (syntax-module e)))
(else (match* e p empty-wrap '() #f)))))))
(define-syntax with-syntax (define-syntax with-syntax