Add new match implementation.
Does not yet work: - some errors about car of () - some match-expander certification errors svn: r9049
This commit is contained in:
Sam Tobin-Hochstadt
parent
3b1d5169f9
commit
b7127dc9c7
|
|
@ -1,192 +1,4 @@
|
|||
;; (documentation (name match))
|
||||
;; <pre>Pattern Matching Syntactic Extensions for Scheme
|
||||
;;
|
||||
;; Special thanks go out to:
|
||||
;; Robert Bruce Findler for support and bug detection.
|
||||
;; Doug Orleans for pointing out that pairs should be reused while
|
||||
;; matching lists.
|
||||
;;
|
||||
;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
|
||||
;; which in turn was adapted from code written by Bruce F. Duba, 1991.
|
||||
;;
|
||||
;; This macro package extends Scheme with several new expression forms.
|
||||
;; Following is a brief summary of the new forms. See the associated
|
||||
;; LaTeX documentation for a full description of their functionality.
|
||||
;;
|
||||
;;
|
||||
;; match expressions:
|
||||
;;
|
||||
;; exp ::= ...
|
||||
;; | (match exp clause ...)
|
||||
;; | (match-lambda clause ...)
|
||||
;; | (match-lambda* clause ...)
|
||||
;; | (match-let ((pat exp) ...) body ...)
|
||||
;; | (match-let var ((pat exp) ...) body ...)
|
||||
;; | (match-let* ((pat exp) ...) body ...)
|
||||
;; | (match-letrec ((pat exp) ...) body ...)
|
||||
;; | (match-define pat exp)
|
||||
;;
|
||||
;; clause ::= (pat body) | (pat (=> identifier) exp)
|
||||
;;
|
||||
;; patterns: matches:
|
||||
;;
|
||||
;; pat ::=
|
||||
;; identifier this binds an identifier if it
|
||||
;; doesn't conflict with
|
||||
;; ..k, var, $, =, and,
|
||||
;; or, not, ?, set!, or get!
|
||||
;; | _ anything
|
||||
;; | () the empty list
|
||||
;; | #t #t
|
||||
;; | #f #f
|
||||
;; | string a string
|
||||
;; | number a number
|
||||
;; | character a character
|
||||
;; | 'sexp an s-expression
|
||||
;; | 'symbol a symbol (special case of s-expr)
|
||||
;; | (lvp_1 ... lvp_n) list of n elements
|
||||
;; | (pat ... pat_n . pat_{n+1}) list of n or more
|
||||
;; | #(lvp_1 ... lvp_n) vector of n elements
|
||||
;; | #&pat box
|
||||
;; | ($ struct-name pat_1 ... pat_n) a structure
|
||||
;; | (= field pat) a field of a structure (field is
|
||||
;; an accessor)
|
||||
;; Actually field can be any function
|
||||
;; which can be
|
||||
;; applied to the data being matched.
|
||||
;; Ex: (match 5 ((= add1 b) b)) => 6
|
||||
;;
|
||||
;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
|
||||
;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
|
||||
;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
|
||||
;; | (? predicate pat_1 ... pat_n) if predicate true and all of
|
||||
;; pat_1 thru pat_n match
|
||||
;; | (set! identifier) anything, and binds setter
|
||||
;; | (get! identifier) anything, and binds getter
|
||||
;; | `qp a quasi-pattern
|
||||
;;
|
||||
;; lvp ::= pat ooo greedily matches n or more of pat,
|
||||
;; each element must match pat
|
||||
;; | pat matches pat
|
||||
;;
|
||||
;; ooo ::= ... zero or more
|
||||
;; | ___ zero or more
|
||||
;; | ..k k or more
|
||||
;; | __k k or more
|
||||
;;
|
||||
;; quasi-patterns: matches:
|
||||
;;
|
||||
;; qp ::= () the empty list
|
||||
;; | #t #t
|
||||
;; | #f #f
|
||||
;; | string a string
|
||||
;; | number a number
|
||||
;; | character a character
|
||||
;; | identifier a symbol
|
||||
;; | (qp_1 ... qp_n) list of n elements
|
||||
;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more
|
||||
;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
|
||||
;; of remainder must match qp_n+1
|
||||
;; | #(qp_1 ... qp_n) vector of n elements
|
||||
;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
|
||||
;; of remainder must match qp_n+1
|
||||
;; | #&qp box
|
||||
;; | ,pat a pattern
|
||||
;; | ,@(lvp . . . lvp-n)
|
||||
;; | ,@(pat . . . pat_n . pat_{n+1})
|
||||
;; | ,@`qp qp must evaluate to a list as
|
||||
;; so that this rule resembles the
|
||||
;; above two rules
|
||||
;;
|
||||
;; The names (quote, quasiquote, unquote, unquote-splicing, ?, _, $,
|
||||
;; and, or, not, set!, get!, list-no-order, hash-table, ..., ___)
|
||||
;; cannot be used as pattern variables.</pre>
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
(module match mzscheme
|
||||
(provide
|
||||
match
|
||||
match-lambda
|
||||
match-lambda*
|
||||
match-let
|
||||
match-let*
|
||||
match-letrec
|
||||
match-define
|
||||
match-equality-test
|
||||
exn:misc:match?
|
||||
exn:misc:match-value
|
||||
define-match-expander)
|
||||
|
||||
;; FIXME: match-helper and match-error should each be split
|
||||
;; into a compile-time part and a run-time part.
|
||||
|
||||
(require-for-syntax "private/match/convert-pat.ss"
|
||||
"private/match/match-helper.ss")
|
||||
|
||||
(require-for-template mzscheme)
|
||||
|
||||
(require (prefix plt: "private/match/match-internal-func.ss")
|
||||
"private/match/match-expander.ss"
|
||||
"private/match/match-helper.ss"
|
||||
"private/match/match-error.ss"
|
||||
"private/match/test-no-order.ss")
|
||||
|
||||
(define-syntax match-definer
|
||||
(syntax-rules ()
|
||||
[(match-definer name clauses ...)
|
||||
(define-syntax (name stx)
|
||||
(md-help syntax stx
|
||||
(syntax-case stx ()
|
||||
clauses ...)))]))
|
||||
|
||||
(match-definer match-lambda
|
||||
[(k clause ...)
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
|
||||
#'(plt:match-lambda new-clauses ...))])
|
||||
|
||||
(match-definer match-lambda*
|
||||
[(k clause ...)
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clause ...))])
|
||||
#'(plt:match-lambda* new-clauses ...))])
|
||||
|
||||
(match-definer match-let
|
||||
[(k name (clauses ...) body ...)
|
||||
(identifier? (syntax name))
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-let name (new-clauses ...) body ...))]
|
||||
[(k (clauses ...) body ...)
|
||||
(with-syntax ([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-let (new-clauses ...) body ...))])
|
||||
|
||||
(match-definer match-let*
|
||||
[(k (clauses ...) body ...)
|
||||
(with-syntax
|
||||
([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-let* (new-clauses ...) body ...))])
|
||||
|
||||
(match-definer match
|
||||
[(_ exp clause ...)
|
||||
(with-syntax
|
||||
([(new-clauses ...) (handle-clauses #'(clause ...))])
|
||||
#'(plt:match exp new-clauses ...))])
|
||||
|
||||
|
||||
(match-definer match-letrec
|
||||
[(k (clauses ...) body ...)
|
||||
(with-syntax
|
||||
([(new-clauses ...) (handle-clauses #'(clauses ...))])
|
||||
#'(plt:match-letrec (new-clauses ...) body ...))])
|
||||
|
||||
|
||||
(match-definer match-define
|
||||
[(k pat exp)
|
||||
(with-syntax ([new-pat (convert-pat #'pat)])
|
||||
#'(plt:match-define new-pat exp))])
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/match/legacy-match)
|
||||
(provide (all-from-out scheme/match/legacy-match))
|
||||
|
|
@ -1,157 +1,4 @@
|
|||
;; (documentation (name plt-match))
|
||||
;; <pre>Pattern Matching Syntactic Extensions for Scheme
|
||||
;;
|
||||
;; All bugs or questions concerning this software should be directed to
|
||||
;; Bruce Hauman <bhauman@cs.wcu.edu>. The latest version of this software
|
||||
;; can be obtained from http://sol.cs.wcu.edu/~bhauman/scheme/pattern.php.
|
||||
;;
|
||||
;; Special thanks go out to:
|
||||
;; Robert Bruce Findler for support and bug detection.
|
||||
;; Doug Orleans for pointing out that pairs should be reused while
|
||||
;; matching lists.
|
||||
;;
|
||||
;;
|
||||
;; Originally written by Andrew K. Wright, 1993 (wright@research.nj.nec.com)
|
||||
;; which in turn was adapted from code written by Bruce F. Duba, 1991.
|
||||
;;
|
||||
;; This software is in the public domain. Feel free to copy,
|
||||
;; distribute, and modify this software as desired. No warranties
|
||||
;; nor guarantees of any kind apply. Please return any improvements
|
||||
;; or bug fixes to bhauman@cs.wcu.edu so that they may be included
|
||||
;; in future releases.
|
||||
;;
|
||||
;; This macro package extends Scheme with several new expression forms.
|
||||
;; Following is a brief summary of the new forms. See the associated
|
||||
;; LaTeX documentation for a full description of their functionality.
|
||||
;;
|
||||
;;
|
||||
;; match expressions:
|
||||
;;
|
||||
;; exp ::= ...
|
||||
;; | (match exp clause ...)
|
||||
;; | (match-lambda clause ...)
|
||||
;; | (match-lambda* clause ...)
|
||||
;; | (match-let ((pat exp) ...) body ...)
|
||||
;; | (match-let var ((pat exp) ...) body ...)
|
||||
;; | (match-let* ((pat exp) ...) body ...)
|
||||
;; | (match-letrec ((pat exp) ...) body ...)
|
||||
;; | (match-define pat exp)
|
||||
;;
|
||||
;; clause ::= (pat body) | (pat (=> identifier) exp)
|
||||
;;
|
||||
;; patterns: matches:
|
||||
;;
|
||||
;; pat ::=
|
||||
;; identifier this binds an identifier if it
|
||||
;; doesn't conflict with ..k, __k or _
|
||||
;; | _ anything
|
||||
;; | #t #t
|
||||
;; | #f #f
|
||||
;; | string a string
|
||||
;; | number a number
|
||||
;; | character a character
|
||||
;; | 'sexp an s-expression
|
||||
;; | 'symbol a symbol (special case of s-expr)
|
||||
;; | (var id) allows one to use ..k or _ as
|
||||
;; identifiers
|
||||
;; | (list lvp_1 ... lvp_n) list of n elements
|
||||
;; | (list-rest lvp_1 ... lvp_n pat) an improper list of n elements
|
||||
;; plus a last element which represents
|
||||
;; the last cdr of the list
|
||||
;; | (vector lvp_1 ... lvp_n) vector of n elements
|
||||
;; | (box pat) box
|
||||
;; | (struct struct-name (pat_1 ... pat_n)) a structure
|
||||
;; | (regexp exp) if regular expression exp matches
|
||||
;; | (regexp exp pat) if result of regexp-match matches pat
|
||||
;; | (pregexp exp) if pregexp.ss regular expression exp matches
|
||||
;; | (pregexp exp pat) if result of pregexp-match matches pat
|
||||
;; | (list-no-order pat ...) matches a list with no regard for
|
||||
;; the order of the
|
||||
;; items in the list
|
||||
;; | (list-no-order pat ... pat_n ooo) pat_n matches the remaining
|
||||
;; unmatched items
|
||||
;; | (hash-table (pat_k pat_v) ...) matches the elements of a hash table
|
||||
;; | (hash-table (pat_k pat_v) ... (pat_kn pat_vn) ooo)
|
||||
;; pat_kn must match the remaining
|
||||
;; unmatched key elements
|
||||
;; pat_vn must match the remaining
|
||||
;; unmatched value elements
|
||||
;; | (app field pat) a field of a structure (field is
|
||||
;; an accessor)
|
||||
;; Actually field can be any function
|
||||
;; which can be
|
||||
;; applied to the data being matched.
|
||||
;; Ex: (match 5 ((= add1 b) b)) => 6
|
||||
;;
|
||||
;; | (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
|
||||
;; | (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
|
||||
;; | (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
|
||||
;; | (? predicate pat_1 ... pat_n) if predicate true and all of
|
||||
;; pat_1 thru pat_n match
|
||||
;; | (set! identifier) anything, and binds setter
|
||||
;; | (get! identifier) anything, and binds getter
|
||||
;; | `qp a quasi-pattern
|
||||
;;
|
||||
;; lvp ::= pat ooo greedily matches n or more of pat,
|
||||
;; each element must match pat
|
||||
;; | pat matches pat
|
||||
;;
|
||||
;; ooo ::= ... zero or more
|
||||
;; | ___ zero or more
|
||||
;; | ..k k or more
|
||||
;; | __k k or more
|
||||
;;
|
||||
;; quasi-patterns: matches:
|
||||
;;
|
||||
;; qp ::= () the empty list
|
||||
;; | #t #t
|
||||
;; | #f #f
|
||||
;; | string a string
|
||||
;; | number a number
|
||||
;; | character a character
|
||||
;; | identifier a symbol
|
||||
;; | (qp_1 ... qp_n) list of n elements
|
||||
;; | (qp_1 ... qp_n . qp_{n+1}) list of n or more
|
||||
;; | (qp_1 ... qp_n qp_n+1 ooo) list of n or more, each element
|
||||
;; of remainder must match qp_n+1
|
||||
;; | #(qp_1 ... qp_n) vector of n elements
|
||||
;; | #(qp_1 ... qp_n qp_n+1 ooo) vector of n or more, each element
|
||||
;; of remainder must match qp_n+1
|
||||
;; | #&qp box
|
||||
;; | ,pat a pattern
|
||||
;; | ,@(list lvp . . . lvp-n)
|
||||
;; | ,@(list-rest lvp-1 . . . lvp-n pat)
|
||||
;; | ,@`qp qp must evaluate to a list as
|
||||
;; so that this rule resembles the
|
||||
;; above two rules
|
||||
;;
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
||||
(module plt-match mzscheme
|
||||
(provide
|
||||
match
|
||||
match-lambda
|
||||
match-lambda*
|
||||
match-let
|
||||
match-let*
|
||||
match-letrec
|
||||
match-define
|
||||
pregexp-match-with-error
|
||||
exn:misc:match?
|
||||
exn:misc:match-value
|
||||
match-equality-test
|
||||
define-match-expander)
|
||||
|
||||
(require "private/match/match-internal-func.ss"
|
||||
"private/match/match-expander.ss"
|
||||
"private/match/match-helper.ss"
|
||||
"private/match/match-error.ss"
|
||||
"private/match/test-no-order.ss")
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/match/match)
|
||||
(provide (all-from-out scheme/match/match))
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
|
||||
(module match scheme/base
|
||||
(require mzlib/plt-match
|
||||
(require scheme/match/match
|
||||
(for-syntax scheme/base))
|
||||
(provide (except-out (all-from-out mzlib/plt-match)
|
||||
(provide (except-out (all-from-out scheme/match/match)
|
||||
define-match-expander)
|
||||
(rename-out [define-match-expander* define-match-expander]))
|
||||
|
||||
|
|
|
|||
433
collects/scheme/match/compiler.ss
Normal file
433
collects/scheme/match/compiler.ss
Normal file
|
|
@ -0,0 +1,433 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-template scheme/base "patterns.ss" scheme/stxparam)
|
||||
mzlib/trace
|
||||
mzlib/etc
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
"patterns.ss"
|
||||
"split-rows.ss"
|
||||
scheme/struct-info
|
||||
scheme/stxparam
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
||||
(provide compile*)
|
||||
|
||||
;; for non-linear patterns
|
||||
(define vars-seen (make-parameter null))
|
||||
|
||||
(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))
|
||||
ht)
|
||||
|
||||
;; generate a clause of kind k
|
||||
;; for rows rows, with matched variable x and rest variable xs
|
||||
;; 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)])
|
||||
#`[(#,predicate-stx #,x) rhs]))
|
||||
(cond
|
||||
[(eq? 'box k)
|
||||
(with-syntax ([(v) (generate-temporaries #'(v))])
|
||||
(with-syntax
|
||||
([body (compile*
|
||||
(cons #'v xs)
|
||||
(map (lambda (r)
|
||||
(define-values (p1 ps) (Row-split-pats r))
|
||||
(make-Row (cons (Box-p p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
|
||||
rows)
|
||||
esc)])
|
||||
#`[(box? #,x)
|
||||
(let ([v (unbox #,x)])
|
||||
body)]))]
|
||||
[(eq? 'pair k)
|
||||
(with-syntax ([(v1 v2) (generate-temporaries #'(v1 v2))])
|
||||
(with-syntax
|
||||
([body (compile*
|
||||
(list* #'v1 #'v2 xs)
|
||||
(map (lambda (r)
|
||||
(define-values (p1 ps) (Row-split-pats r))
|
||||
(make-Row (list* (Pair-a p1) (Pair-d p1) ps) (Row-rhs r) (Row-unmatch r) (Row-vars-seen r)))
|
||||
rows)
|
||||
esc)])
|
||||
#`[(pair? #,x)
|
||||
(let ([v1 (car #,x)]
|
||||
[v2 (cdr #,x)])
|
||||
body)]))]
|
||||
[(eq? 'string k) (constant-pat #'string?)]
|
||||
[(eq? 'number k) (constant-pat #'number?)]
|
||||
[(eq? 'symbol k) (constant-pat #'symbol?)]
|
||||
[(eq? 'keyword k) (constant-pat #'keyword?)]
|
||||
[(eq? 'char k) (constant-pat #'char?)]
|
||||
[(eq? 'bytes k) (constant-pat #'bytes?)]
|
||||
[(eq? 'regexp k) (constant-pat #'regexp?)]
|
||||
[(eq? 'boolean k) (constant-pat #'boolean?)]
|
||||
[(eq? 'null k) (constant-pat #'null?)]
|
||||
[(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)]
|
||||
[(n ...) ns])
|
||||
#`[(#,arity)
|
||||
(let ([tmps (vector-ref #,x n)] ...)
|
||||
body)]))))])
|
||||
#`[(vector? #,x)
|
||||
(case (vector-length #,x)
|
||||
clauses ...)]))]
|
||||
;; it's a structure
|
||||
[(box? k)
|
||||
;; all the rows are structures with the same predicate
|
||||
(let* ([s (Row-first-pat (car rows))]
|
||||
[accs (Struct-accessors s)]
|
||||
[pred (Struct-pred s)])
|
||||
(with-syntax ([(tmps ...) (generate-temporaries accs)])
|
||||
(with-syntax ([(accs ...) accs]
|
||||
[pred pred]
|
||||
[body (compile*
|
||||
(append (syntax->list #'(tmps ...)) xs)
|
||||
(map (lambda (row)
|
||||
(define-values (p1 ps) (Row-split-pats row))
|
||||
(make-Row (append (Struct-ps p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row)))
|
||||
rows)
|
||||
esc)])
|
||||
#`[(pred #,x)
|
||||
(let ([tmps (accs #,x)] ...)
|
||||
body)])))]
|
||||
[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
|
||||
;; 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)]))])
|
||||
#`(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 (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)))])
|
||||
#`(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
|
||||
(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
|
||||
[vars (bound-vars (car qs))])
|
||||
(with-syntax ([vars vars])
|
||||
;; 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*)])
|
||||
;; then compile the rest of the 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)))))
|
||||
esc))))))]
|
||||
;; the App rule
|
||||
[(App? first)
|
||||
;; 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)]
|
||||
[pats (Row-pats row)])
|
||||
(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)))
|
||||
esc))))]
|
||||
;; the And rule
|
||||
[(And? first)
|
||||
;; 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)]
|
||||
[pats (Row-pats row)]
|
||||
;; 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)))
|
||||
esc))]
|
||||
;; the Not rule
|
||||
[(Not? first)
|
||||
;; 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)]
|
||||
[pats (Row-pats row)]
|
||||
;; 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))])
|
||||
#,(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)))
|
||||
#'f))))]
|
||||
[(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)))
|
||||
block)
|
||||
esc)])
|
||||
#`(cond [(pred? #,x) body] [else (#,esc)]))]
|
||||
;; Generalized sequences... slightly tested
|
||||
[(GSeq? first)
|
||||
(let* ([headss (GSeq-headss first)]
|
||||
[mins (GSeq-mins first)]
|
||||
[maxs (GSeq-maxs first)]
|
||||
[onces? (GSeq-onces? first)]
|
||||
[tail (GSeq-tail first)]
|
||||
[k (Row-rhs (car block))]
|
||||
[xvar (car (generate-temporaries (list #'x)))]
|
||||
[complete-heads-pattern
|
||||
(lambda (ps)
|
||||
(define (loop ps pat)
|
||||
(if (pair? ps)
|
||||
(make-Pair (car ps)
|
||||
(loop (cdr ps) pat))
|
||||
pat))
|
||||
(loop ps (make-Var xvar)))]
|
||||
[heads
|
||||
(for/list ([ps headss])
|
||||
(complete-heads-pattern ps))]
|
||||
[head-idss
|
||||
(for/list ([heads headss])
|
||||
(apply append (map bound-vars heads)))]
|
||||
[hid-argss (map generate-temporaries head-idss)]
|
||||
[hid-args (apply append hid-argss)]
|
||||
[reps (generate-temporaries (for/list ([head heads]) 'rep))])
|
||||
(with-syntax ([x xvar]
|
||||
[var0 (car vars)]
|
||||
[((hid ...) ...) head-idss]
|
||||
[((hid-arg ...) ...) hid-argss]
|
||||
[(rep ...) reps]
|
||||
[(maxrepconstraint ...)
|
||||
;; FIXME: move to side condition to appropriate pattern
|
||||
(for/list ([repvar reps] [maxrep maxs])
|
||||
(if maxrep
|
||||
#`(< #,repvar #,maxrep)
|
||||
#`#t))]
|
||||
[(minrepclause ...)
|
||||
(for/list ([repvar reps] [minrep mins] #:when minrep)
|
||||
#`[(< #,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))])
|
||||
(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))))
|
||||
...]]
|
||||
[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))])])
|
||||
#`(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 list heads)
|
||||
(syntax->list #'(rhs ...)))
|
||||
(list (make-Row (list tail) #`tail-rhs (Row-unmatch (car block)) null)))
|
||||
#'failkv)))))]
|
||||
;; doesn't work, never called
|
||||
#;
|
||||
[(VectorSeq? first)
|
||||
(let*-values ([(row) (car block)]
|
||||
[(p ps) (Row-split-pats row)]
|
||||
[(head) (VectorSeq-p p)]
|
||||
[(start) (VectorSeq-start p)]
|
||||
[(expr) (Row-rhs row)]
|
||||
[(count) (VectorSeq-count p)]
|
||||
[(head-vars) (bound-vars head)])
|
||||
(with-syntax ([var0 (car vars)]
|
||||
[(x) (generate-temporaries #'(x))]
|
||||
[(hid ...) head-vars]
|
||||
[(hid-arg ...) (generate-temporaries head-vars)]
|
||||
[(parse-k parse-loop head-var tail-var fail reps len)
|
||||
(generate-temporaries
|
||||
#'(parse-k parse-loop head-var tail-var fail reps len))])
|
||||
#`(if (vector? var0)
|
||||
(let ([len (vector-length var0)])
|
||||
(define (parse-k hid ...)
|
||||
#,(compile* xs
|
||||
(list (make-Row ps expr))
|
||||
esc))
|
||||
(define (parse-loop reps hid-arg ...)
|
||||
(define (fail)
|
||||
(parse-k (reverse hid-arg) ...))
|
||||
(if (and
|
||||
(< reps len)
|
||||
#,@(if (number? count)
|
||||
#`((reps . < . '#,(+ start count)))
|
||||
#'()))
|
||||
(let ([head-var (vector-ref var0 reps)])
|
||||
#,(compile*
|
||||
(list #'head-var)
|
||||
(list
|
||||
(make-Row (list head)
|
||||
#`(parse-loop (add1 reps)
|
||||
(cons hid hid-arg) ...)))
|
||||
#'fail))
|
||||
(fail)))
|
||||
(let ([hid null] ...)
|
||||
(parse-loop #,start hid ...)))
|
||||
(#,esc))))]
|
||||
[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 (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)))]))])
|
||||
(with-syntax ([(fns ... [_ (lambda () body)]) fns])
|
||||
(let/wrap #'(fns ...) #'body)))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;(trace compile* compile-one)
|
||||
116
collects/scheme/match/define-forms.ss
Normal file
116
collects/scheme/match/define-forms.ss
Normal file
|
|
@ -0,0 +1,116 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
"parse.ss"
|
||||
"parse-helper.ss"
|
||||
"patterns.ss"
|
||||
"gen-match.ss"))
|
||||
|
||||
(provide define-forms)
|
||||
|
||||
(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)
|
||||
(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]
|
||||
...))
|
||||
|
||||
|
||||
(define-syntax (match-lambda stx)
|
||||
(syntax-case stx ()
|
||||
[(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)))]))
|
||||
|
||||
(define-syntax (match-lambda** stx)
|
||||
(syntax-case stx ()
|
||||
[(k [(pats ...) . rhs] ...)
|
||||
(let* ([pss (syntax->list #'((pats ...) ...))]
|
||||
[len (length (syntax->list (car pss)))])
|
||||
(for/list ([ps pss])
|
||||
(unless (= (length (syntax->list ps)) len)
|
||||
(raise-syntax-error 'match "unequal number of patterns in match clauses" stx ps)))
|
||||
(with-syntax ([(vars ...) (generate-temporaries (car pss))])
|
||||
(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)
|
||||
(syntax-case stx ()
|
||||
;; an empty body is an error
|
||||
[(_ nm (clauses ...))
|
||||
(identifier? #'nm)
|
||||
(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 ...)
|
||||
(identifier? #'name)
|
||||
(syntax/loc stx (let name () body ...))]
|
||||
[(_ () body ...) (syntax/loc stx (let () body ...))]
|
||||
;; optimize the all-variable case
|
||||
[(_ ([pat exp]...) body ...)
|
||||
(andmap pattern-var? (syntax->list #'(pat ...)))
|
||||
(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))])
|
||||
(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 ...)])))
|
||||
))
|
||||
|
||||
|
||||
|
||||
(define-syntax (match-letrec stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (clauses ...)) (match:syntax-err stx "bad syntax (empty body)")]
|
||||
[(_ ([pat exp] ...) . body)
|
||||
(andmap pattern-var?
|
||||
(syntax->list #'(pat ...)))
|
||||
(syntax/loc stx (letrec ([pat exp] ...) . body))]
|
||||
[(_ ([pat exp] ...) . body)
|
||||
(syntax/loc stx (let ()
|
||||
(match-define pat exp) ...
|
||||
. body))]))
|
||||
|
||||
|
||||
|
||||
(define-syntax (match-define stx)
|
||||
(syntax-case stx ()
|
||||
[(_ pat exp)
|
||||
(pattern-var? #'pat)
|
||||
(syntax/loc stx (define pat exp))]
|
||||
[(_ pat rhs)
|
||||
;; FIXME - calls parse twice
|
||||
(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)])))))])))))
|
||||
45
collects/scheme/match/gen-match.ss
Normal file
45
collects/scheme/match/gen-match.ss
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "patterns.ss" "compiler.ss"
|
||||
syntax/stx
|
||||
(for-template scheme/base (only-in "patterns.ss" match:error)))
|
||||
|
||||
(provide go)
|
||||
|
||||
;; this parses the clauses using parse/cert, then compiles them
|
||||
;; go : syntax syntax syntax certifier -> syntax
|
||||
(define (go parse/cert stx exprs clauses cert)
|
||||
(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))))))]))
|
||||
12
collects/scheme/match/legacy-match.ss
Normal file
12
collects/scheme/match/legacy-match.ss
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
#lang scheme/base
|
||||
|
||||
(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)))
|
||||
|
||||
(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)
|
||||
61
collects/scheme/match/match-expander.ss
Normal file
61
collects/scheme/match/match-expander.ss
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax "patterns.ss"))
|
||||
|
||||
(provide define-match-expander)
|
||||
|
||||
(define-syntax (define-match-expander stx)
|
||||
(define (lookup v alist)
|
||||
(cond [(assoc v alist) => cadr]
|
||||
[else #f]))
|
||||
(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))])))))
|
||||
(syntax-case stx ()
|
||||
[(_ id kw . rest)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(let* ([args (syntax->list #'(kw . rest))]
|
||||
[parsed-args (parse args)])
|
||||
(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)))])
|
||||
(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)))))))]
|
||||
|
||||
;; 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)]
|
||||
[(_ 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)]
|
||||
|
||||
;; error checking
|
||||
[_ (raise-syntax-error #f "Invalid use of define-match-expander" stx)]
|
||||
))
|
||||
12
collects/scheme/match/match.ss
Normal file
12
collects/scheme/match/match.ss
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
#lang scheme/base
|
||||
|
||||
(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)))
|
||||
|
||||
(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)
|
||||
85
collects/scheme/match/parse-helper.ss
Normal file
85
collects/scheme/match/parse-helper.ss
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-template scheme/base)
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
scheme/struct-info
|
||||
"patterns.ss"
|
||||
"compiler.ss"
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
||||
(provide ddk? parse-literal all-vars pattern-var? match:syntax-err)
|
||||
|
||||
|
||||
|
||||
;; raise an error, blaming stx
|
||||
(define (match:syntax-err stx msg)
|
||||
(raise-syntax-error #f msg stx))
|
||||
|
||||
;; pattern-var? : syntax -> bool
|
||||
;; is p an identifier representing a pattern variable?
|
||||
(define (pattern-var? 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 #\_)))
|
||||
(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*)]))))))))
|
||||
|
||||
|
||||
;; 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))
|
||||
|
||||
;; (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))
|
||||
(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))
|
||||
(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))))))
|
||||
135
collects/scheme/match/parse-legacy.ss
Normal file
135
collects/scheme/match/parse-legacy.ss
Normal file
|
|
@ -0,0 +1,135 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-template scheme/base)
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
scheme/struct-info
|
||||
"patterns.ss"
|
||||
"compiler.ss"
|
||||
"parse-helper.ss"
|
||||
"parse-quasi.ss"
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
||||
(provide parse/legacy/cert)
|
||||
|
||||
(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)))
|
||||
|
||||
[(expander args ...)
|
||||
(and (identifier? #'expander)
|
||||
;; for debugging
|
||||
(syntax-transforming?)
|
||||
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
|
||||
(let* ([expander (syntax-local-value (cert #'expander))]
|
||||
[transformer (match-expander-legacy-xform expander)])
|
||||
(unless transformer
|
||||
(raise-syntax-error #f "This expander only works with the standard match syntax" #'expander))
|
||||
(let* ([introducer (make-syntax-introducer)]
|
||||
[certifier (match-expander-certifier expander)]
|
||||
[mstx (introducer (syntax-local-introduce stx))]
|
||||
[mresult (transformer mstx)]
|
||||
[result (syntax-local-introduce (introducer mresult))]
|
||||
[cert* (lambda (id) (certifier (cert id) #f introducer))])
|
||||
(parse/legacy/cert result cert*)))]
|
||||
[(and p ...)
|
||||
(make-And (map parse (syntax->list #'(p ...))))]
|
||||
[(or p ...)
|
||||
(let ([ps (map parse (syntax->list #'(p ...)))])
|
||||
(all-vars ps stx)
|
||||
(make-Or ps))]
|
||||
[(not p ...)
|
||||
;; nots are conjunctions of negations
|
||||
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
|
||||
(make-And ps))]
|
||||
[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 ...))))))]
|
||||
[#(es ...)
|
||||
(make-Vector (map parse (syntax->list #'(es ...))))]
|
||||
|
||||
[($ s . pats)
|
||||
(let* ([fail (lambda ()
|
||||
(raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
|
||||
[v (syntax-local-value (cert #'s) fail)])
|
||||
(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
|
||||
(define (get-lineage struct-name)
|
||||
(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 (if (not (car acc)) (cdr acc) acc)])
|
||||
(make-Struct id pred (get-lineage #'s) 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 #'s) (length acc) (length ps))
|
||||
stx #'pats))
|
||||
(map parse ps)))))))]
|
||||
[(? p q1 qs ...)
|
||||
(make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
|
||||
[(? p)
|
||||
(make-Pred (cert #'p))]
|
||||
[(= f p)
|
||||
(make-App #'f (parse (cert #'p)))]
|
||||
[(quasiquote p)
|
||||
(parse-quasi #'p cert parse/legacy/cert)]
|
||||
[(quote ())
|
||||
(make-Null (make-Dummy stx))]
|
||||
[(quote (a . b))
|
||||
(make-Pair (parse (syntax/loc stx (quote a)))
|
||||
(parse (syntax/loc stx (quote b))))]
|
||||
[(quote vec)
|
||||
(vector? (syntax-e #'vec))
|
||||
(make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
|
||||
(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))]
|
||||
[() (make-Null (make-Dummy #f))]
|
||||
[(..)
|
||||
(ddk? #'..)
|
||||
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
|
||||
[(p .. . rest)
|
||||
(ddk? #'..)
|
||||
(let* ([count (ddk? #'..)]
|
||||
[min (if (number? count) count #f)]
|
||||
[max (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 (syntax/loc stx rest))))]
|
||||
[(e . es)
|
||||
(make-Pair (parse #'e) (parse (syntax/loc stx es)))]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
(cond [(eq? '_ (syntax-e #'x))
|
||||
(make-Dummy #'x)]
|
||||
[(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
|
||||
[else (make-Var #'x)])]
|
||||
[v
|
||||
(or (parse-literal (syntax-e #'v))
|
||||
(raise-syntax-error 'match "syntax error in pattern" stx))]))
|
||||
84
collects/scheme/match/parse-quasi.ss
Normal file
84
collects/scheme/match/parse-quasi.ss
Normal file
|
|
@ -0,0 +1,84 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-template scheme/base)
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
scheme/struct-info
|
||||
"patterns.ss"
|
||||
"compiler.ss"
|
||||
"parse-helper.ss"
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
||||
(provide parse-quasi)
|
||||
|
||||
;; 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))]
|
||||
[(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))]
|
||||
[(Null? p1) p2]
|
||||
[else (error 'match "illegal input to append-pats")]))
|
||||
|
||||
;; parse stx as a quasi-pattern
|
||||
;; parse/cert parses unquote
|
||||
(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-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)))]
|
||||
[(p dd)
|
||||
(ddk? #'dd)
|
||||
(let* ([count (ddk? #'..)]
|
||||
[min (if (number? count) count #f)]
|
||||
[max (if (number? count) count #f)])
|
||||
(make-GSeq
|
||||
(parameterize ([match-...-nesting (add1 (match-...-nesting))])
|
||||
(list (list (pq #'p))))
|
||||
(list min)
|
||||
;; no upper bound
|
||||
(list #f)
|
||||
;; patterns in p get bound to lists
|
||||
(list #f)
|
||||
(make-Null (make-Dummy #f))))]
|
||||
[(a . b) (make-Pair (pq #'a) (pq #'b))]
|
||||
;; the hard cases
|
||||
[#(p ...)
|
||||
(ormap (lambda (p)
|
||||
(or (ddk? p)
|
||||
(syntax-case p (unquote-splicing)
|
||||
[(unquote-splicing . _) #t]
|
||||
[_ #f])))
|
||||
(syntax->list #'(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
|
||||
(box? (syntax-e #'bx))
|
||||
(make-Box (pq (unbox (syntax-e #'bx))))]
|
||||
[()
|
||||
(make-Null (make-Dummy #f))]
|
||||
[v
|
||||
(or (parse-literal (syntax-e #'v))
|
||||
(raise-syntax-error 'match "syntax error in quasipattern" stx))]))
|
||||
243
collects/scheme/match/parse.ss
Normal file
243
collects/scheme/match/parse.ss
Normal file
|
|
@ -0,0 +1,243 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-template scheme/base)
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
scheme/struct-info
|
||||
"patterns.ss"
|
||||
"compiler.ss"
|
||||
"parse-helper.ss"
|
||||
"parse-quasi.ss"
|
||||
"match-expander.ss"
|
||||
(only-in srfi/1 delete-duplicates))
|
||||
|
||||
(provide parse/cert)
|
||||
|
||||
;; 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)
|
||||
(lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
|
||||
[(expander args ...)
|
||||
(and (identifier? #'expander)
|
||||
(match-expander? (syntax-local-value (cert #'expander) (lambda () #f))))
|
||||
(let* ([expander (syntax-local-value (cert #'expander))]
|
||||
[transformer (match-expander-match-xform expander)])
|
||||
(unless transformer
|
||||
(raise-syntax-error #f "This expander only works with the legacy match syntax" #'expander))
|
||||
(let* ([introducer (make-syntax-introducer)]
|
||||
[certifier (match-expander-certifier expander)]
|
||||
[mstx (introducer (syntax-local-introduce stx))]
|
||||
[mresult (transformer mstx)]
|
||||
[result (syntax-local-introduce (introducer mresult))]
|
||||
[cert* (lambda (id) (certifier (cert id) #f introducer))])
|
||||
(parse/cert result cert*)))]
|
||||
[(var v)
|
||||
(identifier? #'v)
|
||||
(make-Var #'v)]
|
||||
[(and p ...)
|
||||
(make-And (map parse (syntax->list #'(p ...))))]
|
||||
[(or p ...)
|
||||
(let ([ps (map parse (syntax->list #'(p ...)))])
|
||||
(all-vars ps stx)
|
||||
(make-Or ps))]
|
||||
[(not p ...)
|
||||
;; nots are conjunctions of negations
|
||||
(let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))])
|
||||
(make-And ps))]
|
||||
[(regexp r)
|
||||
(make-And (list (make-Pred #'string?) (make-App #'(lambda (e) (regexp-match r e)) (make-Pred #'values))))]
|
||||
[(regexp r p)
|
||||
(make-And (list (make-Pred #'string?) (make-App #'(lambda (e) (regexp-match r e)) (parse #'p))))]
|
||||
[(pregexp r)
|
||||
(make-And (list (make-Pred #'string?) (make-App (syntax/loc #'r
|
||||
(lambda (e) (regexp-match (if (pregexp? r)
|
||||
r
|
||||
(pregexp r))
|
||||
e)))
|
||||
(make-Pred #'values))))]
|
||||
[(pregexp r p)
|
||||
(make-And (list (make-Pred #'string?) (make-App (syntax/loc #'r
|
||||
(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 ...)))
|
||||
(make-And (list (make-Pred #'vector?) (make-App #'vector->list (parse (syntax/loc stx (list es ...))))))]
|
||||
[(vector es ...)
|
||||
(make-Vector (map parse (syntax->list #'(es ...))))]
|
||||
[(hash-table p ... dd)
|
||||
(ddk? #'dd)
|
||||
(make-And
|
||||
(list
|
||||
(make-Pred #'hash-table?)
|
||||
(make-App
|
||||
#'(lambda (e) (hash-table-map e list))
|
||||
(with-syntax ([(elems ...) (map (lambda (p)
|
||||
(syntax-case p ()
|
||||
[(a b) #'(list a b)]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#'x]))
|
||||
(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 ...))))]
|
||||
[(hash-table p ...)
|
||||
(make-And
|
||||
(list
|
||||
(make-Pred #'hash-table?)
|
||||
(make-App
|
||||
#'(lambda (e) (hash-table-map e list))
|
||||
(with-syntax ([(elems ...) (map (lambda (p)
|
||||
(syntax-case p ()
|
||||
[(a b) #'(list a b)]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
#'x]))
|
||||
(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)
|
||||
(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))))]
|
||||
[(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 ...))))]
|
||||
[(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))))]
|
||||
[(list) (make-Null (make-Dummy stx))]
|
||||
[(list ..)
|
||||
(ddk? #'..)
|
||||
(raise-syntax-error 'match "incorrect use of ... in pattern" stx #'..)]
|
||||
[(list p .. . rest)
|
||||
(ddk? #'..)
|
||||
(let* ([count (ddk? #'..)]
|
||||
[min (if (number? count) count #f)]
|
||||
[max (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 (syntax/loc stx (list . rest)))))]
|
||||
[(list e es ...)
|
||||
(make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))]
|
||||
[(list-rest e)
|
||||
(parse #'e)]
|
||||
[(list-rest p dd . rest)
|
||||
(ddk? #'dd)
|
||||
(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 (syntax/loc stx (list-rest . rest)))))]
|
||||
[(list-rest e . es)
|
||||
(make-Pair (parse #'e) (parse (syntax/loc #'es (list-rest . es))))]
|
||||
[(cons e1 e2) (make-Pair (parse #'e1) (parse #'e2))]
|
||||
[(struct s pats)
|
||||
(let* ([fail (lambda ()
|
||||
(raise-syntax-error 'match (format "~a does not refer to a structure definition" (syntax->datum #'s)) stx #'s))]
|
||||
[v (syntax-local-value (cert #'s) fail)])
|
||||
(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
|
||||
(define (get-lineage struct-name)
|
||||
(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 (if (not (car acc)) (cdr acc) acc)])
|
||||
(make-Struct id pred (get-lineage #'s) 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 #'s) (length acc) (length ps))
|
||||
stx #'pats))
|
||||
(map parse ps)))))))]
|
||||
[(? p q1 qs ...)
|
||||
(make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))]
|
||||
[(? p)
|
||||
(make-Pred (cert #'p))]
|
||||
[(app f p)
|
||||
(make-App #'f (parse (cert #'p)))]
|
||||
[(quasiquote p)
|
||||
(parse-quasi #'p cert parse/cert)]
|
||||
[(quote ())
|
||||
(make-Null (make-Dummy stx))]
|
||||
[(quote (a . b))
|
||||
(make-Pair (parse (syntax/loc stx (quote a)))
|
||||
(parse (syntax/loc stx (quote b))))]
|
||||
[(quote vec)
|
||||
(vector? (syntax-e #'vec))
|
||||
(make-Vector (for/list ([e (vector->list (syntax-e #'vec))])
|
||||
(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))]
|
||||
[x
|
||||
(identifier? #'x)
|
||||
(cond [(eq? '_ (syntax-e #'x))
|
||||
(make-Dummy #'x)]
|
||||
[(ddk? #'x) (raise-syntax-error 'match "incorrect use of ... in pattern" stx #'x)]
|
||||
[else (make-Var #'x)])]
|
||||
[v
|
||||
(or (parse-literal (syntax-e #'v))
|
||||
(raise-syntax-error 'match "syntax error in pattern" stx))]))
|
||||
|
||||
;(trace parse)
|
||||
|
||||
|
||||
|
||||
|
||||
224
collects/scheme/match/patterns.ss
Normal file
224
collects/scheme/match/patterns.ss
Normal file
|
|
@ -0,0 +1,224 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require syntax/boundmap
|
||||
mzlib/trace
|
||||
scheme/stxparam
|
||||
scheme/contract
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide (except-out (all-defined-out)
|
||||
struct-key-ht
|
||||
get-key
|
||||
(struct-out Row)
|
||||
(struct-out exn:misc:match))
|
||||
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-struct Pat () #:transparent)
|
||||
;; v is an identifier
|
||||
(define-struct (Var Pat) (v)
|
||||
#:transparent
|
||||
#:property
|
||||
prop:custom-write (lambda (v p w?)
|
||||
(fprintf p "(Var ~a)" (syntax-e (Var-v v)))))
|
||||
(define-struct (Dummy Var) ()
|
||||
#:transparent
|
||||
#:property
|
||||
prop:custom-write (lambda (v p w?)
|
||||
(fprintf p "_")))
|
||||
|
||||
;; constructor patterns
|
||||
(define-struct (CPat Pat) () #:transparent)
|
||||
|
||||
;; start is what index to start at
|
||||
(define-struct (Vector CPat) (ps) #:transparent)
|
||||
|
||||
(define-struct (VectorSeq Pat) (p count start) #:transparent)
|
||||
|
||||
(define-struct (Pair CPat) (a d) #:transparent)
|
||||
|
||||
(define-struct (Box CPat) (p) #:transparent)
|
||||
|
||||
;; p is a pattern to match against the literal
|
||||
(define-struct (Atom CPat) (p) #:transparent)
|
||||
(define-struct (String Atom) () #:transparent)
|
||||
(define-struct (Number Atom) () #:transparent)
|
||||
(define-struct (Symbol Atom) () #:transparent)
|
||||
(define-struct (Keyword Atom) () #:transparent)
|
||||
(define-struct (Char Atom) () #:transparent)
|
||||
(define-struct (Bytes Atom) () #:transparent)
|
||||
(define-struct (Regexp Atom) () #:transparent)
|
||||
(define-struct (Boolean Atom) () #:transparent)
|
||||
(define-struct (Null Atom) () #:transparent)
|
||||
|
||||
;; expr is an expression
|
||||
;; p is a pattern
|
||||
(define-struct (App Pat) (expr p) #:transparent)
|
||||
|
||||
;; pred is an expression
|
||||
(define-struct (Pred Pat) (pred) #:transparent)
|
||||
|
||||
;; pred is an identifier
|
||||
;; super is an identifier, or #f
|
||||
;; accessors is a listof identifiers (NB in reverse order from the struct info)
|
||||
;; ps is a listof patterns
|
||||
(define-struct (Struct CPat) (id pred super accessors ps) #:transparent)
|
||||
|
||||
;; both fields are lists of pats
|
||||
(define-struct (HashTable CPat) (key-pats val-pats) #:transparent)
|
||||
|
||||
;; ps are patterns
|
||||
(define-struct (Or Pat) (ps) #:transparent)
|
||||
(define-struct (And Pat) (ps) #:transparent)
|
||||
;; p is a pattern
|
||||
(define-struct (Not Pat) (p) #:transparent)
|
||||
|
||||
;; 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)
|
||||
;; tail : pattern
|
||||
(define-struct (GSeq Pat) (headss mins maxs onces? tail) #:transparent)
|
||||
|
||||
;; match with equal?
|
||||
;; v is a quotable scheme value
|
||||
(define-struct (Exact Pat) (v) #:transparent)
|
||||
|
||||
;; pats is a Listof Pat
|
||||
;; rhs is an expression
|
||||
;; unmatch is an identifier
|
||||
;; 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 <expr>)" (Row-pats v))))
|
||||
|
||||
|
||||
|
||||
(define struct-key-ht (make-free-identifier-mapping))
|
||||
(define (get-key id)
|
||||
(free-identifier-mapping-get
|
||||
struct-key-ht id
|
||||
(lambda ()
|
||||
(let ([k (box-immutable (syntax-e id))])
|
||||
(free-identifier-mapping-put! struct-key-ht id k)
|
||||
k))))
|
||||
|
||||
;; pat-key returns either an immutable box, or a symbol., or #f
|
||||
;; the result is a box iff the argument was a struct pattern
|
||||
;; (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]
|
||||
[(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)
|
||||
|
||||
;; Row-first-pat : Row -> Pat
|
||||
;; Row must not have empty list of pats
|
||||
(define (Row-first-pat r)
|
||||
(car (Row-pats r)))
|
||||
|
||||
(define (Row-split-pats r)
|
||||
(define p (Row-pats r))
|
||||
(values (car p) (cdr p)))
|
||||
|
||||
|
||||
;; merge : (liftof (listof id)) -> (listof id)
|
||||
;; 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)))]))
|
||||
;; bound-vars : Pat -> listof identifiers
|
||||
(define (bound-vars p)
|
||||
(cond
|
||||
[(Dummy? p) null]
|
||||
[(Pred? p) null]
|
||||
[(Var? p) (list (Var-v p))]
|
||||
[(Or? p)
|
||||
(bound-vars (car (Or-ps p)))]
|
||||
[(Box? p)
|
||||
(bound-vars (Box-p p))]
|
||||
[(Atom? p) null]
|
||||
[(Pair? p)
|
||||
(merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-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))))))]
|
||||
[(Vector? p)
|
||||
(merge (map bound-vars (Vector-ps p)))]
|
||||
[(Struct? p)
|
||||
(merge (map bound-vars (Struct-ps p)))]
|
||||
[(App? p)
|
||||
(bound-vars (App-p p))]
|
||||
[(Not? p) null]
|
||||
[(And? p)
|
||||
(merge (map bound-vars (And-ps p)))]
|
||||
[(Exact? p) null]
|
||||
[else (error 'match "bad pattern: ~a" p)]))
|
||||
|
||||
(define match-...-nesting (make-parameter 0))
|
||||
(define match-equality-test (make-parameter equal?))
|
||||
|
||||
(define-syntax-parameter fail
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f
|
||||
"used out of context: not in match pattern"
|
||||
stx)))
|
||||
|
||||
#|
|
||||
;; EXAMPLES
|
||||
|
||||
(define p-x (make-Var #'x))
|
||||
(define p-y (make-Var #'y))
|
||||
(define p-d (make-Dummy #'_))
|
||||
|
||||
(define p-cons (make-Pair p-x p-y))
|
||||
(define p-vec (make-Vector (list p-x p-y p-d)))
|
||||
|
||||
(define r1 (make-Row (list p-x) #'#f #f null))
|
||||
(define r2 (make-Row (list p-y) #'#f #f null))
|
||||
(define r3 (make-Row (list p-cons) #'#f #f null))
|
||||
(define r4 (make-Row (list p-vec p-d) #'#f #f null))
|
||||
|#
|
||||
|
||||
(provide/contract (struct Row ([pats (listof Pat?)]
|
||||
[rhs syntax?]
|
||||
[unmatch (or/c identifier? false/c)]
|
||||
[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))
|
||||
85
collects/scheme/match/split-rows.ss
Normal file
85
collects/scheme/match/split-rows.ss
Normal file
|
|
@ -0,0 +1,85 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "patterns.ss")
|
||||
|
||||
(provide split-rows)
|
||||
|
||||
;; 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.
|
||||
(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))]))]))
|
||||
(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))]))]))
|
||||
(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))]))]))
|
||||
|
||||
(require mzlib/trace)
|
||||
;(trace split-rows)
|
||||
|
||||
;; EXAMPLES:
|
||||
#|
|
||||
(define mat1 (list r1 r2 r3))
|
||||
(define mat2 (list r1 r3 r2 r1))|#
|
||||
Loading…
Reference in New Issue
Block a user