guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 08/09: psyntax: Cosmetic change to overriden globals


From: Andy Wingo
Subject: [Guile-commits] 08/09: psyntax: Cosmetic change to overriden globals
Date: Mon, 25 Nov 2024 05:47:45 -0500 (EST)

wingo pushed a commit to branch main
in repository guile.

commit 2f175f34537cd38bf7cf4f96d1afe0d0db93d019
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Wed Nov 20 15:55:44 2024 +0100

    psyntax: Cosmetic change to overriden globals
    
    * 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.
---
 module/ice-9/psyntax-pp.scm | 301 +++++++++++++++++++++++---------------------
 module/ice-9/psyntax.scm    | 227 ++++++++++++++++-----------------
 2 files changed, 270 insertions(+), 258 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 9c4b22e74..875a0af07 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -105,6 +105,8 @@
                      (fk)))))
             (top-level-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-line (lambda (s) (vector-ref s 1)))
             (sourcev-column (lambda (s) (vector-ref s 2)))
@@ -306,8 +308,6 @@
                                           (fk))))
                                   (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)))))
             (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)))
@@ -1196,11 +1196,11 @@
                                 (source-wrap e w (wrap-subst w) mod)
                                 x))
                               (else (decorate-source x))))))
-                 (let* ((t-680b775fb37a463-c86 transformer-environment)
-                        (t-680b775fb37a463-c87 (lambda (k) (k e r w s rib 
mod))))
+                 (let* ((t-680b775fb37a463-cbb transformer-environment)
+                        (t-680b775fb37a463-cbc (lambda (k) (k e r w s rib 
mod))))
                    (with-fluid*
-                    t-680b775fb37a463-c86
-                    t-680b775fb37a463-c87
+                    t-680b775fb37a463-cbb
+                    t-680b775fb37a463-cbc
                     (lambda () (rebuild-macro-output (p (source-wrap e 
(anti-mark w) s mod)) (new-mark))))))))
             (expand-body
              (lambda (body outer-form r w mod)
@@ -1731,11 +1731,11 @@
                                                 s
                                                 mod
                                                 get-formals
-                                                (map (lambda 
(tmp-680b775fb37a463-f0f
-                                                              
tmp-680b775fb37a463-f0e
-                                                              
tmp-680b775fb37a463-f0d)
-                                                       (cons 
tmp-680b775fb37a463-f0d
-                                                             (cons 
tmp-680b775fb37a463-f0e tmp-680b775fb37a463-f0f)))
+                                                (map (lambda 
(tmp-680b775fb37a463-f44
+                                                              
tmp-680b775fb37a463-f43
+                                                              
tmp-680b775fb37a463-f42)
+                                                       (cons 
tmp-680b775fb37a463-f42
+                                                             (cons 
tmp-680b775fb37a463-f43 tmp-680b775fb37a463-f44)))
                                                      e2*
                                                      e1*
                                                      args*)))
@@ -2008,8 +2008,11 @@
                        (apply (lambda (args e1 e2)
                                 (build-it
                                  '()
-                                 (map (lambda (tmp-680b775fb37a463-2 
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                        (cons tmp-680b775fb37a463 (cons 
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+                                 (map (lambda (tmp-680b775fb37a463-11a9
+                                               tmp-680b775fb37a463-11a8
+                                               tmp-680b775fb37a463-11a7)
+                                        (cons tmp-680b775fb37a463-11a7
+                                              (cons tmp-680b775fb37a463-11a8 
tmp-680b775fb37a463-11a9)))
                                       e2
                                       e1
                                       args)))
@@ -2019,9 +2022,11 @@
                              (apply (lambda (docstring args e1 e2)
                                       (build-it
                                        (list (cons 'documentation 
(syntax->datum docstring)))
-                                       (map (lambda (tmp-680b775fb37a463-118a 
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
-                                              (cons tmp-680b775fb37a463
-                                                    (cons 
tmp-680b775fb37a463-1 tmp-680b775fb37a463-118a)))
+                                       (map (lambda (tmp-680b775fb37a463-11bf
+                                                     tmp-680b775fb37a463-11be
+                                                     tmp-680b775fb37a463-11bd)
+                                              (cons tmp-680b775fb37a463-11bd
+                                                    (cons 
tmp-680b775fb37a463-11be tmp-680b775fb37a463-11bf)))
                                             e2
                                             e1
                                             args)))
@@ -2039,11 +2044,11 @@
                        (apply (lambda (args e1 e2)
                                 (build-it
                                  '()
-                                 (map (lambda (tmp-680b775fb37a463-11aa
-                                               tmp-680b775fb37a463-11a9
-                                               tmp-680b775fb37a463-11a8)
-                                        (cons tmp-680b775fb37a463-11a8
-                                              (cons tmp-680b775fb37a463-11a9 
tmp-680b775fb37a463-11aa)))
+                                 (map (lambda (tmp-680b775fb37a463-11df
+                                               tmp-680b775fb37a463-11de
+                                               tmp-680b775fb37a463-11dd)
+                                        (cons tmp-680b775fb37a463-11dd
+                                              (cons tmp-680b775fb37a463-11de 
tmp-680b775fb37a463-11df)))
                                       e2
                                       e1
                                       args)))
@@ -2053,11 +2058,11 @@
                              (apply (lambda (docstring args e1 e2)
                                       (build-it
                                        (list (cons 'documentation 
(syntax->datum docstring)))
-                                       (map (lambda (tmp-680b775fb37a463-11c0
-                                                     tmp-680b775fb37a463-11bf
-                                                     tmp-680b775fb37a463-11be)
-                                              (cons tmp-680b775fb37a463-11be
-                                                    (cons 
tmp-680b775fb37a463-11bf tmp-680b775fb37a463-11c0)))
+                                       (map (lambda (tmp-680b775fb37a463-11f5
+                                                     tmp-680b775fb37a463-11f4
+                                                     tmp-680b775fb37a463-11f3)
+                                              (cons tmp-680b775fb37a463-11f3
+                                                    (cons 
tmp-680b775fb37a463-11f4 tmp-680b775fb37a463-11f5)))
                                             e2
                                             e1
                                             args)))
@@ -2620,90 +2625,103 @@
       (define! '%syntax-module %syntax-module)
       (define! 'syntax-local-binding syntax-local-binding)
       (define! 'syntax-locally-bound-identifiers 
syntax-locally-bound-identifiers))
-    (letrec* ((match-each
-               (lambda (e p w mod)
-                 (cond
-                   ((pair? e)
-                    (let ((first (match (car e) p w '() mod)))
-                      (and first (let ((rest (match-each (cdr e) p w mod))) 
(and rest (cons first rest))))))
-                   ((null? e) '())
-                   ((syntax? e)
-                    (match-each (syntax-expression e) p (join-wraps w 
(syntax-wrap e)) (or (syntax-module e) mod)))
-                   (else #f))))
-              (match-each+
-               (lambda (e x-pat y-pat z-pat w r mod)
-                 (let f ((e e) (w w))
-                   (cond
-                     ((pair? e)
-                      (call-with-values
-                       (lambda () (f (cdr e) w))
-                       (lambda (xr* y-pat r)
-                         (if r
-                             (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
-                             ((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)))
+    (set! $sc-dispatch
+          (lambda (e p)
+            (letrec* ((match-each
+                       (lambda (e p w mod)
+                         (cond
+                           ((pair? e)
+                            (let ((first (match (car e) p w '() mod)))
+                              (and first (let ((rest (match-each (cdr e) p w 
mod))) (and rest (cons first rest))))))
+                           ((null? e) '())
+                           ((syntax? e)
+                            (match-each
+                             (syntax-expression e)
+                             p
+                             (join-wraps w (syntax-wrap e))
+                             (or (syntax-module e) mod)))
+                           (else #f))))
+                      (match-each+
+                       (lambda (e x-pat y-pat z-pat w r mod)
+                         (let f ((e e) (w w))
                            (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+))
+                             ((pair? e)
                               (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)
-                                 (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))))))
-      (set! $sc-dispatch
-            (lambda (e p)
+                                 (if r
+                                     (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
+                                     ((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
                 ((eq? p 'any) (list e))
                 ((eq? p '_) '())
@@ -2867,9 +2885,9 @@
                            #f
                            k
                            '()
-                           (map (lambda (tmp-680b775fb37a463-149e 
tmp-680b775fb37a463-149d tmp-680b775fb37a463-149c)
-                                  (list (cons tmp-680b775fb37a463-149c 
tmp-680b775fb37a463-149d)
-                                        tmp-680b775fb37a463-149e))
+                           (map (lambda (tmp-680b775fb37a463-14d3 
tmp-680b775fb37a463-14d2 tmp-680b775fb37a463-14d1)
+                                  (list (cons tmp-680b775fb37a463-14d1 
tmp-680b775fb37a463-14d2)
+                                        tmp-680b775fb37a463-14d3))
                                 template
                                 pattern
                                 keyword)))
@@ -2884,11 +2902,11 @@
                                  #f
                                  k
                                  (list docstring)
-                                 (map (lambda (tmp-680b775fb37a463-14b7
-                                               tmp-680b775fb37a463-14b6
-                                               tmp-680b775fb37a463-14b5)
-                                        (list (cons tmp-680b775fb37a463-14b5 
tmp-680b775fb37a463-14b6)
-                                              tmp-680b775fb37a463-14b7))
+                                 (map (lambda (tmp-680b775fb37a463-14ec
+                                               tmp-680b775fb37a463-14eb
+                                               tmp-680b775fb37a463-14ea)
+                                        (list (cons tmp-680b775fb37a463-14ea 
tmp-680b775fb37a463-14eb)
+                                              tmp-680b775fb37a463-14ec))
                                       template
                                       pattern
                                       keyword)))
@@ -2900,11 +2918,9 @@
                                        dots
                                        k
                                        '()
-                                       (map (lambda (tmp-680b775fb37a463-14d0
-                                                     tmp-680b775fb37a463-14cf
-                                                     tmp-680b775fb37a463-14ce)
-                                              (list (cons 
tmp-680b775fb37a463-14ce tmp-680b775fb37a463-14cf)
-                                                    tmp-680b775fb37a463-14d0))
+                                       (map (lambda (tmp-680b775fb37a463-2 
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                              (list (cons tmp-680b775fb37a463 
tmp-680b775fb37a463-1)
+                                                    tmp-680b775fb37a463-2))
                                             template
                                             pattern
                                             keyword)))
@@ -2920,11 +2936,11 @@
                                              dots
                                              k
                                              (list docstring)
-                                             (map (lambda 
(tmp-680b775fb37a463-14ef
-                                                           
tmp-680b775fb37a463-14ee
-                                                           
tmp-680b775fb37a463-14ed)
-                                                    (list (cons 
tmp-680b775fb37a463-14ed tmp-680b775fb37a463-14ee)
-                                                          
tmp-680b775fb37a463-14ef))
+                                             (map (lambda 
(tmp-680b775fb37a463-2
+                                                           
tmp-680b775fb37a463-1
+                                                           tmp-680b775fb37a463)
+                                                    (list (cons 
tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+                                                          
tmp-680b775fb37a463-2))
                                                   template
                                                   pattern
                                                   keyword)))
@@ -3052,9 +3068,9 @@
                                                              (apply (lambda (p)
                                                                       (if (= 
lev 0)
                                                                           
(quasilist*
-                                                                           
(map (lambda (tmp-680b775fb37a463-159c)
+                                                                           
(map (lambda (tmp-680b775fb37a463-15d1)
                                                                                
   (list "value"
-                                                                               
         tmp-680b775fb37a463-159c))
+                                                                               
         tmp-680b775fb37a463-15d1))
                                                                                
 p)
                                                                            
(quasi q lev))
                                                                           
(quasicons
@@ -3080,9 +3096,9 @@
                                                                    (apply 
(lambda (p)
                                                                             
(if (= lev 0)
                                                                                
 (quasiappend
-                                                                               
  (map (lambda (tmp-680b775fb37a463-15a1)
+                                                                               
  (map (lambda (tmp-680b775fb37a463-15d6)
                                                                                
         (list "value"
-                                                                               
               tmp-680b775fb37a463-15a1))
+                                                                               
               tmp-680b775fb37a463-15d6))
                                                                                
       p)
                                                                                
  (quasi q lev))
                                                                                
 (quasicons
@@ -3118,8 +3134,8 @@
                                            (apply (lambda (p)
                                                     (if (= lev 0)
                                                         (quasilist*
-                                                         (map (lambda 
(tmp-680b775fb37a463-15b7)
-                                                                (list "value" 
tmp-680b775fb37a463-15b7))
+                                                         (map (lambda 
(tmp-680b775fb37a463-15ec)
+                                                                (list "value" 
tmp-680b775fb37a463-15ec))
                                                               p)
                                                          (vquasi q lev))
                                                         (quasicons
@@ -3139,8 +3155,8 @@
                                                  (apply (lambda (p)
                                                           (if (= lev 0)
                                                               (quasiappend
-                                                               (map (lambda 
(tmp-680b775fb37a463-15bc)
-                                                                      (list 
"value" tmp-680b775fb37a463-15bc))
+                                                               (map (lambda 
(tmp-680b775fb37a463-15f1)
+                                                                      (list 
"value" tmp-680b775fb37a463-15f1))
                                                                     p)
                                                                (vquasi q lev))
                                                               (quasicons
@@ -3222,7 +3238,8 @@
                                        (let ((tmp-1 ls))
                                          (let ((tmp ($sc-dispatch tmp-1 
'each-any)))
                                            (if tmp
-                                               (apply (lambda 
(t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
+                                               (apply (lambda 
(t-680b775fb37a463-163a)
+                                                        (cons "vector" 
t-680b775fb37a463-163a))
                                                       tmp)
                                                (syntax-violation
                                                 #f
@@ -3256,9 +3273,9 @@
                                               (let ((tmp-1 (map emit x)))
                                                 (let ((tmp ($sc-dispatch tmp-1 
'each-any)))
                                                   (if tmp
-                                                      (apply (lambda 
(t-680b775fb37a463-162f)
+                                                      (apply (lambda 
(t-680b775fb37a463)
                                                                (cons 
(make-syntax 'list '((top)) '(hygiene guile))
-                                                                     
t-680b775fb37a463-162f))
+                                                                     
t-680b775fb37a463))
                                                              tmp)
                                                       (syntax-violation
                                                        #f
@@ -3293,12 +3310,12 @@
                                                           (let ((tmp-1 (map 
emit x)))
                                                             (let ((tmp 
($sc-dispatch tmp-1 'each-any)))
                                                               (if tmp
-                                                                  (apply 
(lambda (t-680b775fb37a463-164f)
+                                                                  (apply 
(lambda (t-680b775fb37a463)
                                                                            
(cons (make-syntax
                                                                                
   'append
                                                                                
   '((top))
                                                                                
   '(hygiene guile))
-                                                                               
  t-680b775fb37a463-164f))
+                                                                               
  t-680b775fb37a463))
                                                                          tmp)
                                                                   
(syntax-violation
                                                                    #f
@@ -3311,12 +3328,12 @@
                                                                 (let ((tmp-1 
(map emit x)))
                                                                   (let ((tmp 
($sc-dispatch tmp-1 'each-any)))
                                                                     (if tmp
-                                                                        (apply 
(lambda (t-680b775fb37a463-165b)
+                                                                        (apply 
(lambda (t-680b775fb37a463)
                                                                                
  (cons (make-syntax
                                                                                
         'vector
                                                                                
         '((top))
                                                                                
         '(hygiene guile))
-                                                                               
        t-680b775fb37a463-165b))
+                                                                               
        t-680b775fb37a463))
                                                                                
tmp)
                                                                         
(syntax-violation
                                                                          #f
@@ -3327,12 +3344,12 @@
                                                          (if tmp-1
                                                              (apply (lambda (x)
                                                                       (let 
((tmp (emit x)))
-                                                                        (let 
((t-680b775fb37a463 tmp))
+                                                                        (let 
((t-680b775fb37a463-169c tmp))
                                                                           
(list (make-syntax
                                                                                
  'list->vector
                                                                                
  '((top))
                                                                                
  '(hygiene guile))
-                                                                               
 t-680b775fb37a463))))
+                                                                               
 t-680b775fb37a463-169c))))
                                                                     tmp-1)
                                                              (let ((tmp-1 
($sc-dispatch tmp '(#(atom "value") any))))
                                                                (if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index d2c10fd06..2911e96ea 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2588,6 +2588,14 @@
   (global-extend 'eval-when 'eval-when '())
   (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
   ;; evaluating) and esew (which stands for "eval syntax expanders
   ;; 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
   ;; expanded, and the expanded definitions are also residualized into
   ;; the object file if we are compiling a file.
-  (set! macroexpand
-        (lambda* (x #:optional (m 'e) (esew '(eval)))
-          (define (unstrip x)
-            (define (annotate result)
-              (let ((props (source-properties x)))
-                (if (pair? props)
-                    (datum->syntax #f result #:source props)
-                    result)))
-            (cond
-             ((pair? x)
-              (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
-             ((vector? x)
-              (let ((v (make-vector (vector-length x))))
-                (annotate (list->vector (map unstrip (vector->list x))))))
-             ((syntax? x) x)
-             (else (annotate x))))
-          (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
-                               (cons 'hygiene (module-name 
(current-module))))))
-
-  (set! identifier?
-        (lambda (x)
-          (nonsymbol-id? x)))
-
-  (set! datum->syntax
-        (lambda* (id datum #:key source)
-          (define (props->sourcev alist)
-            (and (pair? alist)
-                 (vector (assq-ref alist 'filename)
-                         (assq-ref alist 'line)
-                         (assq-ref alist 'column))))
-          (make-syntax datum
-                       (if id
-                           (syntax-wrap id)
-                           empty-wrap)
-                       (if id
-                           (syntax-module id)
-                           #f)
-                       (cond
-                        ((not source)
-                         (props->sourcev (source-properties datum)))
-                        ((and (list? source) (and-map pair? source))
-                         (props->sourcev source))
-                        ((and (vector? source) (= 3 (vector-length source)))
-                         source)
-                        (else (syntax-sourcev source))))))
-
-  (set! syntax->datum
-        ;; accepts any object, since syntax objects may consist partially
-        ;; or entirely of unwrapped, nonsymbolic data
-        (lambda (x)
-          (strip x)))
-
-  (set! generate-temporaries
-        (lambda (ls)
-          (arg-check list? ls 'generate-temporaries)
-          (let ((mod (cons 'hygiene (module-name (current-module)))))
-            (map (lambda (x)
-                   (wrap (gen-var 't) top-wrap mod))
-                 ls))))
-
-  (set! free-identifier=?
-        (lambda (x y)
-          (arg-check nonsymbol-id? x 'free-identifier=?)
-          (arg-check nonsymbol-id? y 'free-identifier=?)
-          (free-id=? x y)))
-
-  (set! bound-identifier=?
-        (lambda (x y)
-          (arg-check nonsymbol-id? x 'bound-identifier=?)
-          (arg-check nonsymbol-id? y 'bound-identifier=?)
-          (bound-id=? x y)))
-
-  (set! syntax-violation
-        (lambda* (who message form #:optional subform)
-          (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
-                     who 'syntax-violation)
-          (arg-check string? message 'syntax-violation)
-          (throw 'syntax-error who message
-                 (sourcev->alist
-                  (or (source-annotation subform)
-                      (source-annotation form)))
-                 (strip form)
-                 (strip subform))))
+  (define*/override (macroexpand x #:optional (m 'e) (esew '(eval)))
+    (define (unstrip x)
+      (define (annotate result)
+        (let ((props (source-properties x)))
+          (if (pair? props)
+              (datum->syntax #f result #:source props)
+              result)))
+      (cond
+       ((pair? x)
+        (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
+       ((vector? x)
+        (let ((v (make-vector (vector-length x))))
+          (annotate (list->vector (map unstrip (vector->list x))))))
+       ((syntax? x) x)
+       (else (annotate x))))
+    (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
+                         (cons 'hygiene (module-name (current-module)))))
+
+  (define/override (identifier? x)
+    (nonsymbol-id? x))
+
+  (define*/override (datum->syntax id datum #:key source)
+    (define (props->sourcev alist)
+      (and (pair? alist)
+           (vector (assq-ref alist 'filename)
+                   (assq-ref alist 'line)
+                   (assq-ref alist 'column))))
+    (make-syntax datum
+                 (if id
+                     (syntax-wrap id)
+                     empty-wrap)
+                 (if id
+                     (syntax-module id)
+                     #f)
+                 (cond
+                  ((not source)
+                   (props->sourcev (source-properties datum)))
+                  ((and (list? source) (and-map pair? source))
+                   (props->sourcev source))
+                  ((and (vector? source) (= 3 (vector-length source)))
+                   source)
+                  (else (syntax-sourcev source)))))
+
+  (define/override (syntax->datum x)
+    ;; accepts any object, since syntax objects may consist partially
+    ;; or entirely of unwrapped, nonsymbolic data
+    (strip x))
+
+  (define/override (generate-temporaries ls)
+    (arg-check list? ls 'generate-temporaries)
+    (let ((mod (cons 'hygiene (module-name (current-module)))))
+      (map (lambda (x)
+             (wrap (gen-var 't) top-wrap mod))
+           ls)))
+
+  (define/override (free-identifier=? x y)
+    (arg-check nonsymbol-id? x 'free-identifier=?)
+    (arg-check nonsymbol-id? y 'free-identifier=?)
+    (free-id=? x y))
+
+  (define/override (bound-identifier=? x y)
+    (arg-check nonsymbol-id? x 'bound-identifier=?)
+    (arg-check nonsymbol-id? y 'bound-identifier=?)
+    (bound-id=? x y))
+
+  (define*/override (syntax-violation who message form #:optional subform)
+    (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+               who 'syntax-violation)
+    (arg-check string? message 'syntax-violation)
+    (throw 'syntax-error who message
+           (sourcev->alist
+            (or (source-annotation subform)
+                (source-annotation form)))
+           (strip form)
+           (strip subform)))
 
   (let ()
     (define (%syntax-module id)
@@ -2737,30 +2737,27 @@
     (define! 'syntax-local-binding syntax-local-binding)
     (define! 'syntax-locally-bound-identifiers 
syntax-locally-bound-identifiers))
   
-  ;; $sc-dispatch expects an expression and a pattern.  If the expression
-  ;; matches the pattern a list of the matching expressions for each
-  ;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
-  ;; not work on r4rs implementations that violate the ieee requirement
-  ;; that #f and () be distinct.)
-
-  ;; The expression is matched with the pattern as follows:
-
-  ;; pattern:                           matches:
-  ;;   ()                                 empty list
-  ;;   any                                anything
-  ;;   (<pattern>1 . <pattern>2)          (<pattern>1 . <pattern>2)
-  ;;   each-any                           (any*)
-  ;;   #(free-id <key>)                   <key> with free-identifier=?
-  ;;   #(each <pattern>)                  (<pattern>*)
-  ;;   #(each+ p1 (p2_1 ... p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
-  ;;   #(vector <pattern>)                (list->vector <pattern>)
-  ;;   #(atom <object>)                   <object> with "equal?"
-
-  ;; Vector cops out to pair under assumption that vectors are rare.  If
-  ;; not, should convert to:
-  ;;   #(vector <pattern>*)               #(<pattern>*)
-
-  (let ()
+  (define/override ($sc-dispatch e p)
+    ;; $sc-dispatch expects an expression and a pattern.  If the expression
+    ;; matches the pattern a list of the matching expressions for each
+    ;; "any" is returned.  Otherwise, #f is returned.
+
+    ;; The expression is matched with the pattern as follows:
+
+    ;; pattern:                           matches:
+    ;;   ()                                 empty list
+    ;;   any                                anything
+    ;;   (<pattern>1 . <pattern>2)          (<pattern>1 . <pattern>2)
+    ;;   each-any                           (any*)
+    ;;   #(free-id <key>)                   <key> with free-identifier=?
+    ;;   #(each <pattern>)                  (<pattern>*)
+    ;;   #(each+ p1 (p2_1 ... p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
+    ;;   #(vector <pattern>)                (list->vector <pattern>)
+    ;;   #(atom <object>)                   <object> with "equal?"
+
+    ;; Vector cops out to pair under assumption that vectors are rare.  If
+    ;; not, should convert to:
+    ;;   #(vector <pattern>*)               #(<pattern>*)
 
     (define (match-each e p w mod)
       (cond
@@ -2884,15 +2881,13 @@
          (or (syntax-module e) mod)))
        (else (match* e p w r mod))))
 
-    (set! $sc-dispatch
-          (lambda (e p)
-            (cond
-             ((eq? p 'any) (list e))
-             ((eq? p '_) '())
-             ((syntax? e)
-              (match* (syntax-expression e)
-                      p (syntax-wrap e) '() (syntax-module e)))
-             (else (match* e p empty-wrap '() #f)))))))
+    (cond
+     ((eq? p 'any) (list e))
+     ((eq? p '_) '())
+     ((syntax? e)
+      (match* (syntax-expression e)
+              p (syntax-wrap e) '() (syntax-module e)))
+     (else (match* e p empty-wrap '() #f)))))
 
 
 (define-syntax with-syntax



reply via email to

[Prev in Thread] Current Thread [Next in Thread]