From fac8cf73288320d18308cb40f66aafd32e04a6c0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 1 Apr 2008 20:37:55 +0000 Subject: [PATCH] minor svn: r9127 --- collects/scheme/match/compiler.ss | 445 +++++++++++++----------- collects/scheme/match/define-forms.ss | 75 ++-- collects/scheme/match/gen-match.ss | 82 +++-- collects/scheme/match/legacy-match.ss | 22 +- collects/scheme/match/match-expander.ss | 73 ++-- collects/scheme/match/match.ss | 22 +- collects/scheme/match/parse-helper.ss | 152 ++++---- collects/scheme/match/parse-legacy.ss | 27 +- collects/scheme/match/parse-quasi.ss | 38 +- collects/scheme/match/parse.ss | 110 +++--- collects/scheme/match/patterns.ss | 106 +++--- collects/scheme/match/split-rows.ss | 132 ++++--- 12 files changed, 680 insertions(+), 604 deletions(-) diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss index 16746d99ad..2b13087f8b 100644 --- a/collects/scheme/match/compiler.ss +++ b/collects/scheme/match/compiler.ss @@ -1,8 +1,6 @@ #lang scheme/base (require (for-template scheme/base "patterns.ss" scheme/stxparam) - mzlib/trace - mzlib/etc syntax/boundmap syntax/stx "patterns.ss" @@ -19,11 +17,11 @@ (define (hash-on f elems #:equal? [eql #t]) (define ht (apply make-hash-table (if eql (list 'equal) null))) ;; put all the elements e in the ht, indexed by (f e) - (for-each (lambda (r) - (define k (f r)) - (hash-table-put! ht k (cons r (hash-table-get ht k (lambda () null))))) - ;; they need to be in the original order when they come out - (reverse elems)) + (for ([r + ;; they need to be in the original order when they come out + (reverse elems)]) + (define k (f r)) + (hash-table-put! ht k (cons r (hash-table-get ht k (lambda () null))))) ht) ;; generate a clause of kind k @@ -31,15 +29,17 @@ ;; escaping to esc (define (gen-clause k rows x xs esc) (define-syntax-rule (constant-pat predicate-stx) - (with-syntax - ([rhs - (compile* (cons x xs) - (map (lambda (row) - (define-values (p ps) (Row-split-pats row)) - (define p* (Atom-p p)) - (make-Row (cons p* ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))) - rows) - esc)]) + (with-syntax ([rhs (compile* (cons x xs) + (map (lambda (row) + (define-values (p ps) + (Row-split-pats row)) + (define p* (Atom-p p)) + (make-Row (cons p* ps) + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) + rows) + esc)]) #`[(#,predicate-stx #,x) rhs])) (define (compile-con-pat accs pred pat-acc) (with-syntax ([(tmps ...) (generate-temporaries accs)]) @@ -49,20 +49,21 @@ (append (syntax->list #'(tmps ...)) xs) (map (lambda (row) (define-values (p1 ps) (Row-split-pats row)) - (make-Row (append (pat-acc p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))) + (make-Row (append (pat-acc p1) ps) + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) rows) esc)]) - #`[(pred #,x) - (let ([tmps (accs #,x)] ...) - body)]))) + #`[(pred #,x) (let ([tmps (accs #,x)] ...) body)]))) (cond - [(eq? 'box k) + [(eq? 'box k) (compile-con-pat (list #'unbox) #'box? (compose list Box-p))] [(eq? 'pair k) - (compile-con-pat (list #'car #'cdr) #'pair? + (compile-con-pat (list #'car #'cdr) #'pair? (lambda (p) (list (Pair-a p) (Pair-d p))))] [(eq? 'mpair k) - (compile-con-pat (list #'mcar #'mcdr) #'mpair? + (compile-con-pat (list #'mcar #'mcdr) #'mpair? (lambda (p) (list (MPair-a p) (MPair-d p))))] [(eq? 'string k) (constant-pat #'string?)] [(eq? 'number k) (constant-pat #'number?)] @@ -77,32 +78,36 @@ ;; because each arity is like a different constructor [(eq? 'vector k) (let () - (define ht (hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows)) - (with-syntax ([(clauses ...) - (hash-table-map - ht - (lambda (arity rows) - (define ns (build-list arity values)) - (with-syntax ([(tmps ...) (generate-temporaries ns)]) - (with-syntax - ([body (compile* (append (syntax->list #'(tmps ...)) xs) - (map (lambda (row) - (define-values (p1 ps) (Row-split-pats row)) - (make-Row (append (Vector-ps p1) ps) - (Row-rhs row) - (Row-unmatch row) - (Row-vars-seen row))) - rows) - esc)] + (define ht + (hash-on (lambda (r) (length (Vector-ps (Row-first-pat r)))) rows)) + (with-syntax + ([(clauses ...) + (hash-table-map + ht + (lambda (arity rows) + (define ns (build-list arity values)) + (with-syntax ([(tmps ...) (generate-temporaries ns)]) + (with-syntax ([body + (compile* + (append (syntax->list #'(tmps ...)) xs) + (map (lambda (row) + (define-values (p1 ps) + (Row-split-pats row)) + (make-Row (append (Vector-ps p1) ps) + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) + rows) + esc)] [(n ...) ns]) - #`[(#,arity) - (let ([tmps (vector-ref #,x n)] ...) - body)]))))]) + #`[(#,arity) + (let ([tmps (vector-ref #,x n)] ...) + body)]))))]) #`[(vector? #,x) (case (vector-length #,x) - clauses ...)]))] + clauses ...)]))] ;; it's a structure - [(box? k) + [(box? k) ;; all the rows are structures with the same predicate (let* ([s (Row-first-pat (car rows))] [accs (Struct-accessors s)] @@ -110,94 +115,115 @@ (compile-con-pat accs pred Struct-ps))] [else (error 'compile "bad key: ~a" k)])) - ;; produces the syntax for a let clause (define (compile-one vars block esc) (define-values (first rest-pats) (Row-split-pats (car block))) (define x (car vars)) (define xs (cdr vars)) - (cond + (cond ;; the Exact rule [(Exact? first) (let ([ht (hash-on (compose Exact-v Row-first-pat) block #:equal? #t)]) - (with-syntax ([(clauses ...) (hash-table-map - ht - (lambda (k v) - #`[(equal? #,x '#,k) - #,(compile* xs - (map (lambda (row) - (make-Row (cdr (Row-pats row)) - (Row-rhs row) - (Row-unmatch row) - (Row-vars-seen row))) - v) - esc)]))]) + (with-syntax ([(clauses ...) + (hash-table-map + ht + (lambda (k v) + #`[(equal? #,x '#,k) + #,(compile* xs + (map (lambda (row) + (make-Row (cdr (Row-pats row)) + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) + v) + esc)]))]) #`(cond clauses ... [else (#,esc)])))] ;; the Var rule [(Var? first) - (let ([transform (lambda (row) - (define-values (p ps) (Row-split-pats row)) - (define v (Var-v p)) - (define seen (Row-vars-seen row)) - ;; a new row with the rest of the patterns - (cond - ;; if this was a wild-card variable, don't bind - [(Dummy? p) (make-Row ps (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))] - ;; if we've seen this variable before, check that it's equal to the one we saw - [(ormap (lambda (e) - (let ([v* (car e)] - [id (cdr e)]) - (and (bound-identifier=? v v*) id))) - seen) - => - (lambda (id) - (make-Row ps - #`(if ((match-equality-test) #,x #,id) - #,(Row-rhs row) - (fail)) - (Row-unmatch row) - seen))] - ;;otherwise, bind the matched variable to x, and add it to the list of vars we've seen - [else (let ([v* (free-identifier-mapping-get (current-renaming) v (lambda () v))]) - (make-Row ps - #`(let ([#,v* #,x]) #,(Row-rhs row)) - (Row-unmatch row) - (cons (cons v x) (Row-vars-seen row))))]))]) + (let ([transform + (lambda (row) + (define-values (p ps) (Row-split-pats row)) + (define v (Var-v p)) + (define seen (Row-vars-seen row)) + ;; a new row with the rest of the patterns + (cond + ;; if this was a wild-card variable, don't bind + [(Dummy? p) (make-Row ps + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))] + ;; if we've seen this variable before, check that it's equal to + ;; the one we saw + [(ormap (lambda (e) + (let ([v* (car e)] [id (cdr e)]) + (and (bound-identifier=? v v*) id))) + seen) + => + (lambda (id) + (make-Row ps + #`(if ((match-equality-test) #,x #,id) + #,(Row-rhs row) + (fail)) + (Row-unmatch row) + seen))] + ;; otherwise, bind the matched variable to x, and add it to the + ;; list of vars we've seen + [else (let ([v* (free-identifier-mapping-get + (current-renaming) v (lambda () v))]) + (make-Row ps + #`(let ([#,v* #,x]) #,(Row-rhs row)) + (Row-unmatch row) + (cons (cons v x) (Row-vars-seen row))))]))]) ;; compile the transformed block (compile* xs (map transform block) esc))] ;; the Constructor rule [(CPat? first) (let ;; put all the rows in the hash-table, indexed by their constructor ([ht (hash-on (lambda (r) (pat-key (Row-first-pat r))) block)]) - (with-syntax ([(clauses ...) (hash-table-map ht (lambda (k v) (gen-clause k v x xs esc)))]) + (with-syntax ([(clauses ...) + (hash-table-map + ht (lambda (k v) (gen-clause k v x xs esc)))]) #`(cond clauses ... [else (#,esc)])))] ;; the Or rule [(Or? first) - ;; we only handle 1-row Ors atm - this is all the mixture rule should give us + ;; we only handle 1-row Ors atm - this is all the mixture rule should give + ;; us (unless (null? (cdr block)) (error 'compile-one "Or block with multiple rows: ~a" block)) (let* ([row (car block)] [pats (Row-pats row)] ;; all the pattern alternatives [qs (Or-ps (car pats))] - ;; the variables bound by this pattern - they're the same for the whole list + ;; the variables bound by this pattern - they're the same for the + ;; whole list [vars (bound-vars (car qs))]) (with-syntax ([vars vars]) - ;; do the or matching, and bind the results to the appropriate variables + ;; do the or matching, and bind the results to the appropriate + ;; variables #`(let/ec exit (let ([esc* (lambda () (exit (#,esc)))]) - (let-values ([vars #,(compile* (list x) (map (lambda (q) (make-Row (list q) #'(values . vars) #f (Row-vars-seen row))) - qs) - #'esc*)]) + (let-values ([vars + #,(compile* (list x) + (map (lambda (q) + (make-Row (list q) + #'(values . vars) + #f + (Row-vars-seen row))) + qs) + #'esc*)]) ;; then compile the rest of the row - #,(compile* xs - (list (make-Row (cdr pats) (Row-rhs row) (Row-unmatch row) + #,(compile* xs + (list (make-Row (cdr pats) + (Row-rhs row) + (Row-unmatch row) (let ([vs (syntax->list #'vars)]) - (append (map cons vs vs) (Row-vars-seen row))))) + (append (map cons vs vs) + (Row-vars-seen row))))) esc))))))] ;; the App rule [(App? first) - ;; we only handle 1-row Apps atm - this is all the mixture rule should give us + ;; we only handle 1-row Apps atm - this is all the mixture rule should + ;; give us (unless (null? (cdr block)) (error 'compile-one "App block with multiple rows: ~a" block)) (let* ([row (car block)] @@ -205,11 +231,15 @@ (with-syntax ([(t) (generate-temporaries #'(t))]) #`(let ([t (#,(App-expr first) #,x)]) #,(compile* (cons #'t xs) - (list (make-Row (cons (App-p first) (cdr pats)) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))) + (list (make-Row (cons (App-p first) (cdr pats)) + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) esc))))] ;; the And rule [(And? first) - ;; we only handle 1-row Ands atm - this is all the mixture rule should give us + ;; we only handle 1-row Ands atm - this is all the mixture rule should + ;; give us (unless (null? (cdr block)) (error 'compile-one "And block with multiple rows: ~a" block)) (let* ([row (car block)] @@ -217,11 +247,15 @@ ;; all the patterns [qs (And-ps (car pats))]) (compile* (append (map (lambda _ x) qs) xs) - (list (make-Row (append qs (cdr pats)) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))) + (list (make-Row (append qs (cdr pats)) + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) esc))] ;; the Not rule [(Not? first) - ;; we only handle 1-row Nots atm - this is all the mixture rule should give us + ;; we only handle 1-row Nots atm - this is all the mixture rule should + ;; give us (unless (null? (cdr block)) (error 'compile-one "Not block with multiple rows: ~a" block)) (let* ([row (car block)] @@ -229,23 +263,33 @@ ;; the single pattern [q (Not-p (car pats))]) (with-syntax ([(f) (generate-temporaries #'(f))]) - #`(let - ;; if q fails, we jump to here - ([f (lambda () - #,(compile* xs - (list (make-Row (cdr pats) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))) - esc))]) + #`(let ;; if q fails, we jump to here + ([f (lambda () + #,(compile* xs + (list (make-Row (cdr pats) + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) + esc))]) #,(compile* (list x) - ;; if q doesn't fail, we jump to esc and fail the not pattern - (list (make-Row (list q) #`(#,esc) (Row-unmatch row) (Row-vars-seen row))) + ;; if q doesn't fail, we jump to esc and fail the not + ;; pattern + (list (make-Row (list q) + #`(#,esc) + (Row-unmatch row) + (Row-vars-seen row))) #'f))))] - [(Pred? first) - ;; multiple preds iff they have the identical predicate + [(Pred? first) + ;; multiple preds iff they have the identical predicate (with-syntax ([pred? (Pred-pred first)] [body (compile* xs (map (lambda (row) - (define-values (_1 ps) (Row-split-pats row)) - (make-Row ps (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))) + (define-values (_1 ps) + (Row-split-pats row)) + (make-Row ps + (Row-rhs row) + (Row-unmatch row) + (Row-vars-seen row))) block) esc)]) #`(cond [(pred? #,x) body] [else (#,esc)]))] @@ -262,9 +306,8 @@ (lambda (ps) (define (loop ps pat) (if (pair? ps) - (make-Pair (car ps) - (loop (cdr ps) pat)) - pat)) + (make-Pair (car ps) (loop (cdr ps) pat)) + pat)) (loop ps (make-Var xvar)))] [heads (for/list ([ps headss]) @@ -285,106 +328,116 @@ [(maxrepconstraint ...) ;; FIXME: move to side condition to appropriate pattern (for/list ([repvar reps] [maxrep maxs]) - (if maxrep - #`(< #,repvar #,maxrep) - #`#t))] + (if maxrep #`(< #,repvar #,maxrep) #`#t))] [(minrepclause ...) (for/list ([repvar reps] [minrep mins] #:when minrep) - #`[(< #,repvar #,minrep) - (fail)])] + #`[(< #,repvar #,minrep) (fail)])] [((hid-rhs ...) ...) (for/list ([hid-args hid-argss] [once? onces?]) - (for/list ([hid-arg hid-args]) - (if once? - #`(car (reverse #,hid-arg)) - #`(reverse #,hid-arg))))] - [(parse-loop failkv fail-tail) (generate-temporaries #'(parse-loop failkv fail-tail))]) + (for/list ([hid-arg hid-args]) + (if once? + #`(car (reverse #,hid-arg)) + #`(reverse #,hid-arg))))] + [(parse-loop failkv fail-tail) + (generate-temporaries #'(parse-loop failkv fail-tail))]) (with-syntax ([(rhs ...) #`[(let ([hid-arg (cons hid* hid-arg)] ...) (if maxrepconstraint - (let ([rep (add1 rep)]) - (parse-loop x #,@hid-args #,@reps fail)) - (begin - (fail)))) + (let ([rep (add1 rep)]) + (parse-loop x #,@hid-args #,@reps fail)) + (begin (fail)))) ...]] [tail-rhs #`(cond minrepclause ... [else (let ([hid hid-rhs] ... ... [fail-tail fail]) - #,(compile* (cdr vars) - (list (make-Row rest-pats k (Row-unmatch (car block)) (Row-vars-seen (car block)))) - #'fail-tail))])]) - (parameterize ([current-renaming - (for/fold ([ht (copy-mapping (current-renaming))]) - ([id (apply append head-idss)] - [id* (apply append head-idss*)]) - (free-identifier-mapping-put! ht id id*) - (free-identifier-mapping-for-each - ht - (lambda (k v) - (when (free-identifier=? v id) - (free-identifier-mapping-put! ht k id*)))) - ht)]) - #`(let parse-loop ([x var0] [hid-arg null] ... ... [rep 0] ... [failkv #,esc]) - #,(compile* (list #'x) + #,(compile* + (cdr vars) + (list (make-Row rest-pats k + (Row-unmatch (car block)) + (Row-vars-seen + (car block)))) + #'fail-tail))])]) + (parameterize ([current-renaming + (for/fold ([ht (copy-mapping (current-renaming))]) + ([id (apply append head-idss)] + [id* (apply append head-idss*)]) + (free-identifier-mapping-put! ht id id*) + (free-identifier-mapping-for-each + ht + (lambda (k v) + (when (free-identifier=? v id) + (free-identifier-mapping-put! ht k id*)))) + ht)]) + #`(let parse-loop ([x var0] + [hid-arg null] ... ... + [rep 0] ... + [failkv #,esc]) + #,(compile* (list #'x) (append - (map (lambda (pats rhs) (make-Row pats rhs (Row-unmatch (car block)) null)) + (map (lambda (pats rhs) + (make-Row pats + rhs + (Row-unmatch (car block)) + null)) (map list heads) (syntax->list #'(rhs ...))) - (list (make-Row (list tail) #`tail-rhs (Row-unmatch (car block)) null))) + (list (make-Row (list tail) + #`tail-rhs + (Row-unmatch (car block)) + null))) #'failkv))))))] - [else (error 'compile "unsupported pattern: ~a~n" first)])) + [else (error 'compile "unsupported pattern: ~a~n" first)])) (define (compile* vars rows esc) (define (let/wrap clauses body) - (if (stx-null? clauses) - body - (quasisyntax (let* #,clauses #,body)))) + (if (stx-null? clauses) + body + (quasisyntax (let* #,clauses #,body)))) (if (null? vars) - ;; if we have no variables, there are no more patterns to match - ;; so we just pick the first RHS - (let ([fns - (let loop ([blocks (reverse rows)] [esc esc] [acc null]) - (cond - ;; if we're done, return the blocks - [(null? blocks) (reverse acc)] - [else (with-syntax (;; f is the name this block will have - [(f) (generate-temporaries #'(f))] - ;; compile the block, with jumps to the previous esc - [c (with-syntax ([rhs #`(syntax-parameterize ([fail (make-rename-transformer (quote-syntax #,esc))]) - #,(Row-rhs (car blocks)))]) - (if - (Row-unmatch (car blocks)) - #`(let/ec k - (let ([#,(Row-unmatch (car blocks)) (lambda () (k (#,esc)))]) - rhs)) - #'rhs))]) - ;; then compile the rest, with our name as the esc - (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))]))]) - (with-syntax ([(fns ... [_ (lambda () body)]) fns]) - (let/wrap #'(fns ...) #'body))) - - ;; otherwise, we split the matrix into blocks - ;; and compile each block with a reference to its continuation - (let ([fns - (let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null]) - (cond - ;; if we're done, return the blocks - [(null? blocks) (reverse acc)] - [else (with-syntax (;; f is the name this block will have - [(f) (generate-temporaries #'(f))] - ;; compile the block, with jumps to the previous esc - [c (compile-one vars (car blocks) esc)]) - ;; then compile the rest, with our name as the esc - (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))]))]) + ;; if we have no variables, there are no more patterns to match + ;; so we just pick the first RHS + (let ([fns + (let loop ([blocks (reverse rows)] [esc esc] [acc null]) + (if (null? blocks) + ;; if we're done, return the blocks + (reverse acc) + (with-syntax + (;; f is the name this block will have + [(f) (generate-temporaries #'(f))] + ;; compile the block, with jumps to the previous esc + [c (with-syntax ([rhs #`(syntax-parameterize + ([fail (make-rename-transformer + (quote-syntax #,esc))]) + #,(Row-rhs (car blocks)))]) + (if (Row-unmatch (car blocks)) + #`(let/ec k + (let ([#,(Row-unmatch (car blocks)) + (lambda () (k (#,esc)))]) + rhs)) + #'rhs))]) + ;; then compile the rest, with our name as the esc + (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))]) + (with-syntax ([(fns ... [_ (lambda () body)]) fns]) + (let/wrap #'(fns ...) #'body))) + + ;; otherwise, we split the matrix into blocks + ;; and compile each block with a reference to its continuation + (let ([fns + (let loop ([blocks (reverse (split-rows rows))] [esc esc] [acc null]) + (if (null? blocks) + ;; if we're done, return the blocks + (reverse acc) + (with-syntax (;; f is the name this block will have + [(f) (generate-temporaries #'(f))] + ;; compile the block, with jumps to the previous + ;; esc + [c (compile-one vars (car blocks) esc)]) + ;; then compile the rest, with our name as the esc + (loop (cdr blocks) #'f (cons #'[f (lambda () c)] acc)))))]) (with-syntax ([(fns ... [_ (lambda () body)]) fns]) (let/wrap #'(fns ...) #'body))))) - - - - - - -;(trace compile* compile-one) +;; (require mzlib/trace) +;; (trace compile* compile-one) diff --git a/collects/scheme/match/define-forms.ss b/collects/scheme/match/define-forms.ss index a75643183d..1d899b17aa 100644 --- a/collects/scheme/match/define-forms.ss +++ b/collects/scheme/match/define-forms.ss @@ -8,32 +8,29 @@ (provide define-forms) -(define-syntax-rule (define-forms parse-id - match match* match-lambda match-lambda* match-let match-let* match-define match-letrec) +(define-syntax-rule (define-forms parse-id + match match* match-lambda match-lambda* match-let + match-let* match-define match-letrec) (... (begin - (provide match match* match-lambda match-lambda* match-let match-let* match-define match-letrec) + (provide match match* match-lambda match-lambda* match-let match-let* + match-define match-letrec) (define-syntax (match* stx) (syntax-case stx () [(_ es . clauses) (go parse-id stx #'es #'clauses (syntax-local-certifier))])) - + (define-syntax-rule (match arg [p . es] ...) - (match* (arg) - [(p) . es] - ...)) - - + (match* (arg) [(p) . es] ...)) + (define-syntax (match-lambda stx) (syntax-case stx () - [(k . clauses) - (syntax/loc stx (lambda (exp) (match exp . clauses)))])) - + [(k . clauses) (syntax/loc stx (lambda (exp) (match exp . clauses)))])) + (define-syntax (match-lambda* stx) (syntax-case stx () - [(k . clauses) - (syntax/loc stx (lambda exp (match exp . clauses)))])) - + [(k . clauses) (syntax/loc stx (lambda exp (match exp . clauses)))])) + (define-syntax (match-lambda** stx) (syntax-case stx () [(k [pats . rhs] ...) @@ -41,13 +38,14 @@ [ps1 (car pss)] [len (length (syntax->list ps1))]) (for/list ([ps pss]) - (unless (= (length (syntax->list ps)) len) - (raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps ps1))) + (unless (= (length (syntax->list ps)) len) + (raise-syntax-error + 'match "unequal number of patterns in match clauses" + stx ps ps1))) (with-syntax ([(vars ...) (generate-temporaries (car pss))]) - (syntax/loc stx (lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))])) - - - + (syntax/loc stx + (lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))])) + ;; there's lots of duplication here to handle named let ;; some factoring out would do a lot of good (define-syntax (match-let stx) @@ -58,36 +56,33 @@ (match:syntax-err stx "bad syntax (empty body)")] [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] ;; with no bindings, there's nothing to do - [(_ name () body ...) + [(_ name () body ...) (identifier? #'name) (syntax/loc stx (let name () body ...))] [(_ () body ...) (syntax/loc stx (let () body ...))] - ;; optimize the all-variable case + ;; optimize the all-variable case [(_ ([pat exp]...) body ...) (andmap pattern-var? (syntax->list #'(pat ...))) - (syntax/loc stx (let name ([pat exp] ...) body ...))] + (syntax/loc stx (let name ([pat exp] ...) body ...))] [(_ name ([pat exp]...) body ...) (and (identifier? (syntax name)) (andmap pattern-var? (syntax->list #'(pat ...)))) (syntax/loc stx (let name ([pat exp] ...) body ...))] ;; now the real cases [(_ name ([pat exp] ...) . body) - (syntax/loc stx (letrec ([name (match-lambda** ((pat ...) . body))]) + (syntax/loc stx (letrec ([name (match-lambda** ((pat ...) . body))]) (name exp ...)))] [(_ ([pat exp] ...) . body) (syntax/loc stx (match* (exp ...) [(pat ...) . body]))])) - + (define-syntax (match-let* stx) (syntax-case stx () [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] - ((_ () body ...) - (syntax/loc stx (let* () body ...))) - ((_ ([pat exp] rest ...) body ...) - (syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))) - )) - - - + [(_ () body ...) + (syntax/loc stx (let* () body ...))] + [(_ ([pat exp] rest ...) body ...) + (syntax/loc stx (match exp [pat (match-let* (rest ...) body ...)]))])) + (define-syntax (match-letrec stx) (syntax-case stx () [(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")] @@ -96,12 +91,8 @@ (syntax->list #'(pat ...))) (syntax/loc stx (letrec ([pat exp] ...) . body))] [(_ ([pat exp] ...) . body) - (syntax/loc stx (let () - (match-define pat exp) ... - . body))])) - - - + (syntax/loc stx (let () (match-define pat exp) ... . body))])) + (define-syntax (match-define stx) (syntax-case stx () [(_ pat exp) @@ -112,6 +103,4 @@ (let ([p (parse-id #'pat (syntax-local-certifier))]) (with-syntax ([vars (bound-vars p)]) (syntax/loc stx - (define-values vars - (match rhs - [pat (values . vars)])))))]))))) \ No newline at end of file + (define-values vars (match rhs [pat (values . vars)])))))]))))) diff --git a/collects/scheme/match/gen-match.ss b/collects/scheme/match/gen-match.ss index 7611f5e9e0..c0f948ba66 100644 --- a/collects/scheme/match/gen-match.ss +++ b/collects/scheme/match/gen-match.ss @@ -10,37 +10,51 @@ ;; go : syntax syntax syntax certifier -> syntax (define (go parse/cert stx exprs clauses cert) (parameterize ([orig-stx stx]) - (syntax-case clauses () - [([pats . rhs] ...) - (let ([len (length (syntax->list exprs))]) - (with-syntax ([(xs ...) (generate-temporaries exprs)] - [(exprs ...) exprs] - [(fail) (generate-temporaries #'(fail))]) - (with-syntax ([body (compile* (syntax->list #'(xs ...)) - (map (lambda (pats rhs) - (unless (= len (length (syntax->list pats))) - (raise-syntax-error 'match - (format "wrong number of match clauses, expected ~a and got ~a" - len (length (syntax->list pats))) - pats)) - (syntax-case* rhs (=>) - (lambda (x y) (eq? (syntax-e x) (syntax-e y))) - [((=> unm) . rhs) - (make-Row (map (lambda (s) (parse/cert s cert)) (syntax->list pats)) - #`(begin . rhs) - #'unm - null)] - [_ - (make-Row (map (lambda (s) (parse/cert s cert)) (syntax->list pats)) - #`(begin . #,rhs) - #f - null)])) - (syntax->list #'(pats ...)) - (syntax->list #'(rhs ...))) - #'fail)] - [orig-expr (if (= 1 len) (stx-car #'(xs ...)) #'(list xs ...))]) - (quasisyntax/loc stx - (let ([xs exprs] - ...) - (let ([fail (lambda () #,(syntax/loc stx (match:error orig-expr)))]) - body))))))]))) \ No newline at end of file + (syntax-case clauses () + [([pats . rhs] ...) + (let ([len (length (syntax->list exprs))]) + (with-syntax ([(xs ...) (generate-temporaries exprs)] + [(exprs ...) exprs] + [(fail) (generate-temporaries #'(fail))]) + (with-syntax ([body (compile* + (syntax->list #'(xs ...)) + (map (lambda (pats rhs) + (unless (= len + (length (syntax->list pats))) + (raise-syntax-error + 'match + (format "~a, expected ~a and got ~a" + "wrong number of match clauses" + len + (length (syntax->list pats))) + pats)) + (syntax-case* rhs (=>) + (lambda (x y) + (eq? (syntax-e x) + (syntax-e y))) + [((=> unm) . rhs) + (make-Row (map (lambda (s) + (parse/cert s cert)) + (syntax->list pats)) + #`(begin . rhs) + #'unm + null)] + [_ + (make-Row (map (lambda (s) + (parse/cert s cert)) + (syntax->list pats)) + #`(begin . #,rhs) + #f + null)])) + (syntax->list #'(pats ...)) + (syntax->list #'(rhs ...))) + #'fail)] + [orig-expr (if (= 1 len) + (stx-car #'(xs ...)) + #'(list xs ...))]) + (quasisyntax/loc stx + (let ([xs exprs] + ...) + (let ([fail (lambda () + #,(syntax/loc stx (match:error orig-expr)))]) + body))))))]))) diff --git a/collects/scheme/match/legacy-match.ss b/collects/scheme/match/legacy-match.ss index 2b58962124..f799de544d 100644 --- a/collects/scheme/match/legacy-match.ss +++ b/collects/scheme/match/legacy-match.ss @@ -1,12 +1,22 @@ #lang scheme/base -(require (only-in "patterns.ss" match-equality-test match-...-nesting exn:misc:match?) - (only-in "match-expander.ss" define-match-expander) +(require (only-in "patterns.ss" + match-equality-test + match-...-nesting + exn:misc:match?) + (only-in "match-expander.ss" + define-match-expander) "define-forms.ss" - (for-syntax "parse-legacy.ss" "gen-match.ss") - (for-syntax (only-in "patterns.ss" match-...-nesting))) + (for-syntax "parse-legacy.ss" + "gen-match.ss" + (only-in "patterns.ss" match-...-nesting))) -(provide (for-syntax match-...-nesting) match-equality-test match-...-nesting define-match-expander exn:misc:match?) +(provide (for-syntax match-...-nesting) + match-equality-test + match-...-nesting + define-match-expander + exn:misc:match?) (define-forms parse/legacy/cert - match match* match-lambda match-lambda* match-let match-let* match-define match-letrec) \ No newline at end of file + match match* match-lambda match-lambda* match-let match-let* + match-define match-letrec) diff --git a/collects/scheme/match/match-expander.ss b/collects/scheme/match/match-expander.ss index 2dffbe66b5..9477148a66 100644 --- a/collects/scheme/match/match-expander.ss +++ b/collects/scheme/match/match-expander.ss @@ -12,19 +12,19 @@ (define (parse args) (let loop ([args args] [alist '()]) - (if (null? args) - alist - (let* ([stx-v (car args)] - [v (syntax-e stx-v)]) - (cond - [(not (keyword? v)) - (raise-syntax-error #f "Argument must be a keyword" stx stx-v)] - [(not (memq v '(#:expression #:plt-match #:match))) - (raise-syntax-error #f (format "Keyword argument ~a is not a correct keyword" v) stx stx-v)] - [else - (loop (cddr args) - (cons (list v (cadr args)) - alist))]))))) + (if (null? args) + alist + (let* ([stx-v (car args)] + [v (syntax-e stx-v)]) + (cond + [(not (keyword? v)) + (raise-syntax-error #f "argument must be a keyword" stx stx-v)] + [(not (memq v '(#:expression #:plt-match #:match))) + (raise-syntax-error + #f (format "keyword argument ~a is not a correct keyword" v) + stx stx-v)] + [else + (loop (cddr args) (cons (list v (cadr args)) alist))]))))) (syntax-case stx () [(_ id kw . rest) (keyword? (syntax-e #'kw)) @@ -33,29 +33,36 @@ (with-syntax ([legacy-xform (lookup '#:match parsed-args)] [match-xform (lookup '#:plt-match parsed-args)] - [macro-xform (or (lookup '#:expression parsed-args) - #'(lambda (stx) - (raise-syntax-error #f "This match expander must be used inside match" stx)))]) + [macro-xform + (or (lookup '#:expression parsed-args) + #'(lambda (stx) + (raise-syntax-error + #f "this match expander must be used inside match" + stx)))]) (if (identifier? #'macro-xform) - (syntax/loc stx - (define-syntax id (make-match-expander match-xform - legacy-xform - (lambda (stx) - (syntax-case stx (set!) - [(nm args (... ...)) #'(macro-xform args (... ...))] - [nm #'macro-xform])) - (syntax-local-certifier)))) - (syntax/loc stx - (define-syntax id (make-match-expander match-xform legacy-xform macro-xform (syntax-local-certifier)))))))] - + (syntax/loc stx + (define-syntax id + (make-match-expander + match-xform + legacy-xform + (lambda (stx) + (syntax-case stx (set!) + [(nm args (... ...)) #'(macro-xform args (... ...))] + [nm #'macro-xform])) + (syntax-local-certifier)))) + (syntax/loc stx + (define-syntax id + (make-match-expander match-xform legacy-xform macro-xform + (syntax-local-certifier)))))))] ;; implement legacy syntax [(_ id plt-match-xform match-xform std-xform) - #'(define-match-expander id #:plt-match plt-match-xform #:match match-xform #:expression std-xform)] + #'(define-match-expander id #:plt-match plt-match-xform + #:match match-xform + #:expression std-xform)] [(_ id plt-match-xform std-xform) - #'(define-match-expander id #:plt-match plt-match-xform #:expression std-xform)] - [(_ id plt-match-xform) + #'(define-match-expander id #:plt-match plt-match-xform + #:expression std-xform)] + [(_ id plt-match-xform) #'(define-match-expander id #:plt-match plt-match-xform)] - ;; error checking - [_ (raise-syntax-error #f "Invalid use of define-match-expander" stx)] - )) \ No newline at end of file + [_ (raise-syntax-error #f "invalid use of define-match-expander" stx)])) diff --git a/collects/scheme/match/match.ss b/collects/scheme/match/match.ss index 52ceb9567a..dd57c96674 100644 --- a/collects/scheme/match/match.ss +++ b/collects/scheme/match/match.ss @@ -1,12 +1,22 @@ #lang scheme/base -(require (only-in "patterns.ss" match-equality-test match-...-nesting exn:misc:match?) - (only-in "match-expander.ss" define-match-expander) +(require (only-in "patterns.ss" + match-equality-test + match-...-nesting + exn:misc:match?) + (only-in "match-expander.ss" + define-match-expander) "define-forms.ss" - (for-syntax "parse.ss" "gen-match.ss") - (for-syntax (only-in "patterns.ss" match-...-nesting))) + (for-syntax "parse.ss" + "gen-match.ss" + (only-in "patterns.ss" match-...-nesting))) -(provide (for-syntax match-...-nesting) match-equality-test match-...-nesting define-match-expander exn:misc:match?) +(provide (for-syntax match-...-nesting) + match-equality-test + match-...-nesting + define-match-expander + exn:misc:match?) (define-forms parse/cert - match match* match-lambda match-lambda* match-let match-let* match-define match-letrec) \ No newline at end of file + match match* match-lambda match-lambda* match-let match-let* + match-define match-letrec) diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss index b7ecd75e9e..84a6827c7f 100644 --- a/collects/scheme/match/parse-helper.ss +++ b/collects/scheme/match/parse-helper.ss @@ -8,16 +8,17 @@ "compiler.ss" (only-in srfi/1 delete-duplicates)) -(provide ddk? parse-literal all-vars pattern-var? match:syntax-err +(provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform matchable? trans-match parse-struct dd-parse parse-quote parse-id) ;; parse x as a match variable ;; x : identifier -(define (parse-id x) +(define (parse-id x) (cond [(eq? '_ (syntax-e x)) (make-Dummy x)] - [(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern" #'x)] + [(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern" + #'x)] [else (make-Var x)])) ;; stx : syntax of pattern, starting with quote @@ -32,15 +33,14 @@ [(quote vec) (vector? (syntax-e #'vec)) (make-Vector (for/list ([e (vector->list (syntax-e #'vec))]) - (parse (quasisyntax/loc stx (quote #,e)))))] + (parse (quasisyntax/loc stx (quote #,e)))))] [(quote bx) (vector? (syntax-e #'bx)) (make-Box (parse (quasisyntax/loc stx (quote #,(syntax-e #'bx)))))] [(quote v) (or (parse-literal (syntax-e #'v)) (raise-syntax-error 'match "non-literal in quote pattern" stx #'v))] - [_ - (raise-syntax-error 'match "syntax error in quote pattern" stx)])) + [_ (raise-syntax-error 'match "syntax error in quote pattern" stx)])) ;; parse : the parse fn ;; p : the repeated pattern @@ -48,16 +48,15 @@ ;; rest : the syntax for the rest (define (dd-parse parse p dd rest) (let* ([count (ddk? dd)] - [min (if (number? count) count #f)]) - (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)))) + [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)))) ;; stx : the syntax object for the whole pattern ;; cert : the certifier @@ -66,34 +65,44 @@ ;; pats : syntax representing the member patterns ;; returns a pattern (define (parse-struct stx cert parse struct-name pats) - (let* ([fail (lambda () - (raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum struct-name)) stx struct-name))] + (let* ([fail (lambda () + (raise-syntax-error + 'match (format "~a does not refer to a structure definition" + (syntax->datum struct-name)) + stx struct-name))] [v (syntax-local-value (cert struct-name) fail)]) - (unless (struct-info? v) - (fail)) - (let-values ([(id _1 pred acc _2 super) (apply values (extract-struct-info v))]) + (unless (struct-info? v) (fail)) + (let-values ([(id _1 pred acc _2 super) + (apply values (extract-struct-info v))]) ;; this produces a list of all the super-types of this struct - ;; ending when it reaches the top of the hierarchy, or a struct that we can't access + ;; ending when it reaches the top of the hierarchy, or a struct that we + ;; can't access (define (get-lineage struct-name) - (let ([super (list-ref - (extract-struct-info (syntax-local-value struct-name)) - 5)]) + (let ([super (list-ref (extract-struct-info (syntax-local-value + struct-name)) + 5)]) (cond [(equal? super #t) '()] ;; no super type exists [(equal? super #f) '()] ;; super type is unknown [else (cons super (get-lineage super))]))) (let* (;; the accessors come in reverse order [acc (reverse acc)] ;; remove the first element, if it's #f - [acc (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])]) - (make-Struct id pred (get-lineage (cert struct-name)) acc + [acc (cond [(null? acc) acc] + [(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 "wrong number for fields for structure ~a: expected ~a but got ~a" - (syntax->datum struct-name) (length acc) (length ps)) - stx pats)) - (map parse ps)))))))) + (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)))))))) (define (trans-match pred transformer pat) (make-And (list (make-Pred pred) (make-App transformer pat)))) @@ -106,9 +115,10 @@ ;; accessor : match-expander -> syntax transformer/#f ;; error-msg : string ;; produces a parsed pattern -(define (match-expander-transform parse/cert cert expander stx accessor error-msg) +(define (match-expander-transform parse/cert cert expander stx accessor + error-msg) (let* ([expander (syntax-local-value (cert expander))] - [transformer (accessor expander)]) + [transformer (accessor expander)]) (unless transformer (raise-syntax-error #f error-msg #'expander)) (let* ([introducer (make-syntax-introducer)] [certifier (match-expander-certifier expander)] @@ -122,7 +132,6 @@ (define (matchable? e) (or (string? e) (bytes? e))) - ;; raise an error, blaming stx (define (match:syntax-err stx msg) (raise-syntax-error #f msg stx)) @@ -130,67 +139,56 @@ ;; pattern-var? : syntax -> bool ;; is p an identifier representing a pattern variable? (define (pattern-var? p) - (and (identifier? p) - (not (ddk? p)))) + (and (identifier? p) (not (ddk? p)))) ;; ddk? : syntax -> number or boolean ;; if #f is returned, was not a ddk identifier ;; if #t is returned, no minimum ;; if a number is returned, that's the minimum (define (ddk? s*) - (define (./_ c) - (or (equal? c #\.) - (equal? c #\_))) + (define (./_ c) (or (equal? c #\.) (equal? c #\_))) (let ([s (syntax->datum s*)]) (and (symbol? s) - (if (memq s '(... ___)) #t - (let* ((s (symbol->string s))) - (and (3 . <= . (string-length s)) - (./_ (string-ref s 0)) - (./_ (string-ref s 1)) - (let ([n (string->number (substring s 2))]) - (cond - [(not n) #f] - [(zero? n) #t] - [(exact-nonnegative-integer? n) n] - [else (raise-syntax-error 'match "invalid number for ..k pattern" s*)])))))))) - + (if (memq s '(... ___)) + #t + (let* ([m (regexp-match #rx"^(?:\\.\\.|__)([0-9]+)$" + (symbol->string s))] + [n (and m (string->number (cadr m)))]) + (cond [(not n) #f] + [(zero? n) #t] + [(exact-nonnegative-integer? n) n] + [else (raise-syntax-error + 'match "invalid number for ..k pattern" + s*)])))))) ;; parse-literal : scheme-val -> pat option ;; is v is a literal, return a pattern matching it ;; otherwise, return #f (define (parse-literal v) - (if (or (number? v) - (string? v) - (keyword? v) - (symbol? v) - (bytes? v) - (regexp? v) - (boolean? v) - (char? v)) - (make-Exact v) - #f)) + (if (or (number? v) (string? v) (keyword? v) (symbol? v) (bytes? v) + (regexp? v) (boolean? v) (char? v)) + (make-Exact v) + #f)) ;; (listof pat) syntax -> void ;; check that all the ps bind the same set of variables (define (all-vars ps stx) - (when (null? ps) - (error 'bad)) + (when (null? ps) (error 'bad)) (let* ([first-vars (bound-vars (car ps))] [l (length ps)] [ht (make-free-identifier-mapping)]) - (for-each (lambda (v) (free-identifier-mapping-put! ht v 1)) first-vars) - (for-each (lambda (p) - (for-each (lambda (v) - (cond [(free-identifier-mapping-get ht v (lambda () #f)) - => - (lambda (n) - (free-identifier-mapping-put! ht v (add1 n)))] - [else (raise-syntax-error 'match "variable not bound in all or patterns" stx v)])) - (bound-vars p))) - (cdr ps)) + (for ([v first-vars]) (free-identifier-mapping-put! ht v 1)) + (for* ([p (cdr ps)] + [v (bound-vars p)]) + (cond [(free-identifier-mapping-get ht v (lambda () #f)) + => (lambda (n) + (free-identifier-mapping-put! ht v (add1 n)))] + [else (raise-syntax-error 'match + "variable not bound in all or patterns" + stx v)])) (free-identifier-mapping-for-each ht (lambda (v n) (unless (= n l) - (raise-syntax-error 'match "variable not bound in all or patterns" stx v)))))) \ No newline at end of file + (raise-syntax-error 'match "variable not bound in all or patterns" + stx v)))))) diff --git a/collects/scheme/match/parse-legacy.ss b/collects/scheme/match/parse-legacy.ss index a845db4e92..c499161f23 100644 --- a/collects/scheme/match/parse-legacy.ss +++ b/collects/scheme/match/parse-legacy.ss @@ -5,7 +5,7 @@ syntax/stx scheme/struct-info "patterns.ss" - "compiler.ss" + "compiler.ss" "parse-helper.ss" "parse-quasi.ss" (only-in srfi/1 delete-duplicates)) @@ -15,13 +15,14 @@ (define (parse/legacy/cert stx cert) (define (parse stx) (parse/legacy/cert stx cert)) (syntax-case* stx (not $ ? and or = quasiquote quote) - (lambda (x y) (eq? (syntax-e x) (syntax-e y))) - + (lambda (x y) (eq? (syntax-e x) (syntax-e y))) [(expander args ...) (and (identifier? #'expander) - (match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) - (match-expander-transform parse/legacy/cert cert #'expander stx match-expander-legacy-xform - "This expander only works with the standard match syntax")] + (match-expander? + (syntax-local-value (cert #'expander) (lambda () #f)))) + (match-expander-transform + parse/legacy/cert cert #'expander stx match-expander-legacy-xform + "This expander only works with the standard match syntax")] [(and p ...) (make-And (map parse (syntax->list #'(p ...))))] [(or p ...) @@ -32,19 +33,21 @@ ;; nots are conjunctions of negations (let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))]) (make-And ps))] - [bx + [bx (box? (syntax-e #'bx)) (make-Box (parse (unbox (syntax-e #'bx))))] [#(es ...) (ormap ddk? (syntax->list #'(es ...))) - (make-And (list (make-Pred #'vector?) (make-App #'vector->list (parse (syntax/loc stx (es ...))))))] + (make-And (list (make-Pred #'vector?) + (make-App #'vector->list + (parse (syntax/loc stx (es ...))))))] [#(es ...) - (make-Vector (map parse (syntax->list #'(es ...))))] - + (make-Vector (map parse (syntax->list #'(es ...))))] [($ s . pats) (parse-struct stx cert parse #'s #'pats)] [(? p q1 qs ...) - (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))] + (make-And (cons (make-Pred (cert #'p)) + (map parse (syntax->list #'(q1 qs ...)))))] [(? p) (make-Pred (cert #'p))] [(= f p) @@ -61,7 +64,7 @@ (ddk? #'..) (dd-parse parse #'p #'.. #'rest)] [(e . es) - (make-Pair (parse #'e) (parse (syntax/loc stx es)))] + (make-Pair (parse #'e) (parse (syntax/loc stx es)))] [x (identifier? #'x) (parse-id #'x)] diff --git a/collects/scheme/match/parse-quasi.ss b/collects/scheme/match/parse-quasi.ss index d3cc095295..de7836e431 100644 --- a/collects/scheme/match/parse-quasi.ss +++ b/collects/scheme/match/parse-quasi.ss @@ -13,23 +13,19 @@ ;; is pat a pattern representing a list? (define (null-terminated? pat) - (cond [(Pair? pat) - (null-terminated? (Pair-d pat))] - [(GSeq? pat) - (null-terminated? (GSeq-tail pat))] + (cond [(Pair? pat) (null-terminated? (Pair-d pat))] + [(GSeq? pat) (null-terminated? (GSeq-tail pat))] [(Null? pat) #t] [else #f])) ;; combine a null-terminated pattern with another pattern to match afterwards (define (append-pats p1 p2) - (cond [(Pair? p1) - (make-Pair (Pair-a p1) (append-pats (Pair-d p1) p2))] - [(GSeq? p1) - (make-GSeq (GSeq-headss p1) - (GSeq-mins p1) - (GSeq-maxs p1) - (GSeq-onces? p1) - (append-pats (GSeq-tail p1) p2))] + (cond [(Pair? p1) (make-Pair (Pair-a p1) (append-pats (Pair-d p1) p2))] + [(GSeq? p1) (make-GSeq (GSeq-headss p1) + (GSeq-mins p1) + (GSeq-maxs p1) + (GSeq-onces? p1) + (append-pats (GSeq-tail p1) p2))] [(Null? p1) p2] [else (error 'match "illegal input to append-pats")])) @@ -38,19 +34,20 @@ (define (parse-quasi stx cert parse/cert) (define (pq s) (parse-quasi s cert parse/cert)) (syntax-case stx (quasiquote unquote quote unquote-splicing) - [(unquote p) (parse/cert #'p cert)] + [(unquote p) (parse/cert #'p cert)] [((unquote-splicing p) . rest) (let ([pat (parse/cert #'p cert)] [rpat (pq #'rest)]) (if (null-terminated? pat) - (append-pats pat rpat) - (raise-syntax-error 'match "non-list pattern inside unquote-splicing" stx #'p)))] + (append-pats pat rpat) + (raise-syntax-error 'match "non-list pattern inside unquote-splicing" + stx #'p)))] [(p dd) (ddk? #'dd) (let* ([count (ddk? #'..)] [min (if (number? count) count #f)] [max (if (number? count) count #f)]) - (make-GSeq + (make-GSeq (parameterize ([match-...-nesting (add1 (match-...-nesting))]) (list (list (pq #'p)))) (list min) @@ -68,10 +65,9 @@ [(unquote-splicing . _) #t] [_ #f]))) (syntax->list #'(p ...))) - (make-And (list - (make-Pred #'vector?) - (make-App #'vector->list - (pq (quasisyntax/loc stx (p ...))))))] + (make-And (list (make-Pred #'vector?) + (make-App #'vector->list + (pq (quasisyntax/loc stx (p ...))))))] [#(p ...) (make-Vector (map pq (syntax->list #'(p ...))))] [bx @@ -81,4 +77,4 @@ (make-Null (make-Dummy #f))] [v (or (parse-literal (syntax-e #'v)) - (raise-syntax-error 'match "syntax error in quasipattern" stx))])) \ No newline at end of file + (raise-syntax-error 'match "syntax error in quasipattern" stx))])) diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss index 5234bf8430..c54d523289 100644 --- a/collects/scheme/match/parse.ss +++ b/collects/scheme/match/parse.ss @@ -13,26 +13,26 @@ (provide parse/cert) -(define (ht-pat-transform p) +(define (ht-pat-transform p) (syntax-case p () [(a b) #'(list a b)] - [x - (identifier? #'x) - #'x])) + [x (identifier? #'x) #'x])) ;; parse : syntax -> Pat ;; compile stx into a pattern, using the new syntax (define (parse/cert stx cert) (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*) - (lambda (x y) (eq? (syntax-e x) (syntax-e y))) - + (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*) + (lambda (x y) (eq? (syntax-e x) (syntax-e y))) [(expander args ...) (and (identifier? #'expander) - (match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) - (match-expander-transform parse/cert cert #'expander stx match-expander-match-xform - "This expander only works with the legacy match syntax")] + (match-expander? (syntax-local-value (cert #'expander) + (lambda () #f)))) + (match-expander-transform + parse/cert cert #'expander stx match-expander-match-xform + "This expander only works with the legacy match syntax")] [(var v) (identifier? #'v) (make-Var #'v)] @@ -47,17 +47,27 @@ (let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))]) (make-And ps))] [(regexp r) - (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (make-Pred #'values))] + (trans-match #'matchable? + #'(lambda (e) (regexp-match r e)) + (make-Pred #'values))] [(regexp r p) (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))] [(pregexp r) - (trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (make-Pred #'values))] + (trans-match #'matchable? + #'(lambda (e) + (regexp-match (if (pregexp? r) r (pregexp r)) e)) + (make-Pred #'values))] [(pregexp r p) - (trans-match #'matchable? #'(lambda (e) (regexp-match (if (pregexp? r) r (pregexp r)) e)) (parse #'p))] - [(box e) (make-Box (parse #'e))] + (trans-match #'matchable? + #'(lambda (e) + (regexp-match (if (pregexp? r) r (pregexp r)) e)) + (parse #'p))] + [(box e) (make-Box (parse #'e))] [(vector es ...) (ormap ddk? (syntax->list #'(es ...))) - (trans-match #'vector? #'vector->list (parse (syntax/loc stx (list es ...))))] + (trans-match #'vector? + #'vector->list + (parse (syntax/loc stx (list es ...))))] [(vector es ...) (make-Vector (map parse (syntax->list #'(es ...))))] [(hash-table p ... dd) @@ -65,49 +75,50 @@ (trans-match #'hash-table? #'(lambda (e) (hash-table-map e list)) - (with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))]) + (with-syntax ([(elems ...) + (map ht-pat-transform (syntax->list #'(p ...)))]) (parse (syntax/loc stx (list-no-order elems ... dd)))))] [(hash-table p ...) - (ormap ddk? (syntax->list #'(p ...))) - (raise-syntax-error 'match "dot dot k can only appear at the end of hash-table patterns" stx - (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))] + (ormap ddk? (syntax->list #'(p ...))) + (raise-syntax-error + 'match "dot dot k can only appear at the end of hash-table patterns" stx + (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))] [(hash-table p ...) - (trans-match - #'hash-table? - #'(lambda (e) (hash-table-map e list)) - (with-syntax ([(elems ...) (map ht-pat-transform (syntax->list #'(p ...)))]) - (parse (syntax/loc stx (list-no-order elems ...)))))] + (trans-match #'hash-table? + #'(lambda (e) (hash-table-map e list)) + (with-syntax ([(elems ...) + (map ht-pat-transform + (syntax->list #'(p ...)))]) + (parse (syntax/loc stx (list-no-order elems ...)))))] [(hash-table . _) (raise-syntax-error 'match "syntax error in hash-table pattern" stx)] [(list-no-order p ... lp dd) - (ddk? #'dd) + (ddk? #'dd) (let* ([count (ddk? #'dd)] [min (if (number? count) count #f)] [max (if (number? count) count #f)] [ps (syntax->list #'(p ...))]) - (make-GSeq - (cons (list (parse #'lp)) - (for/list ([p ps]) - (list (parse p)))) - (cons min (map (lambda _ 1) ps)) - (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-GSeq (cons (list (parse #'lp)) + (for/list ([p ps]) (list (parse p)))) + (cons min (map (lambda _ 1) ps)) + (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))))] [(list-no-order p ...) (ormap ddk? (syntax->list #'(p ...))) - (raise-syntax-error 'match "dot dot k can only appear at the end of unordered match patterns" stx - (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))] + (raise-syntax-error + 'match "dot dot k can only appear at the end of unordered match patterns" + stx + (ormap (lambda (e) (and (ddk? e) e)) (syntax->list #'(p ...))))] [(list-no-order p ...) (let ([ps (syntax->list #'(p ...))]) - (make-GSeq - (for/list ([p ps]) - (list (parse p))) - (map (lambda _ 1) ps) - (map (lambda _ 1) ps) - ;; all of these patterns get bound to only one thing - (map (lambda _ #t) ps) - (make-Null (make-Dummy #f))))] + (make-GSeq (for/list ([p ps]) (list (parse p))) + (map (lambda _ 1) ps) + (map (lambda _ 1) ps) + ;; all of these patterns get bound to only one thing + (map (lambda _ #t) ps) + (make-Null (make-Dummy #f))))] [(list) (make-Null (make-Dummy stx))] [(list ..) (ddk? #'..) @@ -131,7 +142,8 @@ [(struct s pats) (parse-struct stx cert parse #'s #'pats)] [(? p q1 qs ...) - (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))] + (make-And (cons (make-Pred (cert #'p)) + (map parse (syntax->list #'(q1 qs ...)))))] [(? p) (make-Pred (cert #'p))] [(app f p) @@ -149,8 +161,4 @@ (or (parse-literal (syntax-e #'v)) (raise-syntax-error 'match "syntax error in pattern" stx))])) -;(trace parse) - - - - +;; (trace parse) diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss index 7560e368e1..258ac7d9f7 100644 --- a/collects/scheme/match/patterns.ss +++ b/collects/scheme/match/patterns.ss @@ -1,7 +1,6 @@ #lang scheme/base (require syntax/boundmap - mzlib/trace scheme/stxparam scheme/contract (for-syntax scheme/base)) @@ -14,10 +13,11 @@ exn:misc:match?) (define-struct (exn:misc:match exn:fail) (value)) - -(define (match:error val) (raise (make-exn:misc:match (format "match: no matching clause for ~e" val) - (current-continuation-marks) - val))) + +(define (match:error val) + (raise (make-exn:misc:match (format "match: no matching clause for ~e" val) + (current-continuation-marks) + val))) (define orig-stx (make-parameter #f)) @@ -31,8 +31,7 @@ (define-struct (Dummy Var) () #:transparent #:property - prop:custom-write (lambda (v p w?) - (fprintf p "_"))) + prop:custom-write (lambda (v p w?) (fprintf p "_"))) ;; constructor patterns (define-struct (CPat Pat) () #:transparent) @@ -84,7 +83,8 @@ ;; headss : listof listof pattern ;; mins : listof option number ;; maxs : listof option number -;; onces? : listof boolean -- is this pattern being bound only once (take the car of the variables) +;; 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) @@ -98,14 +98,12 @@ ;; vars-seen is a listof identifiers (define-struct Row (pats rhs unmatch vars-seen) #:transparent #:property - prop:custom-write (lambda (v p w?) - (fprintf p "(Row ~a )" (Row-pats v)))) - - + prop:custom-write + (lambda (v p w?) (fprintf p "(Row ~a )" (Row-pats v)))) (define struct-key-ht (make-free-identifier-mapping)) (define (get-key id) - (free-identifier-mapping-get + (free-identifier-mapping-get struct-key-ht id (lambda () (let ([k (box-immutable (syntax-e id))]) @@ -117,24 +115,24 @@ ;; (eq? (pat-key p) (pat-key q)) if p and q match the same constructor ;; the result is #f if p is not a constructor pattern (define (pat-key p) - (cond - [(Struct? p) (get-key (Struct-id p))] - [(Box? p) 'box] - [(Vector? p) 'vector] - [(Pair? p) 'pair] - [(MPair? p) 'mpair] - [(String? p) 'string] - [(Symbol? p) 'symbol] - [(Number? p) 'number] - [(Bytes? p) 'bytes] - [(Char? p) 'char] - [(Regexp? p) 'regexp] - [(Keyword? p) 'keyword] - [(Boolean? p) 'boolean] - [(Null? p) 'null] - [else #f])) + (cond [(Struct? p) (get-key (Struct-id p))] + [(Box? p) 'box] + [(Vector? p) 'vector] + [(Pair? p) 'pair] + [(MPair? p) 'mpair] + [(String? p) 'string] + [(Symbol? p) 'symbol] + [(Number? p) 'number] + [(Bytes? p) 'bytes] + [(Char? p) 'char] + [(Regexp? p) 'regexp] + [(Keyword? p) 'keyword] + [(Boolean? p) 'boolean] + [(Null? p) 'null] + [else #f])) -;(trace pat-key) +;; (require mzlib/trace) +;; (trace pat-key) ;; Row-first-pat : Row -> Pat ;; Row must not have empty list of pats @@ -145,29 +143,23 @@ (define p (Row-pats r)) (values (car p) (cdr p))) - ;; merge : (liftof (listof id)) -> (listof id) -;; merges lists of identifiers, removing module-identifier=? -;; duplicates +;; merges lists of identifiers, removing module-identifier=? duplicates (define (merge l) - (cond - [(null? l) null] - [(null? (cdr l)) (car l)] - [else (let ([m (make-module-identifier-mapping)]) - (for-each (lambda (ids) - (for-each (lambda (id) - (module-identifier-mapping-put! m id #t)) - ids)) - l) - (module-identifier-mapping-map m (lambda (k v) k)))])) + (cond [(null? l) null] + [(null? (cdr l)) (car l)] + [else (let ([m (make-module-identifier-mapping)]) + (for* ([ids l] [id ids]) + (module-identifier-mapping-put! m id #t)) + (module-identifier-mapping-map m (lambda (k v) k)))])) ;; bound-vars : Pat -> listof identifiers (define (bound-vars p) (cond [(Dummy? p) null] [(Pred? p) null] - [(Var? p) (let* ([v (Var-v p)] - [v* (free-identifier-mapping-get (current-renaming) v (lambda () v))]) - (list v*))] + [(Var? p) + (let ([v (Var-v p)]) + (list (free-identifier-mapping-get (current-renaming) v (lambda () v))))] [(Or? p) (bound-vars (car (Or-ps p)))] [(Box? p) @@ -178,11 +170,10 @@ [(MPair? p) (merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-d p))))] [(GSeq? p) - (merge (cons - (bound-vars (GSeq-tail p)) - (for/list ([pats (GSeq-headss p)]) - (merge (for/list ([pat pats]) - (bound-vars pat))))))] + (merge (cons (bound-vars (GSeq-tail p)) + (for/list ([pats (GSeq-headss p)]) + (merge (for/list ([pat pats]) + (bound-vars pat))))))] [(Vector? p) (merge (map bound-vars (Vector-ps p)))] [(Struct? p) @@ -200,15 +191,15 @@ (define-syntax-parameter fail (lambda (stx) - (raise-syntax-error #f - "used out of context: not in match pattern" - stx))) + (raise-syntax-error + #f "used out of context: not in match pattern" stx))) (define current-renaming (make-parameter (make-free-identifier-mapping))) (define (copy-mapping ht) (define new-ht (make-free-identifier-mapping)) - (free-identifier-mapping-for-each ht (lambda (k v) (free-identifier-mapping-put! new-ht k v))) + (free-identifier-mapping-for-each + ht (lambda (k v) (free-identifier-mapping-put! new-ht k v))) new-ht) #| @@ -230,9 +221,10 @@ (provide/contract (struct Row ([pats (listof Pat?)] [rhs syntax?] [unmatch (or/c identifier? false/c)] - [vars-seen (listof (cons/c identifier? identifier?))]))) + [vars-seen (listof (cons/c identifier? + identifier?))]))) (define-struct match-expander (match-xform legacy-xform macro-xform certifier) #:property prop:procedure (struct-field-index macro-xform)) -(provide (struct-out match-expander)) \ No newline at end of file +(provide (struct-out match-expander)) diff --git a/collects/scheme/match/split-rows.ss b/collects/scheme/match/split-rows.ss index d955f207c2..ebaba107d9 100644 --- a/collects/scheme/match/split-rows.ss +++ b/collects/scheme/match/split-rows.ss @@ -6,80 +6,76 @@ ;; split-rows : Listof[Row] -> Listof[Listof[Row]] ;; takes a matrix, and returns a list of matricies -;; each returned matrix does not require the mixture rule to do compilation of the first column. +;; each returned matrix does not require the mixture rule to do compilation of +;; the first column. (define (split-rows rows [acc null]) (define (loop/var matched-rows prev-mats rows) - (cond [(null? rows) - (reverse (cons (reverse matched-rows) prev-mats))] - [else - (let* ([r (car rows)] - [p (Row-first-pat r)] - [rs (cdr rows)]) - (cond - [(Row-unmatch r) - (split-rows rows (cons (reverse matched-rows) prev-mats))] - [(Var? p) - (loop/var (cons r matched-rows) prev-mats rs)] - [else - (split-rows rows (cons (reverse matched-rows) prev-mats))]))])) + (if (null? rows) + (reverse (cons (reverse matched-rows) prev-mats)) + (let* ([r (car rows)] + [p (Row-first-pat r)] + [rs (cdr rows)]) + (cond [(Row-unmatch r) + (split-rows rows (cons (reverse matched-rows) prev-mats))] + [(Var? p) + (loop/var (cons r matched-rows) prev-mats rs)] + [else + (split-rows rows (cons (reverse matched-rows) prev-mats))])))) (define (loop/con matched-rows prev-mats struct-key rows) - (cond [(null? rows) - (reverse (cons (reverse matched-rows) prev-mats))] - [else - (let* ([r (car rows)] - [p (Row-first-pat r)] - [rs (cdr rows)]) - (cond - [(Row-unmatch r) - (split-rows rows (cons (reverse matched-rows) prev-mats))] - [(and (Struct? p) struct-key (eq? (pat-key p) struct-key)) - ;(printf "struct-keys were equal: ~a~n" struct-key) - (loop/con (cons r matched-rows) prev-mats struct-key rs)] - [(and (Struct? p) (not struct-key)) - ;(printf "no struct-key so far: ~a~n" struct-key) - (loop/con (cons r matched-rows) prev-mats (pat-key p) rs)] - [(and (CPat? p) (not (Struct? p))) - ;(printf "wasn't a struct: ~a~n" p) - (loop/con (cons r matched-rows) prev-mats struct-key rs)] - [else (split-rows rows (cons (reverse matched-rows) prev-mats))]))])) + (if (null? rows) + (reverse (cons (reverse matched-rows) prev-mats)) + (let* ([r (car rows)] + [p (Row-first-pat r)] + [rs (cdr rows)]) + (cond [(Row-unmatch r) + (split-rows rows (cons (reverse matched-rows) prev-mats))] + [(and (Struct? p) struct-key (eq? (pat-key p) struct-key)) + ;; (printf "struct-keys were equal: ~a~n" struct-key) + (loop/con (cons r matched-rows) prev-mats struct-key rs)] + [(and (Struct? p) (not struct-key)) + ;; (printf "no struct-key so far: ~a~n" struct-key) + (loop/con (cons r matched-rows) prev-mats (pat-key p) rs)] + [(and (CPat? p) (not (Struct? p))) + ;; (printf "wasn't a struct: ~a~n" p) + (loop/con (cons r matched-rows) prev-mats struct-key rs)] + [else (split-rows rows (cons (reverse matched-rows) + prev-mats))])))) (define (loop/exact matched-rows prev-mats rows) - (cond [(null? rows) - (reverse (cons (reverse matched-rows) prev-mats))] - [else - (let* ([r (car rows)] - [p (Row-first-pat r)] - [rs (cdr rows)]) - (cond - [(Row-unmatch r) - (split-rows rows (cons (reverse matched-rows) prev-mats))] - [(Exact? p) - (loop/exact (cons r matched-rows) prev-mats rs)] - [else (split-rows rows (cons (reverse matched-rows) prev-mats))]))])) - (cond - [(null? rows) (reverse acc)] - [else - (let* ([r (car rows)] - [p (Row-first-pat r)] - [rs (cdr rows)]) - (cond - [(Row-unmatch r) - (split-rows rs (cons (list r) acc))] - [(Var? p) - (loop/var (list r) acc rs)] - [(Exact? p) - (loop/exact (list r) acc rs)] - [(CPat? p) - (if (Struct? p) - (begin - ;(printf "found a struct: ~a~n" (pat-key r)) - (loop/con (list r) acc (pat-key p) rs)) - (loop/con (list r) acc #f rs))] - [else (split-rows rs (cons (list r) acc))]))])) + (if (null? rows) + (reverse (cons (reverse matched-rows) prev-mats)) + (let* ([r (car rows)] + [p (Row-first-pat r)] + [rs (cdr rows)]) + (cond + [(Row-unmatch r) + (split-rows rows (cons (reverse matched-rows) prev-mats))] + [(Exact? p) + (loop/exact (cons r matched-rows) prev-mats rs)] + [else (split-rows rows (cons (reverse matched-rows) prev-mats))])))) + (if (null? rows) + (reverse acc) + (let* ([r (car rows)] + [p (Row-first-pat r)] + [rs (cdr rows)]) + (cond [(Row-unmatch r) + (split-rows rs (cons (list r) acc))] + [(Var? p) + (loop/var (list r) acc rs)] + [(Exact? p) + (loop/exact (list r) acc rs)] + [(CPat? p) + (if (Struct? p) + (begin + ;; (printf "found a struct: ~a~n" (pat-key r)) + (loop/con (list r) acc (pat-key p) rs)) + (loop/con (list r) acc #f rs))] + [else (split-rows rs (cons (list r) acc))])))) -(require mzlib/trace) -;(trace split-rows) +;; (require mzlib/trace) +;; (trace split-rows) ;; EXAMPLES: #| (define mat1 (list r1 r2 r3)) -(define mat2 (list r1 r3 r2 r1))|# \ No newline at end of file +(define mat2 (list r1 r3 r2 r1)) +|#