mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 03:40:34 +02:00
add partial support for tail patterns in syntax-rules/syntax-case
I've prepared a patch that adds partial support for tail patterns. Things like the the SRFI-34 `guard' macro from [0] are supported, but you still can't combine dotted patterns with tail patterns, e.g. (syntax-rules (else) ((foo bar ... (else something) . rest) <TEMPLATE-HERE>)) will *not* work; there's the issue that one can't just transcribe the implementation of this feature from the latest version of psyntax, as I've done for non-dotted tail patterns, as it's implemented using a dotted pattern like the above. Alas! [0] <http://article.gmane.org/gmane.lisp.guile.devel/9442> * module/ice-9/psyntax.scm (syntax-case, $sc-dispatch): Add support for tail patterns, transcribed from the latest psyntax. * module/ice-9/psyntax-pp.scm: Regenerated. * test-suite/tests/syncase.test: Add tests for tail patterns.
This commit is contained in:
Andreas Rottmann
Andy Wingo
parent
e42573315b
commit
aa3819aa34
3 changed files with 6705 additions and 6396 deletions
File diff suppressed because it is too large
Load diff
|
|
@ -2235,33 +2235,55 @@
|
|||
; accepts pattern & keys
|
||||
; returns $sc-dispatch pattern & ids
|
||||
(lambda (pattern keys)
|
||||
(let cvt ((p pattern) (n 0) (ids '()))
|
||||
(if (id? p)
|
||||
(if (bound-id-member? p keys)
|
||||
(values (vector 'free-id p) ids)
|
||||
(values 'any (cons (cons p n) ids)))
|
||||
(syntax-case p ()
|
||||
((x dots)
|
||||
(ellipsis? #'dots)
|
||||
(call-with-values
|
||||
(lambda () (cvt #'x (fx+ n 1) ids))
|
||||
(lambda (p ids)
|
||||
(values (if (eq? p 'any) 'each-any (vector 'each p))
|
||||
ids))))
|
||||
((x . y)
|
||||
(call-with-values
|
||||
(lambda () (cvt #'y n ids))
|
||||
(lambda (y ids)
|
||||
(call-with-values
|
||||
(lambda () (cvt #'x n ids))
|
||||
(lambda (x ids)
|
||||
(values (cons x y) ids))))))
|
||||
(() (values '() ids))
|
||||
(#(x ...)
|
||||
(call-with-values
|
||||
(lambda () (cvt #'(x ...) n ids))
|
||||
(lambda (p ids) (values (vector 'vector p) ids))))
|
||||
(x (values (vector 'atom (strip p empty-wrap)) ids)))))))
|
||||
(define cvt*
|
||||
(lambda (p* n ids)
|
||||
(if (null? p*)
|
||||
(values '() ids)
|
||||
(call-with-values
|
||||
(lambda () (cvt* (cdr p*) n ids))
|
||||
(lambda (y ids)
|
||||
(call-with-values
|
||||
(lambda () (cvt (car p*) n ids))
|
||||
(lambda (x ids)
|
||||
(values (cons x y) ids))))))))
|
||||
(define cvt
|
||||
(lambda (p n ids)
|
||||
(if (id? p)
|
||||
(if (bound-id-member? p keys)
|
||||
(values (vector 'free-id p) ids)
|
||||
(values 'any (cons (cons p n) ids)))
|
||||
(syntax-case p ()
|
||||
((x dots)
|
||||
(ellipsis? (syntax dots))
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax x) (fx+ n 1) ids))
|
||||
(lambda (p ids)
|
||||
(values (if (eq? p 'any) 'each-any (vector 'each p))
|
||||
ids))))
|
||||
((x dots ys ...)
|
||||
(ellipsis? (syntax dots))
|
||||
(call-with-values
|
||||
(lambda () (cvt* (syntax (ys ...)) n ids))
|
||||
(lambda (ys ids)
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax x) (+ n 1) ids))
|
||||
(lambda (x ids)
|
||||
(values `#(each+ ,x ,(reverse ys) ()) ids))))))
|
||||
((x . y)
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax y) n ids))
|
||||
(lambda (y ids)
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax x) n ids))
|
||||
(lambda (x ids)
|
||||
(values (cons x y) ids))))))
|
||||
(() (values '() ids))
|
||||
(#(x ...)
|
||||
(call-with-values
|
||||
(lambda () (cvt (syntax (x ...)) n ids))
|
||||
(lambda (p ids) (values (vector 'vector p) ids))))
|
||||
(x (values (vector 'atom (strip p empty-wrap)) ids))))))
|
||||
(cvt pattern 0 '())))
|
||||
|
||||
(define build-dispatch-call
|
||||
(lambda (pvars exp y r mod)
|
||||
|
|
@ -2454,6 +2476,7 @@
|
|||
;;; each-any (any*)
|
||||
;;; #(free-id <key>) <key> with free-identifier=?
|
||||
;;; #(each <pattern>) (<pattern>*)
|
||||
;;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
|
||||
;;; #(vector <pattern>) (list->vector <pattern>)
|
||||
;;; #(atom <object>) <object> with "equal?"
|
||||
|
||||
|
|
@ -2479,6 +2502,29 @@
|
|||
(syntax-object-module e)))
|
||||
(else #f))))
|
||||
|
||||
(define match-each+
|
||||
(lambda (e x-pat y-pat z-pat w r mod)
|
||||
(let f ((e e) (w w))
|
||||
(cond
|
||||
((pair? e)
|
||||
(call-with-values (lambda () (f (cdr e) w))
|
||||
(lambda (xr* y-pat r)
|
||||
(if r
|
||||
(if (null? y-pat)
|
||||
(let ((xr (match (car e) x-pat w '() mod)))
|
||||
(if xr
|
||||
(values (cons xr xr*) y-pat r)
|
||||
(values #f #f #f)))
|
||||
(values
|
||||
'()
|
||||
(cdr y-pat)
|
||||
(match (car e) (car y-pat) w r mod)))
|
||||
(values #f #f #f)))))
|
||||
((syntax-object? e)
|
||||
(f (syntax-object-expression e) (join-wraps w e)))
|
||||
(else
|
||||
(values '() y-pat (match e z-pat w r mod)))))))
|
||||
|
||||
(define match-each-any
|
||||
(lambda (e w mod)
|
||||
(cond
|
||||
|
|
@ -2502,9 +2548,19 @@
|
|||
(else
|
||||
(case (vector-ref p 0)
|
||||
((each) (match-empty (vector-ref p 1) r))
|
||||
((each+) (match-empty (vector-ref p 1)
|
||||
(match-empty
|
||||
(reverse (vector-ref p 2))
|
||||
(match-empty (vector-ref p 3) r))))
|
||||
((free-id atom) r)
|
||||
((vector) (match-empty (vector-ref p 1) r)))))))
|
||||
|
||||
(define combine
|
||||
(lambda (r* r)
|
||||
(if (null? (car r*))
|
||||
r
|
||||
(cons (map car r*) (combine (map cdr r*) r)))))
|
||||
|
||||
(define match*
|
||||
(lambda (e p w r mod)
|
||||
(cond
|
||||
|
|
@ -2526,6 +2582,16 @@
|
|||
(if (null? (car l))
|
||||
r
|
||||
(cons (map car l) (collect (map cdr l)))))))))
|
||||
((each+)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(match-each+ e (vector-ref p 1) (vector-ref p 2) (vector-ref p 3) w r mod))
|
||||
(lambda (xr* y-pat r)
|
||||
(and r
|
||||
(null? y-pat)
|
||||
(if (null? xr*)
|
||||
(match-empty (vector-ref p 1) r)
|
||||
(combine xr* r))))))
|
||||
((free-id) (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
|
||||
((atom) (and (equal? (vector-ref p 1) (strip e w)) r))
|
||||
((vector)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@
|
|||
;; affect code outside of this file.
|
||||
;;
|
||||
(define-module (test-suite test-syncase)
|
||||
:use-module (test-suite lib))
|
||||
:use-module (test-suite lib)
|
||||
:use-module ((srfi srfi-1) :select (member)))
|
||||
|
||||
(define-syntax plus
|
||||
(syntax-rules ()
|
||||
|
|
@ -43,3 +44,41 @@
|
|||
(pass-if "macro using quasisyntax"
|
||||
(equal? (string-let foo (list foo foo))
|
||||
'("foo" "foo")))
|
||||
|
||||
(define-syntax string-case
|
||||
(syntax-rules (else)
|
||||
((string-case expr ((string ...) clause-body ...) ... (else else-body ...))
|
||||
(let ((value expr))
|
||||
(cond ((member value '(string ...) string=?)
|
||||
clause-body ...)
|
||||
...
|
||||
(else
|
||||
else-body ...))))
|
||||
((string-case expr ((string ...) clause-body ...) ...)
|
||||
(let ((value expr))
|
||||
(cond ((member value '(string ...) string=?)
|
||||
clause-body ...)
|
||||
...)))))
|
||||
|
||||
(define-syntax alist
|
||||
(syntax-rules (tail)
|
||||
((alist ((key val) ... (tail expr)))
|
||||
(cons* '(key . val) ... expr))
|
||||
((alist ((key val) ...))
|
||||
(list '(key . val) ...))))
|
||||
|
||||
(with-test-prefix "tail patterns"
|
||||
(with-test-prefix "at the outermost level"
|
||||
(pass-if "non-tail invocation"
|
||||
(equal? (string-case "foo" (("foo") 'foo))
|
||||
'foo))
|
||||
(pass-if "tail invocation"
|
||||
(equal? (string-case "foo" (("bar") 'bar) (else 'else))
|
||||
'else)))
|
||||
(with-test-prefix "at a nested level"
|
||||
(pass-if "non-tail invocation"
|
||||
(equal? (alist ((a 1) (b 2) (c 3)))
|
||||
'((a . 1) (b . 2) (c . 3))))
|
||||
(pass-if "tail invocation"
|
||||
(equal? (alist ((foo 42) (tail '((bar . 66)))))
|
||||
'((foo . 42) (bar . 66))))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue