suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Start add match-...-nesting parameter.

Browse Source 
svn: r8371
This commit is contained in:
Sam Tobin-Hochstadt 2008-01-20 14:35:58 +00:00
parent 67aff4881c
commit f2c9c59b06
1 changed files with 20 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/mzlib/private/match/simplify-patterns.ss
View File

@ -2,6 +2,8 @@
(require (lib "stx.ss" "syntax")) (require (lib "stx.ss" "syntax"))
(require scheme/list)
(require "match-error.ss" (require "match-error.ss"
"match-helper.ss" "match-helper.ss"
"test-structure.scm" "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 ;; simplifies patterns by removing syntactic sugar and expanding match-expanders
@ -107,6 +111,20 @@
[(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")] [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")]
;; aggregates ;; 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 ...) [(kw pats ...)
(memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)) (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not))
(with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))])