[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)