* [PATCH] psyntax tail patterns
@ 2009-10-29 20:55 Andreas Rottmann
0 siblings, 0 replies; only message in thread
From: Andreas Rottmann @ 2009-10-29 20:55 UTC (permalink / raw)
To: Guile Developers
[-- Attachment #1: Type: text/plain, Size: 727 bytes --]
Hi!
This is a followup on my earlier message on this topic[0]. 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!
[ As a side remark, I don't really understand why one has to implement a
macro expander in a way that requires bootstrapping ]
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: syncase-tail-patterns.diff --]
[-- Type: text/x-diff, Size: 9154 bytes --]
From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: [PATCH] Add support for tail patterns to syntax-case and syntax-rules
---
module/ice-9/psyntax.scm | 120 +++++++++++++++++++++++++++++++---------
test-suite/tests/syncase.test | 43 ++++++++++++++-
2 files changed, 134 insertions(+), 29 deletions(-)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 6fcc9b0..af0e5e6 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2242,33 +2242,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? (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 . 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)))))))
+ (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)
@@ -2461,6 +2483,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?"
@@ -2486,6 +2509,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
@@ -2509,9 +2555,19 @@
(else
(case (vector-ref p 0)
((each) (match-empty (vector-ref p 1) r))
+ ((each+) (match-empy (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
@@ -2533,6 +2589,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)
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index cb916cf..f21000e 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -1,6 +1,6 @@
;;;; syncase.test --- test suite for (ice-9 syncase) -*- scheme -*-
;;;;
-;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -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))))))
--
tg: (d365a9a..) t/syncase-tail-patterns (depends on: master t/quasisyntax)
[-- Attachment #3: Type: text/plain, Size: 123 bytes --]
[0] <http://article.gmane.org/gmane.lisp.guile.devel/9442>
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2009-10-29 20:55 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2009-10-29 20:55 [PATCH] psyntax tail patterns Andreas Rottmann
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).