guile-commits
[Top][All Lists]
Advanced

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

[Guile-commits] 10/12: psyntax: Add simple pattern matcher


From: Andy Wingo
Subject: [Guile-commits] 10/12: psyntax: Add simple pattern matcher
Date: Fri, 15 Nov 2024 10:25:32 -0500 (EST)

wingo pushed a commit to branch main
in repository guile.

commit d94292724b4dd400a5fd051c0a4a1eac681291ab
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Nov 15 14:16:20 2024 +0100

    psyntax: Add simple pattern matcher
    
    * module/ice-9/psyntax.scm (simple-match1, simple-match-pat,
    simple-match-patv, match): Add simple pattern matcher.
    * module/ice-9/psyntax-pp.scm: Regenerate.  Just different renumbering
    of temps.
---
 module/ice-9/psyntax-pp.scm | 78 +++++++++++++++++++++++----------------------
 module/ice-9/psyntax.scm    | 52 ++++++++++++++++++++++++++++++
 2 files changed, 92 insertions(+), 38 deletions(-)

diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 9d1749c40..d5134585c 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -794,11 +794,11 @@
                                 (source-wrap e w (cdr w) mod)
                                 x))
                               (else (decorate-source x))))))
-                 (let* ((t-680b775fb37a463-d6f transformer-environment)
-                        (t-680b775fb37a463-d70 (lambda (k) (k e r w s rib 
mod))))
+                 (let* ((t-680b775fb37a463-e6b transformer-environment)
+                        (t-680b775fb37a463-e6c (lambda (k) (k e r w s rib 
mod))))
                    (with-fluid*
-                    t-680b775fb37a463-d6f
-                    t-680b775fb37a463-d70
+                    t-680b775fb37a463-e6b
+                    t-680b775fb37a463-e6c
                     (lambda () (rebuild-macro-output (p (source-wrap e 
(anti-mark w) s mod)) (new-mark))))))))
             (expand-body
              (lambda (body outer-form r w mod)
@@ -1328,11 +1328,11 @@
                                                 s
                                                 mod
                                                 get-formals
-                                                (map (lambda 
(tmp-680b775fb37a463-feb
-                                                              
tmp-680b775fb37a463-fea
-                                                              
tmp-680b775fb37a463-fe9)
-                                                       (cons 
tmp-680b775fb37a463-fe9
-                                                             (cons 
tmp-680b775fb37a463-fea tmp-680b775fb37a463-feb)))
+                                                (map (lambda 
(tmp-680b775fb37a463-10e7
+                                                              
tmp-680b775fb37a463-10e6
+                                                              
tmp-680b775fb37a463-10e5)
+                                                       (cons 
tmp-680b775fb37a463-10e5
+                                                             (cons 
tmp-680b775fb37a463-10e6 tmp-680b775fb37a463-10e7)))
                                                      e2*
                                                      e1*
                                                      args*)))
@@ -1600,8 +1600,8 @@
                (apply (lambda (args e1 e2)
                         (build-it
                          '()
-                         (map (lambda (tmp-680b775fb37a463-63b 
tmp-680b775fb37a463-63a tmp-680b775fb37a463)
-                                (cons tmp-680b775fb37a463 (cons 
tmp-680b775fb37a463-63a tmp-680b775fb37a463-63b)))
+                         (map (lambda (tmp-680b775fb37a463-2 
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                (cons tmp-680b775fb37a463 (cons 
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
                               e2
                               e1
                               args)))
@@ -1611,8 +1611,9 @@
                      (apply (lambda (docstring args e1 e2)
                               (build-it
                                (list (cons 'documentation (syntax->datum 
docstring)))
-                               (map (lambda (tmp-680b775fb37a463-1 
tmp-680b775fb37a463 tmp-680b775fb37a463-64f)
-                                      (cons tmp-680b775fb37a463-64f (cons 
tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
+                               (map (lambda (tmp-680b775fb37a463-74d 
tmp-680b775fb37a463-74c tmp-680b775fb37a463-74b)
+                                      (cons tmp-680b775fb37a463-74b
+                                            (cons tmp-680b775fb37a463-74c 
tmp-680b775fb37a463-74d)))
                                     e2
                                     e1
                                     args)))
@@ -1632,8 +1633,8 @@
                (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-1 
tmp-680b775fb37a463 tmp-680b775fb37a463-6ff)
+                                (cons tmp-680b775fb37a463-6ff (cons 
tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
                               e2
                               e1
                               args)))
@@ -1643,8 +1644,8 @@
                      (apply (lambda (docstring args e1 e2)
                               (build-it
                                (list (cons 'documentation (syntax->datum 
docstring)))
-                               (map (lambda (tmp-680b775fb37a463-61b 
tmp-680b775fb37a463-61a tmp-680b775fb37a463)
-                                      (cons tmp-680b775fb37a463 (cons 
tmp-680b775fb37a463-61a tmp-680b775fb37a463-61b)))
+                               (map (lambda (tmp-680b775fb37a463-2 
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+                                      (cons tmp-680b775fb37a463 (cons 
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
                                     e2
                                     e1
                                     args)))
@@ -2441,9 +2442,11 @@
                                  #f
                                  k
                                  (list docstring)
-                                 (map (lambda (tmp-680b775fb37a463 
tmp-680b775fb37a463-111f tmp-680b775fb37a463-111e)
-                                        (list (cons tmp-680b775fb37a463-111e 
tmp-680b775fb37a463-111f)
-                                              tmp-680b775fb37a463))
+                                 (map (lambda (tmp-680b775fb37a463-121c
+                                               tmp-680b775fb37a463-121b
+                                               tmp-680b775fb37a463-121a)
+                                        (list (cons tmp-680b775fb37a463-121a 
tmp-680b775fb37a463-121b)
+                                              tmp-680b775fb37a463-121c))
                                       template
                                       pattern
                                       keyword)))
@@ -2632,9 +2635,9 @@
                                                                    (apply 
(lambda (p)
                                                                             
(if (= lev 0)
                                                                                
 (quasiappend
-                                                                               
  (map (lambda (tmp-680b775fb37a463-120a)
+                                                                               
  (map (lambda (tmp-680b775fb37a463)
                                                                                
         (list "value"
-                                                                               
               tmp-680b775fb37a463-120a))
+                                                                               
               tmp-680b775fb37a463))
                                                                                
       p)
                                                                                
  (quasi q lev))
                                                                                
 (quasicons
@@ -2670,8 +2673,8 @@
                                            (apply (lambda (p)
                                                     (if (= lev 0)
                                                         (quasilist*
-                                                         (map (lambda 
(tmp-680b775fb37a463)
-                                                                (list "value" 
tmp-680b775fb37a463))
+                                                         (map (lambda 
(tmp-680b775fb37a463-131c)
+                                                                (list "value" 
tmp-680b775fb37a463-131c))
                                                               p)
                                                          (vquasi q lev))
                                                         (quasicons
@@ -2774,8 +2777,8 @@
                                        (let ((tmp-1 ls))
                                          (let ((tmp ($sc-dispatch tmp-1 
'each-any)))
                                            (if tmp
-                                               (apply (lambda 
(t-680b775fb37a463-126e)
-                                                        (cons "vector" 
t-680b775fb37a463-126e))
+                                               (apply (lambda 
(t-680b775fb37a463-136a)
+                                                        (cons "vector" 
t-680b775fb37a463-136a))
                                                       tmp)
                                                (syntax-violation
                                                 #f
@@ -2785,8 +2788,7 @@
                               (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") 
each-any))))
                                 (if tmp-1
                                     (apply (lambda (y)
-                                             (k (map (lambda 
(tmp-680b775fb37a463-127a)
-                                                       (list "quote" 
tmp-680b775fb37a463-127a))
+                                             (k (map (lambda 
(tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
                                                      y)))
                                            tmp-1)
                                     (let ((tmp-1 ($sc-dispatch tmp '(#(atom 
"list") . each-any))))
@@ -2828,14 +2830,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-12ac
-                                                                               
   t-680b775fb37a463-12ab)
+                                                                  (apply 
(lambda (t-680b775fb37a463-13a8
+                                                                               
   t-680b775fb37a463-13a7)
                                                                            
(list (make-syntax
                                                                                
   'cons
                                                                                
   '((top))
                                                                                
   '(hygiene guile))
-                                                                               
  t-680b775fb37a463-12ac
-                                                                               
  t-680b775fb37a463-12ab))
+                                                                               
  t-680b775fb37a463-13a8
+                                                                               
  t-680b775fb37a463-13a7))
                                                                          tmp)
                                                                   
(syntax-violation
                                                                    #f
@@ -2848,12 +2850,12 @@
                                                           (let ((tmp-1 (map 
emit x)))
                                                             (let ((tmp 
($sc-dispatch tmp-1 'each-any)))
                                                               (if tmp
-                                                                  (apply 
(lambda (t-680b775fb37a463-12b8)
+                                                                  (apply 
(lambda (t-680b775fb37a463-13b4)
                                                                            
(cons (make-syntax
                                                                                
   'append
                                                                                
   '((top))
                                                                                
   '(hygiene guile))
-                                                                               
  t-680b775fb37a463-12b8))
+                                                                               
  t-680b775fb37a463-13b4))
                                                                          tmp)
                                                                   
(syntax-violation
                                                                    #f
@@ -2866,12 +2868,12 @@
                                                                 (let ((tmp-1 
(map emit x)))
                                                                   (let ((tmp 
($sc-dispatch tmp-1 'each-any)))
                                                                     (if tmp
-                                                                        (apply 
(lambda (t-680b775fb37a463-12c4)
+                                                                        (apply 
(lambda (t-680b775fb37a463-13c0)
                                                                                
  (cons (make-syntax
                                                                                
         'vector
                                                                                
         '((top))
                                                                                
         '(hygiene guile))
-                                                                               
        t-680b775fb37a463-12c4))
+                                                                               
        t-680b775fb37a463-13c0))
                                                                                
tmp)
                                                                         
(syntax-violation
                                                                          #f
@@ -2882,12 +2884,12 @@
                                                          (if tmp-1
                                                              (apply (lambda (x)
                                                                       (let 
((tmp (emit x)))
-                                                                        (let 
((t-680b775fb37a463-12d0 tmp))
+                                                                        (let 
((t-680b775fb37a463-13cc tmp))
                                                                           
(list (make-syntax
                                                                                
  'list->vector
                                                                                
  '((top))
                                                                                
  '(hygiene guile))
-                                                                               
 t-680b775fb37a463-12d0))))
+                                                                               
 t-680b775fb37a463-13cc))))
                                                                     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 c772c4aca..412c9560a 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -126,6 +126,58 @@
   (define-expansion-constructors)
   (define-expansion-accessors lambda src meta body)
 
+  ;; A simple pattern matcher based on Oleg Kiselyov's pmatch.
+  (define-syntax-rule (simple-match e cs ...)
+    (let ((v e)) (simple-match-1 v cs ...)))
+
+  (define-syntax simple-match-1
+    (syntax-rules ()
+      ((_ v) (error "value failed to match" v))
+      ((_ v (pat e0 e ...) cs ...)
+       (let ((fk (lambda () (simple-match-1 v cs ...))))
+         (simple-match-pat v pat (let () e0 e ...) (fk))))))
+
+  (define-syntax simple-match-patv
+    (syntax-rules ()
+      ((_ v idx () kt kf) kt)
+      ((_ v idx (x . y) kt kf)
+       (simple-match-pat (vector-ref v idx) x
+                         (simple-match-patv v (1+ idx) y kt kf)
+                         kf))))
+
+  (define-syntax simple-match-pat
+    (syntax-rules (_ quote unquote ? and or not)
+      ((_ v _ kt kf) kt)
+      ((_ v () kt kf) (if (null? v) kt kf))
+      ((_ v #t kt kf) (if (eq? v #t) kt kf))
+      ((_ v #f kt kf) (if (eq? v #f) kt kf))
+      ((_ v (and) kt kf) kt)
+      ((_ v (and x . y) kt kf)
+       (simple-match-pat v x (simple-match-pat v (and . y) kt kf) kf))
+      ((_ v (or) kt kf) kf)
+      ((_ v (or x . y) kt kf)
+       (let ((tk (lambda () kt)))
+         (simple-match-pat v x (tk) (simple-match-pat v (or . y) (tk) kf))))
+      ((_ v (not pat) kt kf) (simple-match-pat v pat kf kt))
+      ((_ v (quote lit) kt kf)
+       (if (eq? v (quote lit)) kt kf))
+      ((_ v (? proc) kt kf) (simple-match-pat v (? proc _) kt kf))
+      ((_ v (? proc pat) kt kf)
+       (if (proc v) (simple-match-pat v pat kt kf) kf))
+      ((_ v (x . y) kt kf)
+       (if (pair? v)
+           (let ((vx (car v)) (vy (cdr v)))
+             (simple-match-pat vx x (simple-match-pat vy y kt kf) kf))
+           kf))
+      ((_ v #(x ...) kt kf)
+       (if (and (vector? v)
+                (eq? (vector-length v) (length '(x ...))))
+           (simple-match-patv v 0 (x ...) kt kf)
+           kf))
+      ((_ v var kt kf) (let ((var v)) kt))))
+
+  (define-syntax-rule (match e cs ...) (simple-match e cs ...))
+
   (define (top-level-eval x mod)
     (primitive-eval x))
 



reply via email to

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