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

Add mlist patterns, and handle ...

Browse Source 
svn: r9774
This commit is contained in:
Sam Tobin-Hochstadt 2008-05-09 19:47:28 +00:00
parent ad4cd48f8b
commit 2bf93a2fa0
6 changed files with 74 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/scheme/match/compiler.ss
View File

@ -307,6 +307,8 @@
[maxs (GSeq-maxs first)]
[onces? (GSeq-onces? first)]
[tail (GSeq-tail first)]
[mutable? (GSeq-mutable? first)]
[make-Pair (if mutable? make-MPair make-Pair)]
[k (Row-rhs (car block))]
[xvar (car (generate-temporaries (list #'x)))]
[complete-heads-pattern

50
collects/scheme/match/parse-helper.ss
View File

@ -48,17 +48,19 @@
;; p : the repeated pattern
;; dd : the ... stx
;; rest : the syntax for the rest
(define (dd-parse parse p dd rest)
(define (dd-parse parse p dd rest #:mutable [mutable? #f])
(let* ([count (ddk? dd)]
[min (and (number? count) count)])
(make-GSeq (parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (parse p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(parse rest))))
(make-GSeq
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
(list (list (parse p))))
(list min)
;; no upper bound
(list #f)
;; patterns in p get bound to lists
(list #f)
(parse rest)
mutable?)))
;; stx : the syntax object for the whole pattern
;; cert : the certifier
@ -93,18 +95,24 @@
[(not (car acc)) (cdr acc)]
[else acc])])
(make-Struct id pred (get-lineage (cert struct-name)) acc
(if (eq? '_ (syntax-e pats))
(map make-Dummy acc)
(let* ([ps (syntax->list pats)])
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))))))))
(cond [(eq? '_ (syntax-e pats))
(map make-Dummy acc)]
[(syntax->list pats)
=>
(lambda (ps)
(unless (= (length ps) (length acc))
(raise-syntax-error
'match
(format "~a structure ~a: expected ~a but got ~a"
"wrong number for fields for"
(syntax->datum struct-name) (length acc)
(length ps))
stx pats))
(map parse ps))]
[else (raise-syntax-error
'match
"improper syntax for struct pattern"
stx pats)]))))))
(define (trans-match pred transformer pat)
(make-And (list (make-Pred pred) (make-App transformer pat))))

6
collects/scheme/match/parse-quasi.ss
View File

@ -25,7 +25,8 @@
(GSeq-mins p1)
(GSeq-maxs p1)
(GSeq-onces? p1)
(append-pats (GSeq-tail p1) p2))]
(append-pats (GSeq-tail p1) p2)
(GSeq-mutable? p1))]
[(Null? p1) p2]
[else (error 'match "illegal input to append-pats")]))
@ -55,7 +56,8 @@
(list #f)
;; patterns in p get bound to lists
(list #f)
(make-Null (make-Dummy #f))))]
(make-Null (make-Dummy #f))
#f))]
[(a . b) (make-Pair (pq #'a) (pq #'b))]
;; the hard cases
[#(p ...)

17
collects/scheme/match/parse.ss
View File

@ -24,7 +24,7 @@
(define (parse stx) (parse/cert stx cert))
(syntax-case* stx (not var struct box cons list vector ? and or quote app
regexp pregexp list-rest list-no-order hash-table
quasiquote mcons list*)
quasiquote mcons list* mlist)
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
[(expander args ...)
(and (identifier? #'expander)
@ -104,7 +104,8 @@
(cons max (map (lambda _ 1) ps))
;; vars in lp are lists, vars elsewhere are not
(cons #f (map (lambda _ #t) ps))
(make-Null (make-Dummy #f))))]
(make-Null (make-Dummy #f))
#f))]
[(list-no-order p ...)
(ormap ddk? (syntax->list #'(p ...)))
(raise-syntax-error
@ -118,16 +119,26 @@
(map (lambda _ 1) ps)
;; all of these patterns get bound to only one thing
(map (lambda _ #t) ps)
(make-Null (make-Dummy #f))))]
(make-Null (make-Dummy #f))
#f))]
[(list) (make-Null (make-Dummy stx))]
[(mlist) (make-Null (make-Dummy stx))]
[(list ..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(mlist ..)
(ddk? #'..)
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
[(list p .. . rest)
(ddk? #'..)
(dd-parse parse #'p #'.. (syntax/loc stx (list . rest)))]
[(mlist p .. . rest)
(ddk? #'..)
(dd-parse parse #'p #'.. (syntax/loc stx (list . rest)) #:mutable #t)]
[(list e es ...)
(make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))]
[(mlist e es ...)
(make-MPair (parse #'e) (parse (syntax/loc stx (mlist es ...))))]
[(list* . rest)
(parse (syntax/loc stx (list-rest . rest)))]
[(list-rest e)

3
collects/scheme/match/patterns.ss
View File

@ -84,7 +84,8 @@
;; onces? : listof boolean -- is this pattern being bound only once (take the
;; car of the variables)
;; tail : pattern
(define-struct (GSeq Pat) (headss mins maxs onces? tail) #:transparent)
;; mutable? : is this for mutable lists?
(define-struct (GSeq Pat) (headss mins maxs onces? tail mutable?) #:transparent)
;; match with equal?
;; v is a quotable scheme value

24
collects/tests/match/examples.ss
View File

@ -1,8 +1,10 @@
#lang scheme/base
(require scheme/match
scheme/mpair
(for-syntax scheme/base)
(prefix-in m: mzlib/match))
(prefix-in m: mzlib/match)
(only-in srfi/13 string-contains))
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
@ -516,6 +518,16 @@
[(mcons a b) (+ a b)]
[_ 'no]))
(comp 3
(match (mlist 1 2)
[(mlist a b) (+ a b)]
[_ 'no]))
(comp 3
(match (mlist 1 2)
[(mlist a ...) (apply + a)]
[_ 'no]))
(comp 1
(match (box 'x) ('#&x 1) (else #f)))
@ -527,6 +539,16 @@
[values (lambda _ 'no)])
(match 1)
'no))
(comp 'yes
(with-handlers ([exn:fail:syntax? (lambda _ 'yes)]
[values (lambda _ 'no)])
(expand #'(let ()
(define-struct foo (bar))
(define the-bar (match (make-foo 42)
[(struct foo bar) ;; note the bad syntax
bar]))
0))))
;; raises error
(comp 'yes (with-handlers ([exn:fail:syntax? (lambda _ 'yes)])