guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] 02/03: psyntax: Simplify id-var-name


From: Andy Wingo
Subject: [Guile-commits] 02/03: psyntax: Simplify id-var-name
Date: Mon, 18 Nov 2024 04:23:01 -0500 (EST)

wingo pushed a commit to branch main
in repository guile.

commit 54c8901adc28c424c80b8a2b444510c3a65d46ac
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Mon Nov 18 09:48:09 2024 +0100

    psyntax: Simplify id-var-name
    
    * module/ice-9/psyntax.scm (id-var-name): No need for `search` to return
    the marks.  Simplify to use scope instead of repeating, and use match.
    * module/ice-9/psyntax-pp.scm: Regenerate.
---
 module/ice-9/psyntax-pp.scm | 304 +++++++++++++++++++++++++++++---------------
 module/ice-9/psyntax.scm    | 110 ++++++++--------
 2 files changed, 255 insertions(+), 159 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index fc29fd43e..509f29d5e 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -261,6 +261,7 @@
              (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)))
             (id-sym-name&marks
              (lambda (x w)
                (if (syntax? x)
@@ -346,52 +347,154 @@
             (id-var-name
              (lambda (id w mod)
                (letrec* ((search
-                          (lambda (sym subst marks mod)
-                            (if (null? subst)
-                                (values #f marks)
-                                (let ((fst (car subst)))
-                                  (if (eq? fst 'shift)
-                                      (search sym (cdr subst) (cdr marks) mod)
-                                      (let ((symnames (ribcage-symnames fst)))
-                                        (if (vector? symnames)
-                                            (search-vector-rib sym subst marks 
symnames fst mod)
-                                            (search-list-rib sym subst marks 
symnames fst mod))))))))
-                         (search-list-rib
-                          (lambda (sym subst marks symnames ribcage mod)
-                            (let f ((symnames symnames)
-                                    (rlabels (ribcage-labels ribcage))
-                                    (rmarks (ribcage-marks ribcage)))
-                              (cond
-                                ((null? symnames) (search sym (cdr subst) 
marks mod))
-                                ((and (eq? (car symnames) sym) (same-marks? 
marks (car rmarks)))
-                                 (let ((n (car rlabels)))
-                                   (if (pair? n)
-                                       (if (equal? mod (car n))
-                                           (values (cdr n) marks)
-                                           (f (cdr symnames) (cdr rlabels) 
(cdr rmarks)))
-                                       (values n marks))))
-                                (else (f (cdr symnames) (cdr rlabels) (cdr 
rmarks)))))))
-                         (search-vector-rib
-                          (lambda (sym subst marks symnames ribcage mod)
-                            (let ((n (vector-length symnames)))
-                              (let f ((i 0))
-                                (cond
-                                  ((= i n) (search sym (cdr subst) marks mod))
-                                  ((and (eq? (vector-ref symnames i) sym)
-                                        (same-marks? marks (vector-ref 
(ribcage-marks ribcage) i)))
-                                   (let ((n (vector-ref (ribcage-labels 
ribcage) i)))
-                                     (if (pair? n)
-                                         (if (equal? mod (car n)) (values (cdr 
n) marks) (f (#{1+}# i)))
-                                         (values n marks))))
-                                  (else (f (#{1+}# i)))))))))
+                          (lambda (sym subst marks)
+                            (let* ((v subst)
+                                   (fk (lambda ()
+                                         (let ((fk (lambda ()
+                                                     (let ((fk (lambda () 
(error "value failed to match" v))))
+                                                       (if (pair? v)
+                                                           (let ((vx (car v)) 
(vy (cdr v)))
+                                                             (if (and (vector? 
vx)
+                                                                      (eq? 
(vector-length vx)
+                                                                           
(length '('ribcage rsymnames rmarks rlabels))))
+                                                                 (if (eq? 
(vector-ref vx 0) 'ribcage)
+                                                                     (let* 
((rsymnames (vector-ref vx (#{1+}# 0)))
+                                                                            
(rmarks (vector-ref vx (#{1+}# (#{1+}# 0))))
+                                                                            
(rlabels
+                                                                             
(vector-ref
+                                                                              
vx
+                                                                              
(#{1+}# (#{1+}# (#{1+}# 0)))))
+                                                                            
(subst vy))
+                                                                       
(letrec* ((search-list-rib
+                                                                               
   (lambda ()
+                                                                               
     (let lp ((rsymnames rsymnames)
+                                                                               
              (rmarks rmarks)
+                                                                               
              (rlabels rlabels))
+                                                                               
       (let* ((v rsymnames)
+                                                                               
              (fk (lambda ()
+                                                                               
                    (let ((fk (lambda ()
+                                                                               
                                (error "value failed to match"
+                                                                               
                                       v))))
+                                                                               
                      (if (pair? v)
+                                                                               
                          (let ((vx (car v))
+                                                                               
                                (vy (cdr v)))
+                                                                               
                            (let* ((rsym vx)
+                                                                               
                                   (rsymnames
+                                                                               
                                    vy)
+                                                                               
                                   (v rmarks)
+                                                                               
                                   (fk (lambda ()
+                                                                               
                                         (error "value failed to match"
+                                                                               
                                                v))))
+                                                                               
                              (if (pair? v)
+                                                                               
                                  (let ((vx (car v))
+                                                                               
                                        (vy (cdr v)))
+                                                                               
                                    (let* ((rmarks1
+                                                                               
                                            vx)
+                                                                               
                                           (rmarks
+                                                                               
                                            vy)
+                                                                               
                                           (v rlabels)
+                                                                               
                                           (fk (lambda ()
+                                                                               
                                                 (error "value failed to match"
+                                                                               
                                                        v))))
+                                                                               
                                      (if (pair? v)
+                                                                               
                                          (let ((vx (car v))
+                                                                               
                                                (vy (cdr v)))
+                                                                               
                                            (let* ((label vx)
+                                                                               
                                                   (rlabels
+                                                                               
                                                    vy))
+                                                                               
                                              (if (and (eq? sym
+                                                                               
                                                            rsym)
+                                                                               
                                                       (same-marks?
+                                                                               
                                                        marks
+                                                                               
                                                        rmarks1))
+                                                                               
                                                  (let* ((v label)
+                                                                               
                                                         (fk (lambda ()
+                                                                               
                                                               (let ((fk 
(lambda ()
+                                                                               
                                                                           
(error "value failed to match"
+                                                                               
                                                                                
  v))))
+                                                                               
                                                                 label))))
+                                                                               
                                                    (if (pair? v)
+                                                                               
                                                        (let ((vx (car v))
+                                                                               
                                                              (vy (cdr v)))
+                                                                               
                                                          (let* ((mod* vx)
+                                                                               
                                                                 (label vy))
+                                                                               
                                                            (if (equal?
+                                                                               
                                                                 mod*
+                                                                               
                                                                 mod)
+                                                                               
                                                                label
+                                                                               
                                                                (lp rsymnames
+                                                                               
                                                                    rmarks
+                                                                               
                                                                    rlabels))))
+                                                                               
                                                        (fk)))
+                                                                               
                                                  (lp rsymnames
+                                                                               
                                                      rmarks
+                                                                               
                                                      rlabels))))
+                                                                               
                                          (fk))))
+                                                                               
                                  (fk))))
+                                                                               
                          (fk))))))
+                                                                               
         (if (null? v)
+                                                                               
             (search sym subst marks)
+                                                                               
             (fk))))))
+                                                                               
  (search-vector-rib
+                                                                               
   (lambda ()
+                                                                               
     (let ((n (vector-length rsymnames)))
+                                                                               
       (let lp ((i 0))
+                                                                               
         (cond
+                                                                               
           ((= i n)
+                                                                               
            (search sym subst marks))
+                                                                               
           ((and (eq? (vector-ref
+                                                                               
                       rsymnames
+                                                                               
                       i)
+                                                                               
                      sym)
+                                                                               
                 (same-marks?
+                                                                               
                  marks
+                                                                               
                  (vector-ref rmarks i)))
+                                                                               
            (let* ((v (vector-ref
+                                                                               
                       rlabels
+                                                                               
                       i))
+                                                                               
                   (fk (lambda ()
+                                                                               
                         (let* ((fk (lambda ()
+                                                                               
                                      (error "value failed to match"
+                                                                               
                                             v)))
+                                                                               
                                (label v))
+                                                                               
                           label))))
+                                                                               
              (if (pair? v)
+                                                                               
                  (let ((vx (car v))
+                                                                               
                        (vy (cdr v)))
+                                                                               
                    (let* ((mod* vx)
+                                                                               
                           (label vy))
+                                                                               
                      (if (equal?
+                                                                               
                           mod*
+                                                                               
                           mod)
+                                                                               
                          label
+                                                                               
                          (lp (#{1+}# i)))))
+                                                                               
                  (fk))))
+                                                                               
           (else (lp (#{1+}# i)))))))))
+                                                                         (if 
(vector? rsymnames)
+                                                                             
(search-vector-rib)
+                                                                             
(search-list-rib))))
+                                                                     (fk))
+                                                                 (fk)))
+                                                           (fk))))))
+                                           (if (pair? v)
+                                               (let ((vx (car v)) (vy (cdr v)))
+                                                 (if (eq? vx 'shift)
+                                                     (let* ((subst vy)
+                                                            (v marks)
+                                                            (fk (lambda () 
(error "value failed to match" v))))
+                                                       (if (pair? v)
+                                                           (let ((vx (car v)) 
(vy (cdr v)))
+                                                             (let ((marks vy)) 
(search sym subst marks)))
+                                                           (fk)))
+                                                     (fk)))
+                                               (fk))))))
+                              (if (null? v) #f (fk))))))
                  (cond
-                   ((symbol? id) (or (search id (wrap-subst w) (wrap-marks w) 
mod) id))
+                   ((symbol? id) (or (search id (wrap-subst w) (wrap-marks w)) 
id))
                    ((syntax? id)
                     (let ((id (syntax-expression id)) (w1 (syntax-wrap id)) 
(mod (or (syntax-module id) mod)))
                       (let ((marks (join-marks (wrap-marks w) (wrap-marks 
w1))))
-                        (call-with-values
-                         (lambda () (search id (wrap-subst w) marks mod))
-                         (lambda (new-id marks) (or new-id (search id 
(wrap-subst w1) marks mod) id))))))
+                        (or (search id (wrap-subst w) marks) (search id 
(wrap-subst w1) marks) id))))
                    (else (syntax-violation 'id-var-name "invalid id" id))))))
             (locally-bound-identifiers
              (lambda (w mod)
@@ -480,14 +583,12 @@
                       (nj (id-var-name j empty-wrap mj)))
                  (letrec* ((id-module-binding
                             (lambda (id mod)
-                              (module-variable
-                               (if mod (resolve-module (cdr mod)) 
(current-module))
-                               (let ((x id)) (if (syntax? x) 
(syntax-expression x) x))))))
+                              (module-variable (if mod (resolve-module (cdr 
mod)) (current-module)) (id-sym-name id)))))
                    (cond
                      ((syntax? ni) (free-id=? ni j))
                      ((syntax? nj) (free-id=? i nj))
                      ((symbol? ni)
-                      (and (eq? nj (let ((x j)) (if (syntax? x) 
(syntax-expression x) x)))
+                      (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))))
@@ -920,11 +1021,11 @@
                                 (source-wrap e w (wrap-subst w) mod)
                                 x))
                               (else (decorate-source x))))))
-                 (let* ((t-680b775fb37a463-f2c transformer-environment)
-                        (t-680b775fb37a463-f2d (lambda (k) (k e r w s rib 
mod))))
+                 (let* ((t-680b775fb37a463-fa5 transformer-environment)
+                        (t-680b775fb37a463-fa6 (lambda (k) (k e r w s rib 
mod))))
                    (with-fluid*
-                    t-680b775fb37a463-f2c
-                    t-680b775fb37a463-f2d
+                    t-680b775fb37a463-fa5
+                    t-680b775fb37a463-fa6
                     (lambda () (rebuild-macro-output (p (source-wrap e 
(anti-mark w) s mod)) (new-mark))))))))
             (expand-body
              (lambda (body outer-form r w mod)
@@ -1454,11 +1555,11 @@
                                                 s
                                                 mod
                                                 get-formals
-                                                (map (lambda 
(tmp-680b775fb37a463-119a
+                                                (map (lambda 
(tmp-680b775fb37a463-2
                                                               
tmp-680b775fb37a463-1
                                                               
tmp-680b775fb37a463)
                                                        (cons 
tmp-680b775fb37a463
-                                                             (cons 
tmp-680b775fb37a463-1 tmp-680b775fb37a463-119a)))
+                                                             (cons 
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
                                                      e2*
                                                      e1*
                                                      args*)))
@@ -1726,8 +1827,8 @@
                (apply (lambda (args e1 e2)
                         (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-6be 
tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6bc)
-                                (cons tmp-680b775fb37a463-6bc (cons 
tmp-680b775fb37a463-6bd tmp-680b775fb37a463-6be)))
+                         (map (lambda (tmp-680b775fb37a463-6bf 
tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bd)
+                                (cons tmp-680b775fb37a463-6bd (cons 
tmp-680b775fb37a463-6be tmp-680b775fb37a463-6bf)))
                               e2
                               e1
                               args)))
@@ -1737,9 +1838,9 @@
                      (apply (lambda (docstring args e1 e2)
                               (build-it
                                (list (cons 'documentation (syntax->datum 
docstring)))
-                               (map (lambda (tmp-680b775fb37a463-6d4 
tmp-680b775fb37a463-6d3 tmp-680b775fb37a463-6d2)
-                                      (cons tmp-680b775fb37a463-6d2
-                                            (cons tmp-680b775fb37a463-6d3 
tmp-680b775fb37a463-6d4)))
+                               (map (lambda (tmp-680b775fb37a463-6d5 
tmp-680b775fb37a463-6d4 tmp-680b775fb37a463-6d3)
+                                      (cons tmp-680b775fb37a463-6d3
+                                            (cons tmp-680b775fb37a463-6d4 
tmp-680b775fb37a463-6d5)))
                                     e2
                                     e1
                                     args)))
@@ -1770,9 +1871,9 @@
                      (apply (lambda (docstring args e1 e2)
                               (build-it
                                (list (cons 'documentation (syntax->datum 
docstring)))
-                               (map (lambda (tmp-680b775fb37a463-69e 
tmp-680b775fb37a463-69d tmp-680b775fb37a463-69c)
-                                      (cons tmp-680b775fb37a463-69c
-                                            (cons tmp-680b775fb37a463-69d 
tmp-680b775fb37a463-69e)))
+                               (map (lambda (tmp-680b775fb37a463-69f 
tmp-680b775fb37a463-69e tmp-680b775fb37a463-69d)
+                                      (cons tmp-680b775fb37a463-69d
+                                            (cons tmp-680b775fb37a463-69e 
tmp-680b775fb37a463-69f)))
                                     e2
                                     e1
                                     args)))
@@ -2553,9 +2654,9 @@
                            #f
                            k
                            '()
-                           (map (lambda (tmp-680b775fb37a463-12b5 
tmp-680b775fb37a463-12b4 tmp-680b775fb37a463-12b3)
-                                  (list (cons tmp-680b775fb37a463-12b3 
tmp-680b775fb37a463-12b4)
-                                        tmp-680b775fb37a463-12b5))
+                           (map (lambda (tmp-680b775fb37a463-132e 
tmp-680b775fb37a463-132d tmp-680b775fb37a463-132c)
+                                  (list (cons tmp-680b775fb37a463-132c 
tmp-680b775fb37a463-132d)
+                                        tmp-680b775fb37a463-132e))
                                 template
                                 pattern
                                 keyword)))
@@ -2570,11 +2671,8 @@
                                  #f
                                  k
                                  (list docstring)
-                                 (map (lambda (tmp-680b775fb37a463-12ce
-                                               tmp-680b775fb37a463-12cd
-                                               tmp-680b775fb37a463-12cc)
-                                        (list (cons tmp-680b775fb37a463-12cc 
tmp-680b775fb37a463-12cd)
-                                              tmp-680b775fb37a463-12ce))
+                                 (map (lambda (tmp-680b775fb37a463-2 
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                        (list (cons tmp-680b775fb37a463 
tmp-680b775fb37a463-1) tmp-680b775fb37a463-2))
                                       template
                                       pattern
                                       keyword)))
@@ -2586,11 +2684,11 @@
                                        dots
                                        k
                                        '()
-                                       (map (lambda (tmp-680b775fb37a463-12e7
-                                                     tmp-680b775fb37a463-12e6
-                                                     tmp-680b775fb37a463-12e5)
-                                              (list (cons 
tmp-680b775fb37a463-12e5 tmp-680b775fb37a463-12e6)
-                                                    tmp-680b775fb37a463-12e7))
+                                       (map (lambda (tmp-680b775fb37a463
+                                                     tmp-680b775fb37a463-135f
+                                                     tmp-680b775fb37a463-135e)
+                                              (list (cons 
tmp-680b775fb37a463-135e tmp-680b775fb37a463-135f)
+                                                    tmp-680b775fb37a463))
                                             template
                                             pattern
                                             keyword)))
@@ -2606,11 +2704,11 @@
                                              dots
                                              k
                                              (list docstring)
-                                             (map (lambda 
(tmp-680b775fb37a463-2
-                                                           
tmp-680b775fb37a463-1
-                                                           tmp-680b775fb37a463)
-                                                    (list (cons 
tmp-680b775fb37a463 tmp-680b775fb37a463-1)
-                                                          
tmp-680b775fb37a463-2))
+                                             (map (lambda 
(tmp-680b775fb37a463-137f
+                                                           
tmp-680b775fb37a463-137e
+                                                           
tmp-680b775fb37a463-137d)
+                                                    (list (cons 
tmp-680b775fb37a463-137d tmp-680b775fb37a463-137e)
+                                                          
tmp-680b775fb37a463-137f))
                                                   template
                                                   pattern
                                                   keyword)))
@@ -2738,9 +2836,9 @@
                                                              (apply (lambda (p)
                                                                       (if (= 
lev 0)
                                                                           
(quasilist*
-                                                                           
(map (lambda (tmp-680b775fb37a463-13b3)
+                                                                           
(map (lambda (tmp-680b775fb37a463-142c)
                                                                                
   (list "value"
-                                                                               
         tmp-680b775fb37a463-13b3))
+                                                                               
         tmp-680b775fb37a463-142c))
                                                                                
 p)
                                                                            
(quasi q lev))
                                                                           
(quasicons
@@ -2766,9 +2864,9 @@
                                                                    (apply 
(lambda (p)
                                                                             
(if (= lev 0)
                                                                                
 (quasiappend
-                                                                               
  (map (lambda (tmp-680b775fb37a463-13b8)
+                                                                               
  (map (lambda (tmp-680b775fb37a463)
                                                                                
         (list "value"
-                                                                               
               tmp-680b775fb37a463-13b8))
+                                                                               
               tmp-680b775fb37a463))
                                                                                
       p)
                                                                                
  (quasi q lev))
                                                                                
 (quasicons
@@ -2804,8 +2902,8 @@
                                            (apply (lambda (p)
                                                     (if (= lev 0)
                                                         (quasilist*
-                                                         (map (lambda 
(tmp-680b775fb37a463-13ce)
-                                                                (list "value" 
tmp-680b775fb37a463-13ce))
+                                                         (map (lambda 
(tmp-680b775fb37a463)
+                                                                (list "value" 
tmp-680b775fb37a463))
                                                               p)
                                                          (vquasi q lev))
                                                         (quasicons
@@ -2825,8 +2923,8 @@
                                                  (apply (lambda (p)
                                                           (if (= lev 0)
                                                               (quasiappend
-                                                               (map (lambda 
(tmp-680b775fb37a463-13d3)
-                                                                      (list 
"value" tmp-680b775fb37a463-13d3))
+                                                               (map (lambda 
(tmp-680b775fb37a463-144c)
+                                                                      (list 
"value" tmp-680b775fb37a463-144c))
                                                                     p)
                                                                (vquasi q lev))
                                                               (quasicons
@@ -2908,8 +3006,7 @@
                                        (let ((tmp-1 ls))
                                          (let ((tmp ($sc-dispatch tmp-1 
'each-any)))
                                            (if tmp
-                                               (apply (lambda 
(t-680b775fb37a463-141c)
-                                                        (cons "vector" 
t-680b775fb37a463-141c))
+                                               (apply (lambda 
(t-680b775fb37a463) (cons "vector" t-680b775fb37a463))
                                                       tmp)
                                                (syntax-violation
                                                 #f
@@ -2919,7 +3016,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-14a1)
+                                                       (list "quote" 
tmp-680b775fb37a463-14a1))
                                                      y)))
                                            tmp-1)
                                     (let ((tmp-1 ($sc-dispatch tmp '(#(atom 
"list") . each-any))))
@@ -2930,8 +3028,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-14b0 tmp))
+                                                      (list "list->vector" 
t-680b775fb37a463-14b0)))))))))))))))))
                (emit (lambda (x)
                        (let ((tmp x))
                          (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") 
any))))
@@ -2943,9 +3041,9 @@
                                               (let ((tmp-1 (map emit x)))
                                                 (let ((tmp ($sc-dispatch tmp-1 
'each-any)))
                                                   (if tmp
-                                                      (apply (lambda 
(t-680b775fb37a463)
+                                                      (apply (lambda 
(t-680b775fb37a463-14bf)
                                                                (cons 
(make-syntax 'list '((top)) '(hygiene guile))
-                                                                     
t-680b775fb37a463))
+                                                                     
t-680b775fb37a463-14bf))
                                                              tmp)
                                                       (syntax-violation
                                                        #f
@@ -2961,14 +3059,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-145a
-                                                                               
   t-680b775fb37a463)
+                                                                  (apply 
(lambda (t-680b775fb37a463-14d3
+                                                                               
   t-680b775fb37a463-14d2)
                                                                            
(list (make-syntax
                                                                                
   'cons
                                                                                
   '((top))
                                                                                
   '(hygiene guile))
-                                                                               
  t-680b775fb37a463-145a
-                                                                               
  t-680b775fb37a463))
+                                                                               
  t-680b775fb37a463-14d3
+                                                                               
  t-680b775fb37a463-14d2))
                                                                          tmp)
                                                                   
(syntax-violation
                                                                    #f
@@ -2981,12 +3079,12 @@
                                                           (let ((tmp-1 (map 
emit x)))
                                                             (let ((tmp 
($sc-dispatch tmp-1 'each-any)))
                                                               (if tmp
-                                                                  (apply 
(lambda (t-680b775fb37a463)
+                                                                  (apply 
(lambda (t-680b775fb37a463-14df)
                                                                            
(cons (make-syntax
                                                                                
   'append
                                                                                
   '((top))
                                                                                
   '(hygiene guile))
-                                                                               
  t-680b775fb37a463))
+                                                                               
  t-680b775fb37a463-14df))
                                                                          tmp)
                                                                   
(syntax-violation
                                                                    #f
@@ -2999,12 +3097,12 @@
                                                                 (let ((tmp-1 
(map emit x)))
                                                                   (let ((tmp 
($sc-dispatch tmp-1 'each-any)))
                                                                     (if tmp
-                                                                        (apply 
(lambda (t-680b775fb37a463)
+                                                                        (apply 
(lambda (t-680b775fb37a463-14eb)
                                                                                
  (cons (make-syntax
                                                                                
         'vector
                                                                                
         '((top))
                                                                                
         '(hygiene guile))
-                                                                               
        t-680b775fb37a463))
+                                                                               
        t-680b775fb37a463-14eb))
                                                                                
tmp)
                                                                         
(syntax-violation
                                                                          #f
@@ -3015,12 +3113,12 @@
                                                          (if tmp-1
                                                              (apply (lambda (x)
                                                                       (let 
((tmp (emit x)))
-                                                                        (let 
((t-680b775fb37a463-147e tmp))
+                                                                        (let 
((t-680b775fb37a463-14f7 tmp))
                                                                           
(list (make-syntax
                                                                                
  'list->vector
                                                                                
  '((top))
                                                                                
  '(hygiene guile))
-                                                                               
 t-680b775fb37a463-147e))))
+                                                                               
 t-680b775fb37a463-14f7))))
                                                                     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 65dc3dc58..1ad6f154f 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -343,7 +343,7 @@
 
   (define-syntax-rule (arg-check pred? e who)
     (let ((x e))
-      (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
+      (unless (pred? x) (syntax-violation who "invalid argument" x))))
 
   ;; compile-time environments
 
@@ -467,11 +467,10 @@
      ((syntax? x) (symbol? (syntax-expression x)))
      (else #f)))
 
-  (define-syntax-rule (id-sym-name e)
-    (let ((x e))
-      (if (syntax? x)
-          (syntax-expression x)
-          x)))
+  (define (id-sym-name x)
+    (if (syntax? x)
+        (syntax-expression x)
+        x))
 
   (define (id-sym-name&marks x w)
     (if (syntax? x)
@@ -638,63 +637,62 @@
     ;; case, this routine returns either a symbol, a syntax object, or
     ;; a string label.
     ;;
-    (define-syntax-rule (first e)
-      ;; Rely on Guile's multiple-values truncation.
-      e)
-    (define search
-      (lambda (sym subst marks mod)
-        (if (null? subst)
-            (values #f marks)
-            (let ((fst (car subst)))
-              (if (eq? fst 'shift)
-                  (search sym (cdr subst) (cdr marks) mod)
-                  (let ((symnames (ribcage-symnames fst)))
-                    (if (vector? symnames)
-                        (search-vector-rib sym subst marks symnames fst mod)
-                        (search-list-rib sym subst marks symnames fst 
mod))))))))
-    (define search-list-rib
-      (lambda (sym subst marks symnames ribcage mod)
-        (let f ((symnames symnames)
-                (rlabels (ribcage-labels ribcage))
-                (rmarks (ribcage-marks ribcage)))
-          (cond
-           ((null? symnames) (search sym (cdr subst) marks mod))
-           ((and (eq? (car symnames) sym) (same-marks? marks (car rmarks)))
-            (let ((n (car rlabels)))
-              (if (pair? n)
-                  (if (equal? mod (car n))
-                      (values (cdr n) marks)
-                      (f (cdr symnames) (cdr rlabels) (cdr rmarks)))
-                  (values n marks))))
-           (else (f (cdr symnames) (cdr rlabels) (cdr rmarks)))))))
-    (define search-vector-rib
-      (lambda (sym subst marks symnames ribcage mod)
-        (let ((n (vector-length symnames)))
-          (let f ((i 0))
-            (cond
-             ((= i n) (search sym (cdr subst) marks mod))
-             ((and (eq? (vector-ref symnames i) sym)
-                   (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
-              (let ((n (vector-ref (ribcage-labels ribcage) i)))
-                (if (pair? n)
-                    (if (equal? mod (car n))
-                        (values (cdr n) marks)
-                        (f (1+ i)))
-                    (values n marks))))
-             (else (f (1+ i))))))))
+    (define (search sym subst marks)
+      (match subst
+        (() #f)
+        (('shift . subst)
+         (match marks
+           ((_ . marks)
+            (search sym subst marks))))
+        ((#('ribcage rsymnames rmarks rlabels) . subst)
+         (define (search-list-rib)
+           (let lp ((rsymnames rsymnames)
+                    (rmarks rmarks)
+                    (rlabels rlabels))
+             (match rsymnames
+               (() (search sym subst marks))
+               ((rsym . rsymnames)
+                (match rmarks
+                  ((rmarks1 . rmarks)
+                   (match rlabels
+                     ((label . rlabels)
+                      (if (and (eq? sym rsym) (same-marks? marks rmarks1))
+                          (match label
+                            ((mod* . label)
+                             (if (equal? mod* mod)
+                                 label
+                                 (lp rsymnames rmarks rlabels)))
+                            (_ label))
+                          (lp rsymnames rmarks rlabels))))))))))
+         (define (search-vector-rib)
+           (let ((n (vector-length rsymnames)))
+             (let lp ((i 0))
+               (cond
+                ((= i n) (search sym subst marks))
+                ((and (eq? (vector-ref rsymnames i) sym)
+                      (same-marks? marks (vector-ref rmarks i)))
+                 (match (vector-ref rlabels i)
+                   ((mod* . label)
+                    (if (equal? mod* mod)
+                        label
+                        (lp (1+ i))))
+                   (label
+                    label)))
+                (else (lp (1+ i)))))))
+         (if (vector? rsymnames)
+             (search-vector-rib)
+             (search-list-rib)))))
     (cond
      ((symbol? id)
-      (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
+      (or (search id (wrap-subst w) (wrap-marks w)) id))
      ((syntax? id)
       (let ((id (syntax-expression id))
             (w1 (syntax-wrap id))
             (mod (or (syntax-module id) mod)))
         (let ((marks (join-marks (wrap-marks w) (wrap-marks w1))))
-          (call-with-values (lambda () (search id (wrap-subst w) marks mod))
-            (lambda (new-id marks)
-              (or new-id
-                  (first (search id (wrap-subst w1) marks mod))
-                  id))))))
+          (or (search id (wrap-subst w) marks)
+              (search id (wrap-subst w1) marks)
+              id))))
      (else (syntax-violation 'id-var-name "invalid id" id))))
 
   ;; A helper procedure for syntax-locally-bound-identifiers, which



reply via email to

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