guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] 01/03: psyntax: Fix bug introduced in 029540948367fe522f


From: Andy Wingo
Subject: [Guile-commits] 01/03: psyntax: Fix bug introduced in 029540948367fe522f9a105f403c12
Date: Mon, 18 Nov 2024 04:23:01 -0500 (EST)

wingo pushed a commit to branch main
in repository guile.

commit 14414655d32adb45bb7cef2be1b06d2e2adf2812
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Nov 18 10:07:50 2024 +0100

    psyntax: Fix bug introduced in 029540948367fe522f9a105f403c12
    
    * module/ice-9/psyntax.scm (analyze-variable): Fix erroneous pattern
    matching.
    * module/ice-9/psyntax-pp.scm: Regenerate.
---
 module/ice-9/psyntax-pp.scm | 114 +++++++++++++++++++++-----------------------
 module/ice-9/psyntax.scm    |   4 +-
 2 files changed, 57 insertions(+), 61 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index efb2ae5c4..fc29fd43e 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -82,16 +82,11 @@
                                                                 (let ((fk 
(lambda () (error "value failed to match" v))))
                                                                   (if (pair? v)
                                                                       (let 
((vx (car v)) (vy (cdr v)))
-                                                                        (if 
(eq? vx 'primitive.)
-                                                                            
(if (pair? vy)
-                                                                               
 (let ((vx (car vy)) (vy (cdr vy)))
-                                                                               
   (if (null? vy)
-                                                                               
       (syntax-violation
-                                                                               
        #f
-                                                                               
        "primitive not in operator position"
-                                                                               
        var)
-                                                                               
       (fk)))
-                                                                               
 (fk))
+                                                                        (if 
(eq? vx 'primitive)
+                                                                            
(syntax-violation
+                                                                             #f
+                                                                             
"primitive not in operator position"
+                                                                             
var)
                                                                             
(fk)))
                                                                       (fk))))))
                                                       (if (pair? v)
@@ -107,7 +102,7 @@
                                                                   (modref-cont 
mod var #f))))))
                                                   (if (eq? vx 'private)
                                                       (tk)
-                                                      (let* ((tk (lambda () 
(tk))) (hygiene vx)) (tk)))))
+                                                      (let ((tk (lambda () 
(tk)))) (if (eq? vx 'hygiene) (tk) (fk))))))
                                               (fk))))))
                               (if (pair? v)
                                   (let ((vx (car v)) (vy (cdr v)))
@@ -925,11 +920,11 @@
                                 (source-wrap e w (wrap-subst w) mod)
                                 x))
                               (else (decorate-source x))))))
-                 (let* ((t-680b775fb37a463-f33 transformer-environment)
-                        (t-680b775fb37a463-f34 (lambda (k) (k e r w s rib 
mod))))
+                 (let* ((t-680b775fb37a463-f2c transformer-environment)
+                        (t-680b775fb37a463-f2d (lambda (k) (k e r w s rib 
mod))))
                    (with-fluid*
-                    t-680b775fb37a463-f33
-                    t-680b775fb37a463-f34
+                    t-680b775fb37a463-f2c
+                    t-680b775fb37a463-f2d
                     (lambda () (rebuild-macro-output (p (source-wrap e 
(anti-mark w) s mod)) (new-mark))))))))
             (expand-body
              (lambda (body outer-form r w mod)
@@ -1459,11 +1454,11 @@
                                                 s
                                                 mod
                                                 get-formals
-                                                (map (lambda 
(tmp-680b775fb37a463-11a1
-                                                              
tmp-680b775fb37a463-11a0
-                                                              
tmp-680b775fb37a463-119f)
-                                                       (cons 
tmp-680b775fb37a463-119f
-                                                             (cons 
tmp-680b775fb37a463-11a0 tmp-680b775fb37a463-11a1)))
+                                                (map (lambda 
(tmp-680b775fb37a463-119a
+                                                              
tmp-680b775fb37a463-1
+                                                              
tmp-680b775fb37a463)
+                                                       (cons 
tmp-680b775fb37a463
+                                                             (cons 
tmp-680b775fb37a463-1 tmp-680b775fb37a463-119a)))
                                                      e2*
                                                      e1*
                                                      args*)))
@@ -2558,9 +2553,9 @@
                            #f
                            k
                            '()
-                           (map (lambda (tmp-680b775fb37a463-12bc 
tmp-680b775fb37a463-12bb tmp-680b775fb37a463-12ba)
-                                  (list (cons tmp-680b775fb37a463-12ba 
tmp-680b775fb37a463-12bb)
-                                        tmp-680b775fb37a463-12bc))
+                           (map (lambda (tmp-680b775fb37a463-12b5 
tmp-680b775fb37a463-12b4 tmp-680b775fb37a463-12b3)
+                                  (list (cons tmp-680b775fb37a463-12b3 
tmp-680b775fb37a463-12b4)
+                                        tmp-680b775fb37a463-12b5))
                                 template
                                 pattern
                                 keyword)))
@@ -2575,11 +2570,11 @@
                                  #f
                                  k
                                  (list docstring)
-                                 (map (lambda (tmp-680b775fb37a463-12d5
-                                               tmp-680b775fb37a463-12d4
-                                               tmp-680b775fb37a463-12d3)
-                                        (list (cons tmp-680b775fb37a463-12d3 
tmp-680b775fb37a463-12d4)
-                                              tmp-680b775fb37a463-12d5))
+                                 (map (lambda (tmp-680b775fb37a463-12ce
+                                               tmp-680b775fb37a463-12cd
+                                               tmp-680b775fb37a463-12cc)
+                                        (list (cons tmp-680b775fb37a463-12cc 
tmp-680b775fb37a463-12cd)
+                                              tmp-680b775fb37a463-12ce))
                                       template
                                       pattern
                                       keyword)))
@@ -2591,11 +2586,11 @@
                                        dots
                                        k
                                        '()
-                                       (map (lambda (tmp-680b775fb37a463-12ee
-                                                     tmp-680b775fb37a463-12ed
-                                                     tmp-680b775fb37a463-12ec)
-                                              (list (cons 
tmp-680b775fb37a463-12ec tmp-680b775fb37a463-12ed)
-                                                    tmp-680b775fb37a463-12ee))
+                                       (map (lambda (tmp-680b775fb37a463-12e7
+                                                     tmp-680b775fb37a463-12e6
+                                                     tmp-680b775fb37a463-12e5)
+                                              (list (cons 
tmp-680b775fb37a463-12e5 tmp-680b775fb37a463-12e6)
+                                                    tmp-680b775fb37a463-12e7))
                                             template
                                             pattern
                                             keyword)))
@@ -2611,11 +2606,11 @@
                                              dots
                                              k
                                              (list docstring)
-                                             (map (lambda 
(tmp-680b775fb37a463-130d
-                                                           
tmp-680b775fb37a463-130c
-                                                           
tmp-680b775fb37a463-130b)
-                                                    (list (cons 
tmp-680b775fb37a463-130b tmp-680b775fb37a463-130c)
-                                                          
tmp-680b775fb37a463-130d))
+                                             (map (lambda 
(tmp-680b775fb37a463-2
+                                                           
tmp-680b775fb37a463-1
+                                                           tmp-680b775fb37a463)
+                                                    (list (cons 
tmp-680b775fb37a463 tmp-680b775fb37a463-1)
+                                                          
tmp-680b775fb37a463-2))
                                                   template
                                                   pattern
                                                   keyword)))
@@ -2743,9 +2738,9 @@
                                                              (apply (lambda (p)
                                                                       (if (= 
lev 0)
                                                                           
(quasilist*
-                                                                           
(map (lambda (tmp-680b775fb37a463-13ba)
+                                                                           
(map (lambda (tmp-680b775fb37a463-13b3)
                                                                                
   (list "value"
-                                                                               
         tmp-680b775fb37a463-13ba))
+                                                                               
         tmp-680b775fb37a463-13b3))
                                                                                
 p)
                                                                            
(quasi q lev))
                                                                           
(quasicons
@@ -2771,9 +2766,9 @@
                                                                    (apply 
(lambda (p)
                                                                             
(if (= lev 0)
                                                                                
 (quasiappend
-                                                                               
  (map (lambda (tmp-680b775fb37a463-13bf)
+                                                                               
  (map (lambda (tmp-680b775fb37a463-13b8)
                                                                                
         (list "value"
-                                                                               
               tmp-680b775fb37a463-13bf))
+                                                                               
               tmp-680b775fb37a463-13b8))
                                                                                
       p)
                                                                                
  (quasi q lev))
                                                                                
 (quasicons
@@ -2809,8 +2804,8 @@
                                            (apply (lambda (p)
                                                     (if (= lev 0)
                                                         (quasilist*
-                                                         (map (lambda 
(tmp-680b775fb37a463-13d5)
-                                                                (list "value" 
tmp-680b775fb37a463-13d5))
+                                                         (map (lambda 
(tmp-680b775fb37a463-13ce)
+                                                                (list "value" 
tmp-680b775fb37a463-13ce))
                                                               p)
                                                          (vquasi q lev))
                                                         (quasicons
@@ -2830,8 +2825,8 @@
                                                  (apply (lambda (p)
                                                           (if (= lev 0)
                                                               (quasiappend
-                                                               (map (lambda 
(tmp-680b775fb37a463-13da)
-                                                                      (list 
"value" tmp-680b775fb37a463-13da))
+                                                               (map (lambda 
(tmp-680b775fb37a463-13d3)
+                                                                      (list 
"value" tmp-680b775fb37a463-13d3))
                                                                     p)
                                                                (vquasi q lev))
                                                               (quasicons
@@ -2913,7 +2908,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-141c)
+                                                        (cons "vector" 
t-680b775fb37a463-141c))
                                                       tmp)
                                                (syntax-violation
                                                 #f
@@ -2923,8 +2919,7 @@
                               (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") 
each-any))))
                                 (if tmp-1
                                     (apply (lambda (y)
-                                             (k (map (lambda 
(tmp-680b775fb37a463-142f)
-                                                       (list "quote" 
tmp-680b775fb37a463-142f))
+                                             (k (map (lambda 
(tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
                                                      y)))
                                            tmp-1)
                                     (let ((tmp-1 ($sc-dispatch tmp '(#(atom 
"list") . each-any))))
@@ -2935,8 +2930,8 @@
                                                 (apply (lambda (y z) (f z 
(lambda (ls) (k (append y ls))))) tmp-1)
                                                 (let ((else tmp))
                                                   (let ((tmp x))
-                                                    (let 
((t-680b775fb37a463-143e tmp))
-                                                      (list "list->vector" 
t-680b775fb37a463-143e)))))))))))))))))
+                                                    (let ((t-680b775fb37a463 
tmp))
+                                                      (list "list->vector" 
t-680b775fb37a463)))))))))))))))))
                (emit (lambda (x)
                        (let ((tmp x))
                          (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") 
any))))
@@ -2948,9 +2943,9 @@
                                               (let ((tmp-1 (map emit x)))
                                                 (let ((tmp ($sc-dispatch tmp-1 
'each-any)))
                                                   (if tmp
-                                                      (apply (lambda 
(t-680b775fb37a463-144d)
+                                                      (apply (lambda 
(t-680b775fb37a463)
                                                                (cons 
(make-syntax 'list '((top)) '(hygiene guile))
-                                                                     
t-680b775fb37a463-144d))
+                                                                     
t-680b775fb37a463))
                                                              tmp)
                                                       (syntax-violation
                                                        #f
@@ -2966,12 +2961,13 @@
                                                           (let ((tmp-1 (list 
(emit (car x*)) (f (cdr x*)))))
                                                             (let ((tmp 
($sc-dispatch tmp-1 '(any any))))
                                                               (if tmp
-                                                                  (apply 
(lambda (t-680b775fb37a463-1 t-680b775fb37a463)
+                                                                  (apply 
(lambda (t-680b775fb37a463-145a
+                                                                               
   t-680b775fb37a463)
                                                                            
(list (make-syntax
                                                                                
   'cons
                                                                                
   '((top))
                                                                                
   '(hygiene guile))
-                                                                               
  t-680b775fb37a463-1
+                                                                               
  t-680b775fb37a463-145a
                                                                                
  t-680b775fb37a463))
                                                                          tmp)
                                                                   
(syntax-violation
@@ -2985,12 +2981,12 @@
                                                           (let ((tmp-1 (map 
emit x)))
                                                             (let ((tmp 
($sc-dispatch tmp-1 'each-any)))
                                                               (if tmp
-                                                                  (apply 
(lambda (t-680b775fb37a463-146d)
+                                                                  (apply 
(lambda (t-680b775fb37a463)
                                                                            
(cons (make-syntax
                                                                                
   'append
                                                                                
   '((top))
                                                                                
   '(hygiene guile))
-                                                                               
  t-680b775fb37a463-146d))
+                                                                               
  t-680b775fb37a463))
                                                                          tmp)
                                                                   
(syntax-violation
                                                                    #f
@@ -3019,12 +3015,12 @@
                                                          (if tmp-1
                                                              (apply (lambda (x)
                                                                       (let 
((tmp (emit x)))
-                                                                        (let 
((t-680b775fb37a463 tmp))
+                                                                        (let 
((t-680b775fb37a463-147e tmp))
                                                                           
(list (make-syntax
                                                                                
  'list->vector
                                                                                
  '((top))
                                                                                
  '(hygiene guile))
-                                                                               
 t-680b775fb37a463))))
+                                                                               
 t-680b775fb37a463-147e))))
                                                                     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 bb71dc585..65dc3dc58 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -224,12 +224,12 @@
     (match mod
       (#f (bare-cont #f var))
       (('public . mod) (modref-cont mod var #t))
-      (((or 'private hygiene) . mod)
+      (((or 'private 'hygiene) . mod)
        (if (equal? mod (module-name (current-module)))
            (bare-cont mod var)
            (modref-cont mod var #f)))
       (('bare . _) (bare-cont var))
-      (('primitive. _)
+      (('primitive . _)
        (syntax-violation #f "primitive not in operator position" var))))
 
   (define (build-global-reference sourcev var mod)



reply via email to

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