From 6639a2982927729466b32da3cae75a0f99db33ed Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 1 Dec 2009 20:39:46 +0000 Subject: [PATCH] non-greedy matching svn: r17149 --- collects/honu/private/macro.ss | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/collects/honu/private/macro.ss b/collects/honu/private/macro.ss index 934bad9a77..1043c8c224 100644 --- a/collects/honu/private/macro.ss +++ b/collects/honu/private/macro.ss @@ -368,12 +368,26 @@ (#%braces (#%braces name pattern ...)) (#%braces (#%braces template ...)) . rest) - (with-syntax ([pulled (pull #'(template ...))]) + (with-syntax ([pulled (pull #'(template ...))] + [(pattern* ...) (map (lambda (stx) + (if (and (identifier? stx) + (not (ormap (lambda (f) + (free-identifier=? stx f)) + (syntax->list #'(honu-literal ...)))) + (not (free-identifier=? stx #'(... ...)))) + (with-syntax ([x stx]) + #'(~and x (~not (~or honu-literal ...)))) + stx)) + (syntax->list #'(pattern ...)))] + ) (values #'(define-honu-syntax name (lambda (stx ctx) - (syntax-case stx (honu-literal ...) - [(name pattern ... . rrest) + ;; (define-literal-set literals (honu-literal ...)) + (syntax-parse stx + ;; #:literal-sets (literals) + #:literals (honu-literal ...) + [(name pattern* ... . rrest) (with-syntax ([(out (... ...)) (unpull #'pulled)]) (values #'(honu-unparsed-block