From f2c9c59b06926325841f4bf7ff17fc5d79e10b7a Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 20 Jan 2008 14:35:58 +0000 Subject: [PATCH] Start add match-...-nesting parameter. svn: r8371 --- .../mzlib/private/match/simplify-patterns.ss | 22 +++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss index 504aa65bf3..b1d4f3c00c 100644 --- a/collects/mzlib/private/match/simplify-patterns.ss +++ b/collects/mzlib/private/match/simplify-patterns.ss @@ -2,6 +2,8 @@ (require (lib "stx.ss" "syntax")) + (require scheme/list) + (require "match-error.ss" "match-helper.ss" "test-structure.scm" @@ -26,7 +28,9 @@ - (provide simplify) + (provide simplify match-...-nesting) + + (define match-...-nesting (make-parameter 0)) ;; simplifies patterns by removing syntactic sugar and expanding match-expanders @@ -107,10 +111,24 @@ [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")] ;; aggregates + + [(kw pats ... last ddk) + (and (stx-dot-dot-k? #'ddk) + (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not))) + (with-syntax ([(pats* ...) (append (syntax-map simplify/i #'(pats ...)) + (parameterize ([match-...-nesting (add1 (match-...-nesting))]) + (list (simplify/i #'last))))]) + #;(printf "kw: ~a~n" (syntax-object->datum stx)) + (quasisyntax/loc stx (kw pats* ... ddk))) + #; + (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))] + [last* (parameterize ([match-...-nesting (add1 (match-...-nesting))]) + (simplify/i #'last))]) + (syntax/loc stx (kw pats* ... last* ddk)))] [(kw pats ...) (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]) - (syntax/loc stx (kw pats* ...)))] + (syntax/loc stx (kw pats* ...)))] [(kw pats ... . rest) (match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))]