mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-30 06:50:31 +02:00
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.
This commit is contained in:
Andy Wingo
parent
d30b39e4ea
commit
d94292724b
2 changed files with 92 additions and 38 deletions
|
|
@ -794,11 +794,11 @@
|
||||||
(source-wrap e w (cdr w) mod)
|
(source-wrap e w (cdr w) mod)
|
||||||
x))
|
x))
|
||||||
(else (decorate-source x))))))
|
(else (decorate-source x))))))
|
||||||
(let* ((t-680b775fb37a463-d6f transformer-environment)
|
(let* ((t-680b775fb37a463-e6b transformer-environment)
|
||||||
(t-680b775fb37a463-d70 (lambda (k) (k e r w s rib mod))))
|
(t-680b775fb37a463-e6c (lambda (k) (k e r w s rib mod))))
|
||||||
(with-fluid*
|
(with-fluid*
|
||||||
t-680b775fb37a463-d6f
|
t-680b775fb37a463-e6b
|
||||||
t-680b775fb37a463-d70
|
t-680b775fb37a463-e6c
|
||||||
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
|
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
|
||||||
(expand-body
|
(expand-body
|
||||||
(lambda (body outer-form r w mod)
|
(lambda (body outer-form r w mod)
|
||||||
|
|
@ -1328,11 +1328,11 @@
|
||||||
s
|
s
|
||||||
mod
|
mod
|
||||||
get-formals
|
get-formals
|
||||||
(map (lambda (tmp-680b775fb37a463-feb
|
(map (lambda (tmp-680b775fb37a463-10e7
|
||||||
tmp-680b775fb37a463-fea
|
tmp-680b775fb37a463-10e6
|
||||||
tmp-680b775fb37a463-fe9)
|
tmp-680b775fb37a463-10e5)
|
||||||
(cons tmp-680b775fb37a463-fe9
|
(cons tmp-680b775fb37a463-10e5
|
||||||
(cons tmp-680b775fb37a463-fea tmp-680b775fb37a463-feb)))
|
(cons tmp-680b775fb37a463-10e6 tmp-680b775fb37a463-10e7)))
|
||||||
e2*
|
e2*
|
||||||
e1*
|
e1*
|
||||||
args*)))
|
args*)))
|
||||||
|
|
@ -1600,8 +1600,8 @@
|
||||||
(apply (lambda (args e1 e2)
|
(apply (lambda (args e1 e2)
|
||||||
(build-it
|
(build-it
|
||||||
'()
|
'()
|
||||||
(map (lambda (tmp-680b775fb37a463-63b tmp-680b775fb37a463-63a tmp-680b775fb37a463)
|
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||||
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-63a tmp-680b775fb37a463-63b)))
|
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
||||||
e2
|
e2
|
||||||
e1
|
e1
|
||||||
args)))
|
args)))
|
||||||
|
|
@ -1611,8 +1611,9 @@
|
||||||
(apply (lambda (docstring args e1 e2)
|
(apply (lambda (docstring args e1 e2)
|
||||||
(build-it
|
(build-it
|
||||||
(list (cons 'documentation (syntax->datum docstring)))
|
(list (cons 'documentation (syntax->datum docstring)))
|
||||||
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-64f)
|
(map (lambda (tmp-680b775fb37a463-74d tmp-680b775fb37a463-74c tmp-680b775fb37a463-74b)
|
||||||
(cons tmp-680b775fb37a463-64f (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
|
(cons tmp-680b775fb37a463-74b
|
||||||
|
(cons tmp-680b775fb37a463-74c tmp-680b775fb37a463-74d)))
|
||||||
e2
|
e2
|
||||||
e1
|
e1
|
||||||
args)))
|
args)))
|
||||||
|
|
@ -1632,8 +1633,8 @@
|
||||||
(apply (lambda (args e1 e2)
|
(apply (lambda (args e1 e2)
|
||||||
(build-it
|
(build-it
|
||||||
'()
|
'()
|
||||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-6ff)
|
||||||
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
(cons tmp-680b775fb37a463-6ff (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
|
||||||
e2
|
e2
|
||||||
e1
|
e1
|
||||||
args)))
|
args)))
|
||||||
|
|
@ -1643,8 +1644,8 @@
|
||||||
(apply (lambda (docstring args e1 e2)
|
(apply (lambda (docstring args e1 e2)
|
||||||
(build-it
|
(build-it
|
||||||
(list (cons 'documentation (syntax->datum docstring)))
|
(list (cons 'documentation (syntax->datum docstring)))
|
||||||
(map (lambda (tmp-680b775fb37a463-61b tmp-680b775fb37a463-61a tmp-680b775fb37a463)
|
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||||
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-61a tmp-680b775fb37a463-61b)))
|
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
||||||
e2
|
e2
|
||||||
e1
|
e1
|
||||||
args)))
|
args)))
|
||||||
|
|
@ -2441,9 +2442,11 @@
|
||||||
#f
|
#f
|
||||||
k
|
k
|
||||||
(list docstring)
|
(list docstring)
|
||||||
(map (lambda (tmp-680b775fb37a463 tmp-680b775fb37a463-111f tmp-680b775fb37a463-111e)
|
(map (lambda (tmp-680b775fb37a463-121c
|
||||||
(list (cons tmp-680b775fb37a463-111e tmp-680b775fb37a463-111f)
|
tmp-680b775fb37a463-121b
|
||||||
tmp-680b775fb37a463))
|
tmp-680b775fb37a463-121a)
|
||||||
|
(list (cons tmp-680b775fb37a463-121a tmp-680b775fb37a463-121b)
|
||||||
|
tmp-680b775fb37a463-121c))
|
||||||
template
|
template
|
||||||
pattern
|
pattern
|
||||||
keyword)))
|
keyword)))
|
||||||
|
|
@ -2632,9 +2635,9 @@
|
||||||
(apply (lambda (p)
|
(apply (lambda (p)
|
||||||
(if (= lev 0)
|
(if (= lev 0)
|
||||||
(quasiappend
|
(quasiappend
|
||||||
(map (lambda (tmp-680b775fb37a463-120a)
|
(map (lambda (tmp-680b775fb37a463)
|
||||||
(list "value"
|
(list "value"
|
||||||
tmp-680b775fb37a463-120a))
|
tmp-680b775fb37a463))
|
||||||
p)
|
p)
|
||||||
(quasi q lev))
|
(quasi q lev))
|
||||||
(quasicons
|
(quasicons
|
||||||
|
|
@ -2670,8 +2673,8 @@
|
||||||
(apply (lambda (p)
|
(apply (lambda (p)
|
||||||
(if (= lev 0)
|
(if (= lev 0)
|
||||||
(quasilist*
|
(quasilist*
|
||||||
(map (lambda (tmp-680b775fb37a463)
|
(map (lambda (tmp-680b775fb37a463-131c)
|
||||||
(list "value" tmp-680b775fb37a463))
|
(list "value" tmp-680b775fb37a463-131c))
|
||||||
p)
|
p)
|
||||||
(vquasi q lev))
|
(vquasi q lev))
|
||||||
(quasicons
|
(quasicons
|
||||||
|
|
@ -2774,8 +2777,8 @@
|
||||||
(let ((tmp-1 ls))
|
(let ((tmp-1 ls))
|
||||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||||
(if tmp
|
(if tmp
|
||||||
(apply (lambda (t-680b775fb37a463-126e)
|
(apply (lambda (t-680b775fb37a463-136a)
|
||||||
(cons "vector" t-680b775fb37a463-126e))
|
(cons "vector" t-680b775fb37a463-136a))
|
||||||
tmp)
|
tmp)
|
||||||
(syntax-violation
|
(syntax-violation
|
||||||
#f
|
#f
|
||||||
|
|
@ -2785,8 +2788,7 @@
|
||||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
|
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
|
||||||
(if tmp-1
|
(if tmp-1
|
||||||
(apply (lambda (y)
|
(apply (lambda (y)
|
||||||
(k (map (lambda (tmp-680b775fb37a463-127a)
|
(k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463))
|
||||||
(list "quote" tmp-680b775fb37a463-127a))
|
|
||||||
y)))
|
y)))
|
||||||
tmp-1)
|
tmp-1)
|
||||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
|
(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-1 (list (emit (car x*)) (f (cdr x*)))))
|
||||||
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
(let ((tmp ($sc-dispatch tmp-1 '(any any))))
|
||||||
(if tmp
|
(if tmp
|
||||||
(apply (lambda (t-680b775fb37a463-12ac
|
(apply (lambda (t-680b775fb37a463-13a8
|
||||||
t-680b775fb37a463-12ab)
|
t-680b775fb37a463-13a7)
|
||||||
(list (make-syntax
|
(list (make-syntax
|
||||||
'cons
|
'cons
|
||||||
'((top))
|
'((top))
|
||||||
'(hygiene guile))
|
'(hygiene guile))
|
||||||
t-680b775fb37a463-12ac
|
t-680b775fb37a463-13a8
|
||||||
t-680b775fb37a463-12ab))
|
t-680b775fb37a463-13a7))
|
||||||
tmp)
|
tmp)
|
||||||
(syntax-violation
|
(syntax-violation
|
||||||
#f
|
#f
|
||||||
|
|
@ -2848,12 +2850,12 @@
|
||||||
(let ((tmp-1 (map emit x)))
|
(let ((tmp-1 (map emit x)))
|
||||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||||
(if tmp
|
(if tmp
|
||||||
(apply (lambda (t-680b775fb37a463-12b8)
|
(apply (lambda (t-680b775fb37a463-13b4)
|
||||||
(cons (make-syntax
|
(cons (make-syntax
|
||||||
'append
|
'append
|
||||||
'((top))
|
'((top))
|
||||||
'(hygiene guile))
|
'(hygiene guile))
|
||||||
t-680b775fb37a463-12b8))
|
t-680b775fb37a463-13b4))
|
||||||
tmp)
|
tmp)
|
||||||
(syntax-violation
|
(syntax-violation
|
||||||
#f
|
#f
|
||||||
|
|
@ -2866,12 +2868,12 @@
|
||||||
(let ((tmp-1 (map emit x)))
|
(let ((tmp-1 (map emit x)))
|
||||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||||
(if tmp
|
(if tmp
|
||||||
(apply (lambda (t-680b775fb37a463-12c4)
|
(apply (lambda (t-680b775fb37a463-13c0)
|
||||||
(cons (make-syntax
|
(cons (make-syntax
|
||||||
'vector
|
'vector
|
||||||
'((top))
|
'((top))
|
||||||
'(hygiene guile))
|
'(hygiene guile))
|
||||||
t-680b775fb37a463-12c4))
|
t-680b775fb37a463-13c0))
|
||||||
tmp)
|
tmp)
|
||||||
(syntax-violation
|
(syntax-violation
|
||||||
#f
|
#f
|
||||||
|
|
@ -2882,12 +2884,12 @@
|
||||||
(if tmp-1
|
(if tmp-1
|
||||||
(apply (lambda (x)
|
(apply (lambda (x)
|
||||||
(let ((tmp (emit x)))
|
(let ((tmp (emit x)))
|
||||||
(let ((t-680b775fb37a463-12d0 tmp))
|
(let ((t-680b775fb37a463-13cc tmp))
|
||||||
(list (make-syntax
|
(list (make-syntax
|
||||||
'list->vector
|
'list->vector
|
||||||
'((top))
|
'((top))
|
||||||
'(hygiene guile))
|
'(hygiene guile))
|
||||||
t-680b775fb37a463-12d0))))
|
t-680b775fb37a463-13cc))))
|
||||||
tmp-1)
|
tmp-1)
|
||||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
|
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
|
||||||
(if tmp-1
|
(if tmp-1
|
||||||
|
|
|
||||||
|
|
@ -126,6 +126,58 @@
|
||||||
(define-expansion-constructors)
|
(define-expansion-constructors)
|
||||||
(define-expansion-accessors lambda src meta body)
|
(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)
|
(define (top-level-eval x mod)
|
||||||
(primitive-eval x))
|
(primitive-eval x))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue