[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 09/09: psyntax: simplify free-id=?
From: |
Andy Wingo |
Subject: |
[Guile-commits] 09/09: psyntax: simplify free-id=? |
Date: |
Mon, 25 Nov 2024 05:47:45 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit c51fcfffb6743832f64ad2213e9f5d8bb09608a1
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Nov 25 11:46:58 2024 +0100
psyntax: simplify free-id=?
* module/ice-9/psyntax.scm (free-id=?): Simplify.
* module/ice-9/psyntax-pp.scm: Regenerate.
---
module/ice-9/psyntax-pp.scm | 121 ++++++++++++++++++++++----------------------
module/ice-9/psyntax.scm | 10 ++--
2 files changed, 65 insertions(+), 66 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 875a0af07..ab5590f0e 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -677,9 +677,8 @@
((syntax? nj) (free-id=? i nj))
((symbol? ni)
(and (eq? nj (id-sym-name j))
- (let ((bi (id-module-binding i mi)))
- (if bi (eq? bi (id-module-binding j mj)) (and
(not (id-module-binding j mj)) (eq? ni nj))))
- (eq? (id-module-binding i mi) (id-module-binding j
mj))))
+ (let ((bi (id-module-binding i mi)) (bj
(id-module-binding j mj)))
+ (and (eq? bi bj) (or bi (eq? ni nj))))))
(else (equal? ni nj)))))))
(bound-id=?
(lambda (i j)
@@ -1196,11 +1195,11 @@
(source-wrap e w (wrap-subst w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-cbb transformer-environment)
- (t-680b775fb37a463-cbc (lambda (k) (k e r w s rib
mod))))
+ (let* ((t-680b775fb37a463-cc0 transformer-environment)
+ (t-680b775fb37a463-cc1 (lambda (k) (k e r w s rib
mod))))
(with-fluid*
- t-680b775fb37a463-cbb
- t-680b775fb37a463-cbc
+ t-680b775fb37a463-cc0
+ t-680b775fb37a463-cc1
(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 +1730,11 @@
s
mod
get-formals
- (map (lambda
(tmp-680b775fb37a463-f44
-
tmp-680b775fb37a463-f43
-
tmp-680b775fb37a463-f42)
- (cons
tmp-680b775fb37a463-f42
- (cons
tmp-680b775fb37a463-f43 tmp-680b775fb37a463-f44)))
+ (map (lambda
(tmp-680b775fb37a463-f49
+
tmp-680b775fb37a463-f48
+
tmp-680b775fb37a463-f47)
+ (cons
tmp-680b775fb37a463-f47
+ (cons
tmp-680b775fb37a463-f48 tmp-680b775fb37a463-f49)))
e2*
e1*
args*)))
@@ -2008,11 +2007,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-11a9
- tmp-680b775fb37a463-11a8
- tmp-680b775fb37a463-11a7)
- (cons tmp-680b775fb37a463-11a7
- (cons tmp-680b775fb37a463-11a8
tmp-680b775fb37a463-11a9)))
+ (map (lambda (tmp-680b775fb37a463-11ae
+ tmp-680b775fb37a463-11ad
+ tmp-680b775fb37a463-11ac)
+ (cons tmp-680b775fb37a463-11ac
+ (cons tmp-680b775fb37a463-11ad
tmp-680b775fb37a463-11ae)))
e2
e1
args)))
@@ -2022,11 +2021,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation
(syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-11bf
- tmp-680b775fb37a463-11be
- tmp-680b775fb37a463-11bd)
- (cons tmp-680b775fb37a463-11bd
- (cons
tmp-680b775fb37a463-11be tmp-680b775fb37a463-11bf)))
+ (map (lambda (tmp-680b775fb37a463-11c4
+ tmp-680b775fb37a463-11c3
+ tmp-680b775fb37a463-11c2)
+ (cons tmp-680b775fb37a463-11c2
+ (cons
tmp-680b775fb37a463-11c3 tmp-680b775fb37a463-11c4)))
e2
e1
args)))
@@ -2044,11 +2043,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-11df
- tmp-680b775fb37a463-11de
- tmp-680b775fb37a463-11dd)
- (cons tmp-680b775fb37a463-11dd
- (cons tmp-680b775fb37a463-11de
tmp-680b775fb37a463-11df)))
+ (map (lambda (tmp-680b775fb37a463-11e4
+ tmp-680b775fb37a463-11e3
+ tmp-680b775fb37a463-11e2)
+ (cons tmp-680b775fb37a463-11e2
+ (cons tmp-680b775fb37a463-11e3
tmp-680b775fb37a463-11e4)))
e2
e1
args)))
@@ -2058,11 +2057,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation
(syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-11f5
- tmp-680b775fb37a463-11f4
- tmp-680b775fb37a463-11f3)
- (cons tmp-680b775fb37a463-11f3
- (cons
tmp-680b775fb37a463-11f4 tmp-680b775fb37a463-11f5)))
+ (map (lambda (tmp-680b775fb37a463-11fa
+ tmp-680b775fb37a463-11f9
+ tmp-680b775fb37a463-11f8)
+ (cons tmp-680b775fb37a463-11f8
+ (cons
tmp-680b775fb37a463-11f9 tmp-680b775fb37a463-11fa)))
e2
e1
args)))
@@ -2885,9 +2884,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-14d3
tmp-680b775fb37a463-14d2 tmp-680b775fb37a463-14d1)
- (list (cons tmp-680b775fb37a463-14d1
tmp-680b775fb37a463-14d2)
- tmp-680b775fb37a463-14d3))
+ (map (lambda (tmp-680b775fb37a463-14d8
tmp-680b775fb37a463-14d7 tmp-680b775fb37a463-14d6)
+ (list (cons tmp-680b775fb37a463-14d6
tmp-680b775fb37a463-14d7)
+ tmp-680b775fb37a463-14d8))
template
pattern
keyword)))
@@ -2902,11 +2901,11 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-14ec
- tmp-680b775fb37a463-14eb
- tmp-680b775fb37a463-14ea)
- (list (cons tmp-680b775fb37a463-14ea
tmp-680b775fb37a463-14eb)
- tmp-680b775fb37a463-14ec))
+ (map (lambda (tmp-680b775fb37a463-14f1
+ tmp-680b775fb37a463-14f0
+ tmp-680b775fb37a463-14ef)
+ (list (cons tmp-680b775fb37a463-14ef
tmp-680b775fb37a463-14f0)
+ tmp-680b775fb37a463-14f1))
template
pattern
keyword)))
@@ -2918,9 +2917,9 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (map (lambda (tmp-680b775fb37a463-150a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-2))
+ tmp-680b775fb37a463-150a))
template
pattern
keyword)))
@@ -3068,9 +3067,9 @@
(apply (lambda (p)
(if (=
lev 0)
(quasilist*
-
(map (lambda (tmp-680b775fb37a463-15d1)
+
(map (lambda (tmp-680b775fb37a463-15d6)
(list "value"
-
tmp-680b775fb37a463-15d1))
+
tmp-680b775fb37a463-15d6))
p)
(quasi q lev))
(quasicons
@@ -3096,9 +3095,9 @@
(apply
(lambda (p)
(if (= lev 0)
(quasiappend
-
(map (lambda (tmp-680b775fb37a463-15d6)
+
(map (lambda (tmp-680b775fb37a463-15db)
(list "value"
-
tmp-680b775fb37a463-15d6))
+
tmp-680b775fb37a463-15db))
p)
(quasi q lev))
(quasicons
@@ -3134,8 +3133,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-15ec)
- (list "value"
tmp-680b775fb37a463-15ec))
+ (map (lambda
(tmp-680b775fb37a463-15f1)
+ (list "value"
tmp-680b775fb37a463-15f1))
p)
(vquasi q lev))
(quasicons
@@ -3155,8 +3154,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-15f1)
- (list
"value" tmp-680b775fb37a463-15f1))
+ (map (lambda
(tmp-680b775fb37a463-15f6)
+ (list
"value" tmp-680b775fb37a463-15f6))
p)
(vquasi q lev))
(quasicons
@@ -3238,8 +3237,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-163a)
- (cons "vector"
t-680b775fb37a463-163a))
+ (apply (lambda
(t-680b775fb37a463-163f)
+ (cons "vector"
t-680b775fb37a463-163f))
tmp)
(syntax-violation
#f
@@ -3249,7 +3248,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda
(tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
+ (k (map (lambda
(tmp-680b775fb37a463-164b)
+ (list "quote"
tmp-680b775fb37a463-164b))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom
"list") . each-any))))
@@ -3260,8 +3260,8 @@
(apply (lambda (y z) (f z
(lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp))
(let ((tmp x))
- (let ((t-680b775fb37a463
tmp))
- (list "list->vector"
t-680b775fb37a463)))))))))))))))))
+ (let
((t-680b775fb37a463-165a tmp))
+ (list "list->vector"
t-680b775fb37a463-165a)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
any))))
@@ -3291,13 +3291,14 @@
(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-167d
+
t-680b775fb37a463-167c)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
-
t-680b775fb37a463-1
-
t-680b775fb37a463))
+
t-680b775fb37a463-167d
+
t-680b775fb37a463-167c))
tmp)
(syntax-violation
#f
@@ -3344,12 +3345,12 @@
(if tmp-1
(apply (lambda (x)
(let
((tmp (emit x)))
- (let
((t-680b775fb37a463-169c tmp))
+ (let
((t-680b775fb37a463-16a1 tmp))
(list (make-syntax
'list->vector
'((top))
'(hygiene guile))
-
t-680b775fb37a463-169c))))
+
t-680b775fb37a463-16a1))))
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 2911e96ea..4a4d6a4c6 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -846,12 +846,10 @@
;; bound to the same variable, or both unbound and have
;; the same name.
(and (eq? nj (id-sym-name j))
- (let ((bi (id-module-binding i mi)))
- (if bi
- (eq? bi (id-module-binding j mj))
- (and (not (id-module-binding j mj))
- (eq? ni nj))))
- (eq? (id-module-binding i mi) (id-module-binding j mj))))
+ (let ((bi (id-module-binding i mi))
+ (bj (id-module-binding j mj)))
+ (and (eq? bi bj)
+ (or bi (eq? ni nj))))))
(else
;; Otherwise `i' is bound, so check that `j' is bound, and
;; bound to the same thing.
- [Guile-commits] branch main updated (cdf8473b1 -> c51fcfffb), Andy Wingo, 2024/11/25
- [Guile-commits] 02/09: psyntax: Factor module-variable use to helpers, Andy Wingo, 2024/11/25
- [Guile-commits] 05/09: psyntax: Cosmetic change, Andy Wingo, 2024/11/25
- [Guile-commits] 08/09: psyntax: Cosmetic change to overriden globals, Andy Wingo, 2024/11/25
- [Guile-commits] 09/09: psyntax: simplify free-id=?,
Andy Wingo <=
- [Guile-commits] 07/09: psyntax: Reorder global-extend, Andy Wingo, 2024/11/25
- [Guile-commits] 06/09: psyntax: Typo fix, Andy Wingo, 2024/11/25
- [Guile-commits] 04/09: psyntax: Clean up sourcev/src namings, Andy Wingo, 2024/11/25
- [Guile-commits] 01/09: psyntax: Remove stale analyze-variable case, Andy Wingo, 2024/11/25
- [Guile-commits] 03/09: psyntax: Simplify output constructors., Andy Wingo, 2024/11/25