[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))
- [Guile-commits] branch main updated (bb7154fb8 -> 2daea4020), Andy Wingo, 2024/11/15
- [Guile-commits] 05/12: psyntax: Clean up use of fx+, etc, Andy Wingo, 2024/11/15
- [Guile-commits] 06/12: psyntax: Functional annotation of function names, Andy Wingo, 2024/11/15
- [Guile-commits] 10/12: psyntax: Add simple pattern matcher,
Andy Wingo <=
- [Guile-commits] 04/12: psyntax: Rename top-level-eval, local-eval, Andy Wingo, 2024/11/15
- [Guile-commits] 07/12: psyntax: Inline the single use of define-structure, Andy Wingo, 2024/11/15
- [Guile-commits] 08/12: psyntax: Remove a useless level of let, Andy Wingo, 2024/11/15
- [Guile-commits] 12/12: psyntax: Use new `match' instead of cdadring, Andy Wingo, 2024/11/15
- [Guile-commits] 11/12: psyntax: Use new `match' instead of cdadring, Andy Wingo, 2024/11/15
- [Guile-commits] 09/12: psyntax: Avoid lambda in procedure definitions, Andy Wingo, 2024/11/15
- [Guile-commits] 01/12: psyntax: Clean up lexical gensym creation, Andy Wingo, 2024/11/15
- [Guile-commits] 03/12: psyntax: Use vectors instead of gensyms for labels, marks, Andy Wingo, 2024/11/15
- [Guile-commits] 02/12: psyntax: Remove useless gen-label invocations, Andy Wingo, 2024/11/15