From: Andreas Rottmann 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 ) with free-identifier=? ;;; #(each ) (*) +;;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) ;;; #(vector ) (list->vector ) ;;; #(atom ) 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)