From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] psyntax tail patterns Date: Thu, 29 Oct 2009 21:55:34 +0100 Message-ID: <87my39kji1.fsf@delenn.lan> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1256849975 824 80.91.229.12 (29 Oct 2009 20:59:35 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Thu, 29 Oct 2009 20:59:35 +0000 (UTC) To: Guile Developers Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Thu Oct 29 21:59:28 2009 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.50) id 1N3c5d-0001CG-KT for guile-devel@m.gmane.org; Thu, 29 Oct 2009 21:59:26 +0100 Original-Received: from localhost ([127.0.0.1]:40994 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1N3c5d-0007GF-4l for guile-devel@m.gmane.org; Thu, 29 Oct 2009 16:59:25 -0400 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1N3c4y-0006lD-RZ for guile-devel@gnu.org; Thu, 29 Oct 2009 16:58:44 -0400 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1N3c4u-0006iq-Rg for guile-devel@gnu.org; Thu, 29 Oct 2009 16:58:44 -0400 Original-Received: from [199.232.76.173] (port=39326 helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1N3c4u-0006il-NE for guile-devel@gnu.org; Thu, 29 Oct 2009 16:58:40 -0400 Original-Received: from mail.gmx.net ([213.165.64.20]:59695) by monty-python.gnu.org with smtp (Exim 4.60) (envelope-from ) id 1N3c4t-0003a7-QO for guile-devel@gnu.org; Thu, 29 Oct 2009 16:58:40 -0400 Original-Received: (qmail invoked by alias); 29 Oct 2009 20:58:38 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp033) with SMTP; 29 Oct 2009 21:58:38 +0100 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX1/0FCcrdRj0cOhE8PpO9rLjVgUeEeLA2lMYiHVKto 1sj+zuFXEdFNmT Original-Received: by nathot.lan (Postfix, from userid 121) id CAF663A68F; Thu, 29 Oct 2009 21:58:37 +0100 (CET) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id 535903A685 for ; Thu, 29 Oct 2009 21:55:35 +0100 (CET) Original-Received: by delenn.lan (Postfix, from userid 1000) id D5D1874EC0; Thu, 29 Oct 2009 21:55:34 +0100 (CET) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.1 (gnu/linux) X-Y-GMX-Trusted: 0 X-FuHaFi: 0.66 X-detected-operating-system: by monty-python.gnu.org: GNU/Linux 2.6, seldom 2.4 (older, 4) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:9605 Archived-At: --=-=-= 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) )) 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 ] --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=syncase-tail-patterns.diff 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) --=-=-= [0] Regards, Rotty -- Andreas Rottmann -- --=-=-=--