gen-match is the gateway through which match accesses the match - ;; pattern compiler. - ;; - ;;
exp - the expression that is to be tested against the pattern. - ;; This should normally be a piece of syntax that indirectly - ;; represents the expression. Because if it is the syntax of the - ;; expression itself it will be duplicated many times throughout - ;; the generated match test. - ;; - ;;
tsf - is a list of tests-seen-so-far and is used to - ;; prevent generating tests for the same condition twice - ;; - ;;
patlist - is a list of the pattern clauses of the match expr - ;; these can be of either form (pat body ...) or - ;; (pat (=> fail) body ...) - ;; - ;;
stx is the original syntax of the match expression. - ;; This is only used for error reporting. - ;; - ;;
success-func - an optional argument which allows one to - ;; specify how a successful match is treated. This made - ;; the creation of match-letrec and match-define macros simple. - ;; The reason for this function is that most of the information - ;; about a match (namely the bound match variables) is at the bottom - ;; of the recursion tree. The success function must take two arguments - ;; and it should return a syntax object. - (define/opt (gen-match exp patlist stx [success-func #f]) - (begin-with-definitions - (when (stx-null? patlist) - (match:syntax-err stx "null clause list")) - ;; We set up the list of - ;; clauses so that one can mark that they have been "reached". - (define marked-clauses (mark-patlist patlist)) - (define failure-func #'(match-failure)) - ;; iterate through list and render each pattern to a list of partially compiled tests - ;; and success functions. - ;; These are partially compiled - ;; because the test structures containa a function that needs to - ;; be coupled with the other functions of the other test - ;; structures before actual compilation results. - (define rendered-list (map (lambda (clause) (test-list-with-success-func - exp clause stx success-func)) - marked-clauses)) - (update-counts rendered-list) - (tag-negate-tests rendered-list) - (update-binding-counts rendered-list) - ;; couple the partially compiled tests together into the final result. - (define compiled-exp - ((meta-couple (reorder-all-lists rendered-list) - (lambda (sf bv) failure-func) - '() - '()) - '() '())) - ;; Also wrap the final compilation in syntax which binds the - ;; match-failure function. - (define compiled-match - #`(let ([match-failure (lambda () #,(quasisyntax/loc stx (match:error #,exp)))]) - #,compiled-exp)) - (unreachable marked-clauses stx) - compiled-match)) - ) diff --git a/collects/mzlib/private/match/getbindings.ss b/collects/mzlib/private/match/getbindings.ss deleted file mode 100644 index c50378fca4..0000000000 --- a/collects/mzlib/private/match/getbindings.ss +++ /dev/null @@ -1,141 +0,0 @@ -(module getbindings mzscheme - (provide getbindings@) - - (require "coupling-and-binding.scm" - "update-binding-counts.scm" - "render-helpers.ss" - "render-sigs.ss" - mzlib/unit) - - (require-for-template mzscheme) - - (define-unit getbindings@ - (import render-test-list^) - (export getbindings^) - - ;;!(function next-outer - ;; (form (next-outer p ae sf bv let-bound kf ks syntax bool) - ;; -> - ;; syntax) - ;; (contract (syntax syntax list list list (list list -> syntax) - ;; (list list -> syntax) syntax bool) - ;; -> - ;; syntax)) - ;; The function next-outer is basically a throw-back to the next - ;; function of the original match compiler. It compiles a pattern - ;; or sub-pattern of a clause and does not yield a list of - ;; partially compiled test structs. This function is called - ;; inside of test constructs that cannot be eliminated because of - ;; a related presence in the test-so-far list. So, instead of - ;; partially compiling patterns this function fully compiles patterns. - (define/opt (next-outer - p - ae ;; this is the actual expression - sf - bv - let-bound - kf - ks - cert - [stx (syntax '())]) - (next-outer-helper p ae sf bv let-bound - (lambda (x) kf) (lambda (a b) ks) cert stx)) - - (define/opt (next-outer* - p - ae ;; this is the actual expression - sf - bv - let-bound - kf - ks - cert - [stx (syntax '())]) - (next-outer-helper p ae sf bv let-bound - (lambda (x) kf) (lambda (a b) (ks b)) cert stx)) - - ;;!(function next-outer-helper - ;; (form (next-outer p ae sf bv let-bound kf-func ks-func syntax bool) - ;; -> - ;; syntax) - ;; (contract (syntax syntax list list list (list list -> syntax) - ;; (list list -> syntax) syntax bool) - ;; -> - ;; syntax)) - ;; The function next-outer-helper contains the meat of next-outer - ;; and allows the programmer to pass higher order functions - ;; ks-func and kf-func that will be given compile time imformation - ;; about let-bindings etc. which in turn will allow the programmer - ;; to take advantage of this info. - (define/opt (next-outer-helper - p - ae ;; this is the actual expression - sf - bv - let-bound - kf-func - ks-func - cert - [stx (syntax '())]) - ;; right now this does not bind new variables - (let ((rendered-list (render-test-list p ae cert stx))) - ;; no need to reorder lists although I suspect that it may be - ;; better to put shape tests first - (update-binding-count rendered-list) - ((couple-tests rendered-list ks-func kf-func let-bound) sf bv))) - - ;;!(function create-test-func - ;; (form (create-test-func p sf let-bound bind-map last-test) - ;; -> - ;; syntax) - ;; (contract (syntax list list a-list bool) -> syntax)) - ;; This function creates a runtime function that is used as an - ;; individual test in a list of tests for the list-no-order - ;; pattern. - ;;
- ;; bindmap - a-list of bindings mapped to their expressions - ;; last-test - a boolean value that indicates whether this function - ;; is collecting one value or a list of values.- (define (create-test-func p sf let-bound bind-map last-test cert) - #`(lambda (exp) - #,(next-outer-helper - p #'exp sf '() let-bound - (lambda (let-bound) - (lambda (sf bv) - #'#f)) - (lambda (fail let-bound) - (lambda (sf bv) - #`(begin - #,@(map (lambda (bind) - (let ((binding-name (get-bind-val (car bind) bind-map)) - (exp-to-bind - (subst-bindings (cdr bind) let-bound))) - (if last-test - #`(set! #,binding-name - (cons #,exp-to-bind #,binding-name)) - #`(set! #,binding-name - #,exp-to-bind)))) - bv) - #t))) - cert))) - - ;;!(function getbindings - ;; (form (getbindings pat-syntax) -> list) - ;; (contract syntax -> list)) - ;; This function given a pattern returns a list of pattern - ;; variable names which are found in the pattern. - (define (getbindings pat-syntax cert) - (let/cc out - (next-outer - pat-syntax - (quote-syntax dummy) - '() - '() - '() - (lambda (sf bv) #'(dummy-symbol)) - (lambda (sf bv) (out (map car bv))) - cert))) - - ;; end getbindings@ - ) - ) diff --git a/collects/mzlib/private/match/getter-setter.scm b/collects/mzlib/private/match/getter-setter.scm deleted file mode 100644 index f3b246da3c..0000000000 --- a/collects/mzlib/private/match/getter-setter.scm +++ /dev/null @@ -1,82 +0,0 @@ -;; This library is used by match.ss - -(module getter-setter mzscheme - (provide getter setter) - (require "coupling-and-binding.scm" - "match-helper.ss" - "match-error.ss" - syntax/stx) - (require-for-template mzscheme - "match-error.ss") - - ;;!(function setter - ;; (form (setter e ident let-bound) -> syntax) - ;; (contract (syntax syntax list) -> syntax) - ;; (example (setter (syntax (mcar x)) (syntax here) '()) - ;; -> - ;; (syntax (lambda (y) (set-mcar! x y))))) - ;; This function takes an expression and returns syntax which - ;; represents a function that is able to set the value that the - ;; expression points to. - (define (setter e ident let-bound) - (define (subst e) (subst-bindings e let-bound)) - (define (mk-setter s cxt) (datum->syntax-object cxt (symbol-append 'set- s '!))) - (syntax-case e (vector-ref unbox car cdr mcar mcdr) - [p - (not (stx-pair? #'p)) - (match:syntax-err - ident - "set! pattern should be nested inside of a vector, box, or struct")] - [(vector-ref vector index) - #`(let ((x #,(subst #'vector))) - (lambda (y) (vector-set! x index y)))] - [(unbox boxed) - #`(let ((x #,(subst #'boxed))) - (lambda (y) (set-box! x y)))] - [(car exp) - (match:syntax-err - ident - "set! cannot be used within list")] - [(cdr exp) - (match:syntax-err - ident - "set! cannot be used within list")] - [(mcar exp) - #`(let ((x #,(subst #'exp))) - (lambda (y) (set-mcar! x y)))] - [(mcdr exp) - #`(let ((x #,(subst #'exp))) - (lambda (y) (set-mcdr! x y)))] - [(acc exp) - (let ([a (assq (syntax-object->datum #'acc) get-c---rs)]) - (if a - #`(let ((x (#,(cadr a) #,(subst #'exp)))) - (lambda (y) (#,(mk-setter (cddr a) #'acc) x y))) - #`(let ((x #,(subst #'exp))) - (lambda (y) - (#,(mk-setter (syntax-object->datum #'acc) #'acc) x y)))))])) - - ;;!(function getter - ;; (form (getter e ident let-bound) -> syntax) - ;; (contract (syntax syntax list) -> syntax) - ;; (example (getter (syntax (car x)) (syntax here) '()) - ;; -> - ;; (syntax (lambda () (car x))))) - ;; This function takes an expression and returns syntax which - ;; represents a function that is able to get the value that the - ;; expression points to. - (define (getter e ident let-bound) - (define (subst e) (subst-bindings e let-bound)) - (syntax-case e (vector-ref unbox car cdr) - [p - (not (stx-pair? #'p)) - (match:syntax-err - ident - "get! pattern should be nested inside of a list, vector or box")] - [(vector-ref vector index) - #`(let ((x #,(subst #'vector))) - (lambda () (vector-ref x index)))] - [(acc exp) - #`(let ((x #,(subst #'exp))) - (lambda () (acc x)))])) -) diff --git a/collects/mzlib/private/match/match-error.ss b/collects/mzlib/private/match/match-error.ss deleted file mode 100644 index 5c05e4a30b..0000000000 --- a/collects/mzlib/private/match/match-error.ss +++ /dev/null @@ -1,81 +0,0 @@ -(module match-error mzscheme - (provide (all-defined)) - - (require mzlib/pregexp) - - (define-struct (exn:misc:match exn:fail) (value)) - - (define match:error - (case-lambda - ((val) - (raise - (make-exn:misc:match - (format "match: no matching clause for ~e" val) - (current-continuation-marks) - val))) - ((val expr) - (raise - (make-exn:misc:match - (format "match: no matching clause for ~e: ~s" val expr) - (current-continuation-marks) - val))))) - - ;;! (function match:syntax-err - ;; (form (match:syntax-err object message . detail) -> void) - ;; (contract (any string . any) -> void) - ;; (example (match:syntax-err (syntax here) "Bad error" (vector)) - ;; -> void) - ;; (contract object -> (normally a syntax object that - ;; that helps determine the source location - ;; of the error))) - ;; This function is used to report malformed match expressions. - - (define match:syntax-err (lambda (obj msg . detail) - (apply - raise-syntax-error - 'match - msg - obj - detail))) - - (define (match:internal-err obj msg . detail) - (apply raise-syntax-error '|internal match error| msg obj detail)) - - - - ;;!(function unreachable - ;; (form (unreachable plist match-expr) -> void) - ;; (contract (list syntax-object) -> void) - ;; (contract plist -> (is a list of unreached pattern clauses)) - ;; (contract match-expr -> (is the origional match expr - ;; the clauses came from))) - ;; This function takes a list of unreached clauses and the original - ;; match expression and prints a warning for each of the unreached - ;; match clauses to the current error port - (define unreachable - (lambda (plist match-expr) - (map - (lambda (x) - (if (not (mcdr x)) - (fprintf - (current-error-port) - "Warning: unreachable match clause ~e in ~e~n" - (syntax-object->datum (mcar x)) - (syntax-object->datum match-expr)))) - plist))) - - ;; this makes pregexp errors a little more friendly - (define (pregexp-match-with-error regex str) - (if (or (string? regex) - (bytes? regex) - (regexp? regex) - (byte-regexp? regex)) - (pregexp-match regex str) - (error 'match:pregex - (string-append - "this pattern expects either a string, byte string, regexp or byte regexp," - " given " (format "~e" regex) "; " - "other argument was " (format "~e" str))))) - - - ) diff --git a/collects/mzlib/private/match/match-expander-struct.ss b/collects/mzlib/private/match/match-expander-struct.ss deleted file mode 100644 index ef326b0d3c..0000000000 --- a/collects/mzlib/private/match/match-expander-struct.ss +++ /dev/null @@ -1,7 +0,0 @@ - (module match-expander-struct mzscheme - (require "define-struct.scm") - (provide (all-defined)) - #;(provide (struct match-expander (match-xform std-xform))) - (define-struct* match-expander (plt-match-xform match-xform std-xform certifier) - (procedure-field std-xform)) - ) diff --git a/collects/mzlib/private/match/match-expander.ss b/collects/mzlib/private/match/match-expander.ss deleted file mode 100644 index 697f4c2071..0000000000 --- a/collects/mzlib/private/match/match-expander.ss +++ /dev/null @@ -1,69 +0,0 @@ -(module match-expander mzscheme - (provide (all-defined)) - (require-for-syntax "match-expander-struct.ss" - "match-error.ss") - - - - ;; (define-match-expander id [#:plt-match transformer-for-plt-match] - ;; [#:match transformer-for-match] - ;; [#:expression transformer-outside-of-match]) - - ;; There is also a legacy syntax, as follows: - ;; (define-match-expander id transformer-for-plt-match [[transformer-for-match] transformer-outside-of-match]) - - (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)) - (match:syntax-err stx-v "Argument must be a keyword")] - [(not (member v '(#:expression #:plt-match #:match))) - (match:syntax-err stx-v "Keyword argument is not a correct keyword")] - [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 - ([match-xform (lookup #:match parsed-args)] - [plt-match-xform (lookup #:plt-match parsed-args)] - [std-xform (or (lookup #:expression parsed-args) - #'(lambda (stx) - (match:syntax-err stx "This match expander must be used inside match")))]) - (if (identifier? #'std-xform) - #`(define-syntax id (make-match-expander plt-match-xform - match-xform - (lambda (stx) - (syntax-case stx (set!) - #;[(set! id v) #'(set! std-xform v)] - [(nm args (... ...)) #'(std-xform args (... ...))] - [nm #'std-xform])) - (syntax-local-certifier))) - #'(define-syntax id (make-match-expander plt-match-xform match-xform std-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 - [_ (match:syntax-err stx "Invalid use of define-match-expander")] - )) - - ) diff --git a/collects/mzlib/private/match/match-helper.ss b/collects/mzlib/private/match/match-helper.ss deleted file mode 100644 index 2f6c23e3c6..0000000000 --- a/collects/mzlib/private/match/match-helper.ss +++ /dev/null @@ -1,482 +0,0 @@ -(module match-helper mzscheme - - (provide (all-defined) - (all-from "syntax-utils.ss")) - - (require syntax/struct - "syntax-utils.ss" - "match-error.ss" - mzlib/list) - - (require-for-template mzscheme) - - ;; define a syntax-transformer in terms of a two-argument function - (define-syntax define-proc - (syntax-rules () - [(_ nm func) - (define-syntax (nm stx) (func stx stx))])) - - ;; bind an identifier to be syntax/loc with a particular location, in an expression - (define-syntax md-help - (syntax-rules () - [(md-help id stx e) - (let-syntax ([id (syntax-rules () [(id arg) (syntax/loc stx arg)])]) - e)])) - - (define (constant-data? v) - (or - (string? v) - (boolean? v) - (char? v) - (number? v) - (keyword? v) - (bytes? v))) - - - ;;!(function symbol-append - ;; (form (symbol-append . args) -> symbol) - ;; (contract ((symbol or number) ...) -> symbol) - ;; (example (symbol-append 'hello 5 'goodbye) -> 'hello5goodbye)) - ;; This function takes any number of arguments which can be either - ;; symbols or numbers and returns one symbol which is the - ;; concatenation of the input. - (define (symbol-append . l) - (define (data->string x) - (cond - [(symbol? x) (symbol->string x)] - [(number? x) (number->string x)] - [else x])) - (string->symbol (apply string-append (map data->string l)))) - - ;;!(function struct-pred-accessors-mutators - ;; (form (struct-pred-accessors-mutators struct-name) - ;; -> - ;; (values pred accessors mutators parental-chain)) - ;; (contract (syntax-object) - ;; -> - ;; (values (any -> bool) list list list))) - ;; This function takes a syntax-object that is the name of a structure. - ;; It returns four values. The first is - ;; a predicate for the structure. The second is a list of accessors - ;; in the same order as the fields of the structure declaration. The - ;; third is a list of mutators for the structure also in the same - ;; order. The last is a list of supertypes of this struct. An - ;; error is raised if the struct-name is not bound to a - ;; structure. - (define (struct-pred-accessors-mutators struct-name) - (define accessors-index 3) - (define mutators-index 4) - (define pred-index 2) - (define super-type-index 5) - (define (failure-thunk) - (match:syntax-err struct-name - "not a defined structure")) - (define (local-val sn) (syntax-local-value sn failure-thunk)) - ;; accessor/mutator lists are stored in reverse order, and can contain #f - ;; we only filter out a mutator if the accessor is also false. - ;; this function returns 2 lists of the same length if the inputs were the same length - (define (handle-acc/mut-lists accs muts) - (let*-values ([(filtered-lists) (filter (lambda (x) (car x)) (map list accs muts))] - [(accs muts) (values (map car filtered-lists) - (map cadr filtered-lists))]) - (values (reverse accs) - (reverse muts)))) - - ;; 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 (local-val struct-name)) - super-type-index)]) - (cond [(equal? super #t) '()] ;; no super type exists - [(equal? super #f) '()] ;; super type is unknown - [else (cons super (get-lineage super))]))) - - (define info-on-struct (let ([v (local-val struct-name)]) - (unless (struct-declaration-info? v) - (failure-thunk)) - (extract-struct-info v))) - - (define (ref-info i) (list-ref info-on-struct i)) - - (let*-values ([(acc-list) (ref-info accessors-index)] - [(mut-list) (ref-info mutators-index)] - [(pred) (ref-info pred-index)] - [(accessors mutators) (handle-acc/mut-lists acc-list mut-list)] - [(parental-chain) (get-lineage struct-name)]) - (values pred accessors mutators (cons struct-name parental-chain))) - ) - - - - - - - ;;!(function in - ;; (form (in e l) -> bool) - ;; (contract (s-exp list) -> bool) - ;; (example (in '(number? x) (list '(number? x))) -> #t)) - ;; This function is responsible for determining which tests are - ;; redundant. If e can be determined to be true from the list of - ;; tests l then e is "in" l. - (define (in e l) - (or - (ormap - (lambda (el) - (or (equal? e el) - (and - (eq? (car e) 'struct-pred) - (eq? (car el) 'struct-pred) - (member (caaddr e) (caddr el)) - (equal? (cadddr e) (cadddr el))))) l) - (and (eq? (car e) 'not) - (let* ((srch (cadr e)) - (const-class (equal-test? srch))) - ;(write srch) - (cond - ((equal? (car srch) 'struct-pred) - (let mem ((l l)) - (if (null? l) - #f - (let ((x (car l))) - (if (and (equal? (car x) - 'struct-pred) - (not (equal? (cadr x) (cadr srch))) - ; the current struct type should not - ; be a member of the parental-chain of - (not (member (caaddr x) (caddr srch))) - (equal? (cadddr x) (cadddr srch))) - #t - (mem (cdr l))))))) - (const-class - (let mem ((l l)) - (if (null? l) - #f - (let ((x (car l))) - (or (and (equal? - (cadr x) - (cadr srch)) - (disjoint? x) - (not (equal? - const-class - (car x)))) - (equal? - x - `(not (,const-class - ,(cadr srch)))) - (and (equal? - (cadr x) - (cadr srch)) - (equal-test? - x) - (not (equal? - (caddr - srch) - (caddr - x)))) - (mem (cdr l))))))) - ((disjoint? srch) - (let mem ((l l)) - (if (null? l) - #f - (let ((x (car l))) - (or (and (disjoint? x) - (not (equal? - (car x) - (car srch))) - (cond ((equal? - (car srch) - 'struct-pred) - (equal? - (cadr x) - ;; we use cadddr here to access the expression - ;; because struct predicates carry some extra baggage - ;; They have the form (struct-pred
This is implemented in what Wright terms as mock-continuation-passing - ;; style. The functions that create the syntax for a match success and failure - ;; are passed forward - ;; but they are always called in emit. This is extremely effective for - ;; handling the different structures that are matched. This way we can - ;; specify ahead of time how the rest of the elements of a list or vector - ;; should be handled. Otherwise we would have to pass more information - ;; forward in the argument list of next and then test for it later and - ;; then take the appropriate action. To understand this better take a - ;; look at how proper and improper lists are handled. - (define/opt (render-test-list p ae cert [stx #'here]) - (define ae-datum (syntax-object->datum ae)) - (syntax-case* - p - (_ list quote quasiquote vector box ? app and or not struct set! var - list-rest get! ... ___ unquote unquote-splicing cons - list-no-order hash-table regexp pregexp cons) stx-equal? - - ;; this is how we extend match - [(expander args ...) - (and (identifier? #'expander) - (match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) - (let* ([expander (syntax-local-value (cert #'expander))] - [transformer (match-expander-plt-match-xform expander)]) - (if (not transformer) - (match:syntax-err #'expander - "This expander only works with standard match.") - (let ([introducer (make-syntax-introducer)] - [certifier (match-expander-certifier expander)]) - (render-test-list - (introducer (transformer (introducer p))) - ae - (lambda (id) - (certifier (cert id) #f introducer)) - stx))))] - - ;; underscore is reserved to match anything and bind nothing - (_ '()) ;(ks sf bv let-bound)) - - ;; for variable patterns, we do bindings, and check if we've seen this variable before - ((var pt) - (identifier? (syntax pt)) - (list (make-act `bind-var-pat - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (cond [(ormap (lambda (x) - (if (bound-identifier=? #'pt (car x)) - (cdr x) - #f)) - bv) - => (lambda (bound-exp) - (emit (lambda (exp) - #`((match-equality-test) #,exp #,(subst-bindings bound-exp let-bound))) - ae - let-bound - sf bv kf ks))] - [else - (ks sf (cons (cons (syntax pt) ae) bv))])))))) - - ;; Recognize the empty list - ((list) (emit-null ae)) - - ;; This recognizes constants such strings - [pt - (constant-data? (syntax-e #'pt)) - (list - (reg-test - `(equal? ,ae-datum - ,(syntax-object->datum (syntax pt))) - ae (lambda (exp) #`(equal? #,exp pt))))] - - ;(pt - ; (stx-? regexp? (syntax pt)) - ; (render-test-list (syntax/loc p (regex pt)) ae stx)) - - ;; match a quoted datum - ;; this is very similar to the previous pattern, except for the second argument to equal? - [(quote item) - (list - (reg-test - `(equal? ,ae-datum - ,(syntax-object->datum p)) - ae (lambda (exp) #`(equal? #,exp #,p))))] - - ;; check for predicate patterns - ;; could we check to see if a predicate is a procedure here? - [(? pred?) - (list (reg-test - `(,(syntax-object->datum #'pred?) - ,ae-datum) - ae (lambda (exp) #`(#,(cert #'pred?) #,exp))))] - - ;; app patterns just apply their operation. - ((app op pat) - (render-test-list #'pat #`(#,(cert #'op) #,ae) cert stx)) - - [(and . pats) (apply - append - (map (lambda (pat) (render-test-list pat ae cert stx)) - (syntax->list #'pats)))] - - ((or . pats) - (list (make-act - 'or-pat ;`(or-pat ,ae-datum) - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (or-gen ae (syntax-e #'pats) - sf bv ks kf let-bound - cert stx)))))) - - - ((not pat) - (list (make-act - 'not-pat ;`(not-pat ,ae-datum) - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - ;; swap success and fail - (next-outer #'pat ae sf bv let-bound ks kf cert)))))) - - ;; could try to catch syntax local value error and rethrow syntax error - ((list-no-order pats ...) - (if (stx-null? (syntax (pats ...))) - (render-test-list #'(list) ae cert stx) - (let* ((pat-list (syntax->list (syntax (pats ...)))) - (ddk-list (ddk-in-list? pat-list)) - (ddk (ddk-only-at-end-of-list? pat-list))) - (if (or (not ddk-list) - (and ddk-list ddk)) - (let* ((bound (getbindings (append-if-necc 'list - (syntax (pats ...))) - cert)) - (bind-map - (map (lambda (x) - (cons x #`#,(gensym (syntax-object->datum x)))) - bound))) - (list - (shape-test - `(list? ,ae-datum) - ae (lambda (exp) #`(list? #,exp))) - (make-act - 'list-no-order - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (let ((last-test - (if ddk - (let ((pl (cdr (reverse pat-list)))) - (begin - (set! pat-list (reverse (cdr pl))) - (create-test-func (car pl) - sf - let-bound - bind-map - #t - cert))) - #f))) - #`(let #,(map (lambda (b) - #`(#,(cdr b) '())) - bind-map) - (let ((last-test #,last-test) - (test-list - (list - #,@(map (lambda (p) - (let ([v (create-test-func - p - sf - let-bound - bind-map - #f - cert)]) - (printf "~s ~s ~s\n" - (syntax-object->datum p) - (syntax-object->datum v) - (continuation-mark-set->context - (current-continuation-marks))) - v)) - pat-list)))) - (if (match:test-no-order test-list - #,ae - last-test - #,ddk) - #,(ks sf (append bind-map bv)) - #,(kf sf bv)))))))))) - (match:syntax-err - p - (string-append "dot dot k can only appear at " - "the end of unordered match patterns")))))) - - ((hash-table pats ...) - ;; must check the structure - #;(proper-hash-table-pattern? (syntax->list (syntax (pats ...)))) - (list - (shape-test - `(hash-table? ,ae-datum) - ae (lambda (exp) #`(hash-table? #,exp))) - - (let ([mod-pat - (lambda (pat) - (syntax-case* pat (var) stx-equal? - [(var id) pat] - [(keypat valpat) (syntax/loc pat (list keypat valpat))] - [_ pat]))]) - (make-act - 'hash-table-pat - ae - (lambda (ks kf let-bound) - (lambda (sf bv) - (let ((hash-name (gensym 'hash))) - #`(let ((#,hash-name - (hash-table-map #,(subst-bindings ae - let-bound) - (lambda (k v) (list k v))))) - #,(next-outer #`(list-no-order #,@(syntax-map mod-pat #'(pats ...))) - #`#,hash-name - sf - ;; these tests have to be true - ;;(append (list - ;; '(pair? exp) - ;; '(pair? (cdr exp)) - ;; '(null? (cdr (cdr exp)))) - ;; sf) - bv - let-bound - kf - ks - cert))))))))) - - ((struct struct-name (fields ...)) - (identifier? (syntax struct-name)) - (let*-values ([(field-pats) (syntax->list (syntax (fields ...)))] - [(num-of-fields) (length field-pats)] - [(pred accessors mutators parental-chain) - (struct-pred-accessors-mutators (cert #'struct-name))] - ;; check that we have the right number of fields - [(dif) (- (length accessors) num-of-fields)]) - (unless (zero? dif) - (match:syntax-err - p - (string-append - (if (> dif 0) "not enough " "too many ") - "fields for structure in pattern"))) - (cons - (shape-test - `(struct-pred ,(syntax-object->datum pred) - ,(map syntax-object->datum parental-chain) - ,ae-datum) - ae (lambda (exp) #`(struct-pred #,pred #,parental-chain #,exp))) - (apply - append - (map - (lambda (cur-pat cur-mutator cur-accessor) - (syntax-case cur-pat (set! get!) - [(set! . rest) - (unless cur-mutator (match:syntax-err cur-pat "Cannot use set! pattern with immutable fields")) - (set/get-matcher 'set! ae p #'rest - #`(lambda (y) - (#,cur-mutator #,ae y)))] - [(get! . rest) - (set/get-matcher 'get! ae p #'rest - #`(lambda () - (#,cur-accessor #,ae)))] - [_ (render-test-list - cur-pat - (quasisyntax/loc cur-pat (#,cur-accessor #,ae)) - cert - stx)])) - field-pats mutators accessors))))) - - ;; syntax checking - ((struct ident ...) - (match:syntax-err - p - (if (zero? (length (syntax-e (syntax (ident ...))))) - (format "~a~n~a~n~a" - "a structure pattern must have the name " - "of a defined structure followed by a list of patterns " - "to match each field of that structure") - "syntax error in structure pattern"))) - ;; use a helper macro to match set/get patterns. - ;; we give it the whole rest so that it can do error-checking and reporting - [(set! . rest) - (set/get-matcher 'set! ae p let-bound (syntax rest) - (setter ae p let-bound))] - [(get! . rest) - (set/get-matcher 'get! ae p let-bound (syntax rest) - (getter ae p let-bound))] - - ;; list pattern with ooo or ook - ((list pat dot-dot-k pat-rest ...) - (and (not (or (memq (syntax-e (syntax pat)) - '(unquote unquote-splicing ... ___)) - (stx-dot-dot-k? (syntax pat)))) - (stx-dot-dot-k? (syntax dot-dot-k))) - (begin - (list - (shape-test - `(list? ,ae-datum) - ae (lambda (exp) #`(list? #,exp))) - (make-act - 'list-ddk-pat - ae - (lambda (ks kf let-bound) - (if (stx-null? (syntax (pat-rest ...))) - (handle-end-ddk-list ae kf ks - (syntax pat) - (syntax dot-dot-k) - let-bound - cert) - (handle-inner-ddk-list ae kf ks - (syntax pat) - (syntax dot-dot-k) - (append-if-necc 'list - (syntax (pat-rest ...))) - let-bound - cert))))))) - - ;; list-rest pattern with a ooo or ook pattern - ((list-rest pat dot-dot-k pat-rest ...) - (and (not (or (memq (syntax-e (syntax pat)) - '(unquote unquote-splicing ... ___)) - (stx-dot-dot-k? (syntax pat)) - (stx-null? (syntax (pat-rest ...))))) - (stx-dot-dot-k? (syntax dot-dot-k))) - (list - (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (make-act - 'list-ddk-pat - ae - (lambda (ks kf let-bound) - (handle-inner-ddk-list - ae kf ks - (syntax pat) - (syntax dot-dot-k) - (if (= 1 (length - (syntax->list (syntax (pat-rest ...))))) - (stx-car (syntax (pat-rest ...))) - (append-if-necc 'list-rest - (syntax (pat-rest ...)))) - let-bound - cert))))) - - ;; list-rest pattern for improper lists - ;; handle proper and improper lists - ((list-rest car-pat cdr-pat) ;pattern ;(pat1 pats ...) - (not (or (memq (syntax-e (syntax car-pat)) - '(unquote unquote-splicing)) - (stx-dot-dot-k? (syntax car-pat)))) - (cons - (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (append - (render-test-list (syntax car-pat) - (quasisyntax/loc (syntax car-pat) (car #,ae)) - cert - stx) ;(add-a e) - (render-test-list - (syntax cdr-pat) - #`(cdr #,ae) - cert - stx)))) - - ;; list-rest pattern - ((list-rest car-pat cdr-pat ...) ;pattern ;(pat1 pats ...) - (not (or (memq (syntax-e (syntax car-pat)) - '(unquote unquote-splicing)) - (stx-dot-dot-k? (syntax car-pat)))) - (cons - (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (append - (render-test-list (syntax car-pat) - #`(car #,ae) - cert - stx) ;(add-a e) - (render-test-list - (append-if-necc 'list-rest (syntax (cdr-pat ...))) - #`(cdr #,ae) - cert - stx)))) - - ;; general list pattern - ((list car-pat cdr-pat ...) ;pattern ;(pat1 pats ...) - (not (or (memq (syntax-e (syntax car-pat)) - '(unquote unquote-splicing)) - (stx-dot-dot-k? (syntax car-pat)))) - (cons - (shape-test - `(pair? ,ae-datum) - ae (lambda (exp) #`(pair? #,exp))) - (append - (render-test-list (syntax car-pat) - #`(car #,ae) - cert - stx) ;(add-a e) - (if (stx-null? (syntax (cdr-pat ...))) - (list - (shape-test - `(null? (cdr ,ae-datum)) - ae (lambda (exp) #`(null? #,exp)) #`(cdr #,ae))) - (render-test-list - (append-if-necc 'list (syntax (cdr-pat ...))) - #`(cdr #,ae) - cert - stx))))) - - ;; vector pattern with ooo or ook at end - ((vector pats ...) - (ddk-only-at-end-of-list? (syntax-e (syntax (pats ...)))) - (list - (shape-test - `(vector? ,ae-datum) - ae (lambda (exp) #`(vector? #,exp))) - (make-act - 'vec-ddk-pat - ae - (lambda (ks kf let-bound) - (handle-ddk-vector ae kf ks - #'#(pats ...) - let-bound - cert))))) - - ;; vector pattern with ooo or ook, but not at end - [(vector pats ...) - (let* ((temp (syntax-e (syntax (pats ...)))) - (len (length temp))) - (and (>= len 2) - (ddk-in-list? temp))) - ;; make this contains ddk with no ddks consecutive - ;;(stx-dot-dot-k? (vector-ref temp (sub1 len)))))) - (list - (shape-test - `(vector? ,ae-datum) - ae (lambda (exp) #`(vector? #,exp))) - ;; we have to look at the first pattern and see if a ddk follows it - ;; if so handle that case else handle the pattern - (make-act - 'vec-ddk-pat - ae - (lambda (ks kf let-bound) - (handle-ddk-vector-inner ae kf ks - #'#(pats ...) - let-bound - cert))))] - - ;; plain old vector pattern - [(vector pats ...) - (let* ([syntax-vec (list->vector (syntax->list (syntax (pats ...))))] - [vlen (vector-length syntax-vec)]) - (list* - (shape-test - `(vector? ,ae-datum) ae - (lambda (exp) #`(vector? #,exp))) - (shape-test - `(equal? (vector-length ,ae-datum) ,vlen) - ae (lambda (exp) #`(equal? (vector-length #,exp) #,vlen))) - (let vloop ((n 0)) - (if (= n vlen) - '() - (append - (render-test-list - (vector-ref syntax-vec n) - #`(vector-ref #,ae #,n) - cert - stx) - (vloop (+ 1 n)))))))] - - [(box pat) - (cons - (shape-test - `(box? ,ae-datum) - ae (lambda (exp) #`(box? #,exp))) - (render-test-list - #'pat #`(unbox #,ae) cert stx))] - - ;; This pattern wasn't a valid form. - [got-too-far - (match:syntax-err - #'got-too-far - "syntax error in pattern")])) - - ;; end of render-test-list@ - ) - - ) diff --git a/collects/mzlib/private/match/render-test-list.scm b/collects/mzlib/private/match/render-test-list.scm deleted file mode 100644 index 1950b33dbd..0000000000 --- a/collects/mzlib/private/match/render-test-list.scm +++ /dev/null @@ -1,19 +0,0 @@ -;; This library is used by match.ss -(module render-test-list mzscheme - - (provide render-test-list) - - (require "render-sigs.ss" - "render-test-list-impl.ss" - "getbindings.ss" - "ddk-handlers.ss" - mzlib/unit) - - (define-compound-unit/infer rtl@ - (import) - (export render-test-list^) - (link render-test-list@ getbindings@ ddk-handlers@)) - - (define-values/invoke-unit/infer rtl@) - - ) diff --git a/collects/mzlib/private/match/reorder-tests.scm b/collects/mzlib/private/match/reorder-tests.scm deleted file mode 100644 index cae052673e..0000000000 --- a/collects/mzlib/private/match/reorder-tests.scm +++ /dev/null @@ -1,102 +0,0 @@ -;; This library is used by match.ss -;; This requires the test data structure. -(module reorder-tests mzscheme - - (provide reorder-all-lists) - - (require "test-structure.scm") - - (require-for-template mzscheme) - - ;; There really ought to be a stable sort in the std library. - - ;;!(function insertion-sort - ;; (form (insertion-sort ls less-than?) -> list) - ;; (contract (list (any any -> bool) -> list))) - ;; This is the classic stable sort. Any stable sort will do. - (define insertion-sort - (lambda (ls less-than?) - (define (insert el ls) - (define (ins ls) - (cond ((null? ls) (list el)) - ((less-than? el (car ls)) - (cons el ls)) - (else (cons (car ls) (ins (cdr ls)))))) - (ins ls)) - (letrec ((IS (lambda (ls) - (if (null? ls) - '() - (insert (car ls) - (IS (cdr ls))))))) - (IS ls)))) - - ;;!(function make-test-order-func - ;; (form (make-test-order-func whole-list) -> less-than?) - ;; (contract list -> (any any -> bool))) - ;; This function creates a test function which has access to the - ;;whole list of test structures capured in the closure. This - ;;function places tests that are used more ahead of those used - ;;less. When tests are used an equal number of times the test whos - ;;membership set has the greatest presence is placed ahead. - (define make-test-order-func - (lambda (whole-list) - (lambda (t1 t2) - (let ((t1-tu (test-times-used t1)) - (t2-tu (test-times-used t2))) - (cond ((> t1-tu t2-tu) #t) - ;; these two new rules allow negate - ;; tests to be placed properly - ((and (= t1-tu t2-tu) - (shape-test? t1) - (not (shape-test? t2)) - (negate-test? t2)) - #t) - ((and (= t1-tu t2-tu) - (not (shape-test? t1)) - (negate-test? t1) - (shape-test? t2)) - #f) - ((and (= t1-tu t2-tu) - (or (equal? (test-used-set t1) (test-used-set t2)) - (>= (number-of-similar (test-used-set t1) - whole-list) - (number-of-similar (test-used-set t2) - whole-list)))) - #t) - (else #f)))))) - - ;;!(function number-of-similar - ;; (form (number-of-similar set ls) -> integer) - ;; (contract (list list) -> integer)) - ;; This function returns the number of tests that have a - ;; membership set similar to set. A membership set is the set of - ;; test-lists that have a similar tests as the test itself. - (define number-of-similar - (lambda (set ls) - (apply + (map (lambda (set2) (if (equal? set set2) 1 0)) - (map test-used-set ls))))) - - ;;!(function reorder-tests - ;; (form (reorder-tests2 test-list) -> test-list) - ;; (contract list -> list)) - ;; This function reorders one list of test structs. - (define reorder-tests - (lambda (test-list) - ;;(pretty-print test-list)(newline) - (insertion-sort test-list (make-test-order-func test-list)))) - - ;;!(function reorder-all-lists - ;; (form (reorder-all-lists2 rendered-list) -> list) - ;; (contract list -> list)) - ;; This function reorders all of the rendered-lists that have - ;; success-functions attached to them. - (define reorder-all-lists - (lambda (rendered-list) - (if (null? rendered-list) - '() - (let ((success-func (cdr (car rendered-list))) - (rot (reorder-tests (caar rendered-list)))) - ;(pretty-print rot)(newline) - (cons (cons rot success-func) - (reorder-all-lists (cdr rendered-list))))))) - ) diff --git a/collects/mzlib/private/match/simplify-patterns.ss b/collects/mzlib/private/match/simplify-patterns.ss deleted file mode 100644 index 82bd11a71f..0000000000 --- a/collects/mzlib/private/match/simplify-patterns.ss +++ /dev/null @@ -1,190 +0,0 @@ -(module simplify-patterns mzscheme - - (require syntax/stx) - - (require scheme/list) - - (require "match-error.ss" - "match-helper.ss" - "test-structure.scm" - "coupling-and-binding.scm" - "update-counts.scm" - "update-binding-counts.scm" - "reorder-tests.scm" - "match-expander-struct.ss" - "render-helpers.ss" - "observe-step.ss") - - (require "render-sigs.ss") - - (require-for-syntax "match-helper.ss" - "match-expander-struct.ss" - "test-no-order.ss") - - (require-for-template mzscheme - "match-error.ss" - "test-no-order.ss" - "match-helper.ss") - - - - (provide simplify match-...-nesting) - - (define match-...-nesting (make-parameter 0)) - - - ;; simplifies patterns by removing syntactic sugar and expanding match-expanders - ;; simplify : syntax certifier-> syntax - (define (simplify stx cert) - - - ;; convert and check sub patterns for hash-table patterns - (define (convert-hash-table-pat pat) - (syntax-case pat () - [(p1 p2) #`(#,(simplify/i #'p1) #,(simplify/i #'p2))] - [i (and (identifier? #'i) (not (stx-dot-dot-k? #'i))) #'(var i)] - [_ (match:syntax-err pat "hash table subpattern must contain either two patterns or an identifier")])) - - ;; simple one-arg version, just passes the cert along - (define (simplify/i stx) (simplify stx cert)) - - (syntax-case* - stx - (_ list quote quasiquote vector box ? app and or not struct set! var - list-rest get! ... ___ unquote unquote-splicing cons - list-no-order hash-table regexp pregexp cons) stx-equal? - - ;; expand match-expanders - ;; this doesn't work because we need to keep the certifier around - [(expander args ...) - (and (identifier? #'expander) - (match-expander? (syntax-local-value (cert #'expander) (lambda () #f)))) - (let* ([expander (syntax-local-value (cert #'expander))] - [transformer (match-expander-plt-match-xform expander)]) - (unless transformer - (match:syntax-err #'expander - "This expander only works with the match.ss library.")) - (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))]) - (observe-step stx mstx mresult result) - (simplify result cert*)))] - - ;; label variable patterns - [id - (and (pattern-var? #'id) (not (stx-dot-dot-k? #'id))) - #'(var id)] - - ;; match the empty list - ['() (syntax/loc stx (list))] - - ;; other quoted data is untransformed - [(quote data) stx] - - ;; transform quasi-patterns into regular patterns - [`quasi-pat (simplify/i (parse-quasi #'quasi-pat))] - - ;; predicate patterns with binders are redundant with and patterns - [(? pred pat . pats) (simplify/i (syntax/loc stx (and (? pred) pat . pats)))] - [(? pred) (quasisyntax/loc stx (? #,(cert #'pred)))] - [(? . anything) - (match:syntax-err - stx - (if (null? (syntax-e #'anything)) - "a predicate pattern must have a predicate following the ?" - "syntax error in predicate pattern"))] - - ;; regexp patterns - FIXME: abstract here - [(regexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (regexp-match re x))))))] - [(pregexp re) (simplify/i (syntax/loc stx (and (? string?) (? (lambda (x) (pregexp-match-with-error re x))))))] - [(regexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (regexp-match re x)) pat))))] - [(pregexp re pat) (simplify/i (syntax/loc stx (and (? string?) (app (lambda (x) (pregexp-match-with-error re x)) pat))))] - [(regexp . re) (match:syntax-err stx "regexp pattern must have one or two subpatterns")] - [(pregexp . re) (match:syntax-err stx "pregexp pattern must have one or two subpatterns")] - - - ;; cons is just list-rest with 2 arguments - [(cons p1 p2) (simplify/i (syntax/loc stx (list-rest p1 p2)))] - [(cons . rest) (match:syntax-err stx "cons pattern must have exactly two subpatterns")] - - ;; aggregates - - [(kw pats ... last ddk) - (and (stx-dot-dot-k? #'ddk) - (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not))) - (with-syntax ([(pats* ...) (append (syntax-map simplify/i #'(pats ...)) - (parameterize ([match-...-nesting (add1 (match-...-nesting))]) - (list (simplify/i #'last))))]) - #;(printf "kw: ~a~n" (syntax-object->datum stx)) - (quasisyntax/loc stx (kw pats* ... ddk))) - #; - (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))] - [last* (parameterize ([match-...-nesting (add1 (match-...-nesting))]) - (simplify/i #'last))]) - (syntax/loc stx (kw pats* ... last* ddk)))] - [(kw pats ...) - (memq (syntax-e #'kw) '(list vector list-rest list-no-order and or not)) - (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))]) - (syntax/loc stx (kw pats* ...)))] - [(kw pats ... . rest) - (not (null? (syntax-e #'rest))) - (match:syntax-err stx (format "~a pattern must have a proper list of subpatterns" (syntax-e #'kw)))] - - ;; hash table patterns have their own syntax - [(hash-table pats ... ooo) - (stx-dot-dot-k? #'ooo) - (with-syntax - ([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))]) - (syntax/loc stx (hash-table pats* ... ooo)))] - [(hash-table pats ...) - (with-syntax - ([(pats* ...) (syntax-map convert-hash-table-pat #'(pats ...))]) - (syntax/loc stx (hash-table pats* ...)))] - [(hash-table . rest) (match:syntax-err stx "syntax error in hash table pattern")] - - ;; struct patterns - [(struct st (pats ...)) (with-syntax ([(pats* ...) (syntax-map simplify/i #'(pats ...))] - [st* (cert #'st)]) - (syntax/loc stx (struct st* (pats* ...))))] - [(struct . rest) - (match:syntax-err - stx - (if (null? (syntax-e #'rest)) - (format "~a~n~a~n~a" - "a structure pattern must have the name " - "of a defined structure followed by a list of patterns " - "to match each field of that structure") - "syntax error in structure pattern"))] - - [(box pat) (quasisyntax/loc stx (box #,(simplify/i #'pat)))] - [(box . rest) (match:syntax-err stx "syntax error in box pattern")] - - [(app e pat) (quasisyntax/loc stx (app #,(cert #'e) #,(simplify/i #'pat)))] - [(app . rest) (match:syntax-err stx "syntax error in app pattern")] - - [(set! id) - (identifier? #'id) - stx] - [(set! . rest) (match:syntax-err stx "set! pattern must have one identifier")] - - [(get! id) - (identifier? #'id) - stx] - [(get! . rest) (match:syntax-err stx "get! pattern must have one identifier")] - - [(var id) - (identifier? #'id) - stx] - [(var . rest) - (match:syntax-err stx "var pattern must have one identifier")] - - [__ stx]) - - - ) - - - ) diff --git a/collects/mzlib/private/match/struct-helper.scm b/collects/mzlib/private/match/struct-helper.scm deleted file mode 100644 index 6455147743..0000000000 --- a/collects/mzlib/private/match/struct-helper.scm +++ /dev/null @@ -1,235 +0,0 @@ -(module struct-helper mzscheme - (require mzlib/list) - (require-for-template mzscheme) - (provide (all-defined)) - - (define-struct field-decl (field ref mut posn immutable? auto?) (make-inspector)) - - (define (sym+ . items) - (define (->string x) - (cond [(string? x) x] - [(symbol? x) (symbol->string x)] - [(identifier? x) (symbol->string (syntax-e x))])) - (string->symbol (apply string-append (map ->string items)))) - - (define (identifier/tf? stx) - (or (identifier? stx) - (not stx) - (eq? (syntax-e stx) #t) - (eq? (syntax-e stx) #f))) - - (define (id/tf stx stx2) - (cond [(identifier? stx) - stx] - [(eq? (syntax-e stx) #t) - stx2] - [else #f])) - - (define (mk-parse-field-decl name-id) - (define (parse-field-decl stx) - (syntax-case stx () - [(field (flag ...) ref mut) - (and (identifier? #'field) - (identifier/tf? #'ref) - (identifier/tf? #'mut) - (andmap identifier? (syntax->list #'(flag ...)))) - (let ((flags (syntax-object->datum #'(flag ...)))) - (make-field-decl - (id/tf #'field #f) - (id/tf #'ref (datum->syntax-object name-id (sym+ name-id '- #'field))) - (id/tf #'mut (datum->syntax-object name-id (sym+ 'set- name-id '- #'field '!))) - #f - (memq 'immutable flags) - (memq 'auto flags)))] - [(field (flag ...) ref) - (parse-field-decl #'(field (flag ...) ref #t))] - [(field (flag ...)) - (parse-field-decl - #`(field - (flag ...) - #t - #t))] - [field - (identifier? #'field) - (parse-field-decl - #`(field () #t #t))])) - (lambda (stx) - (let ((r (parse-field-decl stx))) - #;(printf "parse-field-decl returned ~s~n" r) - r))) - - (define-struct decl:super (super struct:super)) - (define-struct decl:auto (value)) - (define-struct decl:property (key value)) - (define-struct decl:inspector (value)) - (define-struct decl:procedure-field (field)) - (define-struct decl:procedure (value)) - (define-struct decl:guard (value)) - (define-struct decl:option (value)) - - (define (fetch-struct:super type) - (let ((struct-info (syntax-local-value type))) - (car struct-info))) - - (define (parse-decl stx) - (syntax-case stx (super struct:super - auto-value property inspector transparent - procedure procedure-field guard - omit-define-values - omit-static-info - clone - replace - ) - [(super type) - (identifier? #'type) - (make-decl:super #'type (fetch-struct:super #'type))] - [(struct:super value) - (make-decl:super #f #'value)] - [(auto-value value) - (make-decl:auto #'value)] - [(property key value) - (make-decl:property #'key #'value)] - [(inspector value) - (make-decl:inspector #'value)] - [transparent - (make-decl:inspector #'(make-inspector))] - [(procedure proc) - (make-decl:procedure #'proc)] - [(procedure-field field) - (identifier? #'field) - (make-decl:procedure-field #'field)] - [(guard proc) - (make-decl:guard #'proc)] - [omit-define-values - (make-decl:option 'omit-define-values)] - [omit-static-info - (make-decl:option 'omit-static-info)] - [clone - (make-decl:option 'include-clone)] - [replace - (make-decl:option 'include-replace)])) - - (define-struct info (type super auto-k auto-v - props insp proc-spec imm-k-list guard - ref-fields ref-posns ref-names - mut-fields mut-posns mut-names - options fdecls)) - (define (make-null-info type) - (make-info type #f 0 #f - '() #f #f '() #f - '() '() '() - '() '() '() - '() '())) - (define (create-info type decls field-decls) - (let ((info (make-null-info type))) - (let loop ((fdecls field-decls) (posn 0) (first-auto #f)) - (if (pair? fdecls) - (let ((fdecl (car fdecls))) - (set-field-decl-posn! fdecl posn) - (when (and first-auto (not (field-decl-auto? fdecl))) - (raise-syntax-error 'define-struct* - "non-auto field came after auto field" - (field-decl-field fdecl))) - (when (field-decl-ref fdecl) - (set-info-ref-fields! info - (cons (field-decl-field fdecl) (info-ref-fields info))) - (set-info-ref-posns! info - (cons posn (info-ref-posns info))) - (set-info-ref-names! info - (cons (field-decl-ref fdecl) (info-ref-names info)))) - (when (field-decl-mut fdecl) - (set-info-mut-fields! info - (cons (field-decl-field fdecl) (info-mut-fields info))) - (set-info-mut-posns! info - (cons posn (info-mut-posns info))) - (set-info-mut-names! info - (cons (field-decl-mut fdecl) (info-mut-names info)))) - (loop (cdr fdecls) - (add1 posn) - (or first-auto (if (field-decl-auto? fdecl) posn #f)))) - (begin (set-info-auto-k! info - (if first-auto (- posn first-auto) 0))))) - (set-info-ref-fields! info (reverse (info-ref-fields info))) - (set-info-ref-posns! info (reverse (info-ref-posns info))) - (set-info-ref-names! info (reverse (info-ref-names info))) - (set-info-mut-fields! info (reverse (info-mut-fields info))) - (set-info-mut-posns! info (reverse (info-mut-posns info))) - (set-info-mut-names! info (reverse (info-mut-names info))) - (set-info-fdecls! info field-decls) - (for-each - (lambda (decl) - (cond [(decl:super? decl) (set-info-super! info decl)] - [(decl:auto? decl) (set-info-auto-v! info (decl:auto-value decl))] - [(decl:property? decl) - (set-info-props! info (cons (cons (decl:property-key decl) - (decl:property-value decl)) - (info-props info)))] - [(decl:inspector? decl) - (set-info-insp! info (decl:inspector-value decl))] - [(decl:procedure? decl) - (set-info-proc-spec! info (decl:procedure-value decl))] - [(decl:procedure-field? decl) - (set-info-proc-spec! - info - (let loop ((fields (map field-decl-field field-decls)) (i 0)) - (cond - [(null? fields) - (raise-syntax-error 'define-struct* - "procedure-field not in field set" - (decl:procedure-field-field decl))] - [(module-identifier=? (decl:procedure-field-field decl) - (car fields)) - i] - [else (loop (cdr fields) (add1 i))])))] - [(decl:guard? decl) - (set-info-guard! info (decl:guard-value decl))] - [(decl:option? decl) - (set-info-options! info (cons (decl:option-value decl) - (info-options info)))] - )) - decls) - (when (and (info-include-replacers? info) (pair? (info-auto-fields info))) - (error 'define-struct* "cannot define replacers with auto-fields")) - info)) - - (define (info-init-fields info) - (filter (lambda (fdecl) (not (field-decl-auto? fdecl))) - (info-fdecls info))) - (define (info-auto-fields info) - (filter (lambda (fdecl) (field-decl-auto? fdecl)) - (info-fdecls info))) - - (define (info-include-define-values? info) - (not (memq 'omit-define-values (info-options info)))) - - (define (info-include-static-info? info) - (not (memq 'omit-static-info (info-options info)))) - (define (info-include-replacers? info) - (memq 'include-replace (info-options info))) - (define (info-include-clone? info) - (memq 'include-clone (info-options info))) - - (define (info-include-x-ref? info) - #f) - (define (info-include-x-set!? info) - #f) - - - (define (info-name:struct-record info) - (let ((type (info-type info))) - (datum->syntax-object type (sym+ 'struct: type)))) - (define (info-name:constructor info) - (let ((type (info-type info))) - (datum->syntax-object type (sym+ 'make- type)))) - (define (info-name:predicate info) - (let ((type (info-type info))) - (datum->syntax-object type (sym+ type '?)))) - (define (info-defined-names info) - (let ((type (info-type info))) - (append (list (info-name:struct-record info) - (info-name:constructor info) - (info-name:predicate info)) - (info-ref-names info) - (info-mut-names info)))) - - ) diff --git a/collects/mzlib/private/match/syntax-utils.ss b/collects/mzlib/private/match/syntax-utils.ss deleted file mode 100644 index 651146cf61..0000000000 --- a/collects/mzlib/private/match/syntax-utils.ss +++ /dev/null @@ -1,45 +0,0 @@ -(module syntax-utils mzscheme - ;; Useful utilities on syntax objects - - (provide (all-defined)) - - ;;! (function stx-length - ;; (form (syntax-length syntax-obj) -> int) - ;; (contract syntax-object -> int) - ;; (example (syntax-length (syntax iraq war idiocy)) -> 3)) - ;; Returns the length of the top-level syntax list. - (define (stx-length stx) (length (syntax->list stx))) - - ;;! (function stx-? - ;; (form (stx? test val) -> bool) - ;; (contract ((any -> bool) syntax-object) -> bool) - ;; (example (stx-? number? (syntax 4)) -> #t)) - ;; Applies predicate test to the syntax object val and returns the resulting - ;; boolean value. - (define (stx-? test val) (test (syntax-object->datum val))) - - ;;!(function stx-equal? - ;; (form (stx-equal? a b) -> bool) - ;; (contract (syntax-object syntax-object) -> bool) - ;; (example (stx-equal? (syntax 5) (syntax 5)) -> #t)) - ;; Check the equality of two syntax objects by after applying - ;; syntax-object->datum to the objects first. Checks equaltiy of - ;; syntax objects after they have had all syntax data stripped away. - (define (stx-equal? a b) - (equal? (syntax-object->datum a) - (syntax-object->datum b))) - - ;;!(function get-exp-var - ;; (form (get-exp-var) -> syntax) - ;; (contract () -> syntax) - ;; (example (get-exp-var) -> (syntax exp754))) - ;; This function just produces unique identifiers for expressions. - (define (get-exp-var) #`#,(gensym 'exp)) - - - ;; syntax-map : (stx -> b) stx-list -> listof[b] - ;; maps a function over a syntax object that represents a list - (define (syntax-map f stx-l) - (map f (syntax->list stx-l))) - - ) diff --git a/collects/mzlib/private/match/tag-negate-tests.scm b/collects/mzlib/private/match/tag-negate-tests.scm deleted file mode 100644 index 910ab01f64..0000000000 --- a/collects/mzlib/private/match/tag-negate-tests.scm +++ /dev/null @@ -1,103 +0,0 @@ -(module tag-negate-tests mzscheme - (provide tag-negate-tests) - (require "test-structure.scm") - - (define (tag-neg-test ls target-set) - (easy-tag ls #f target-set)) - - (define (easy-tag ls last-shape target-set) - (cond ((null? ls) #f) - ((let ((tst (car ls))) - (and ;(not (action-test? tst)) - (not (or (shape-test? tst) (action-test? tst))) - (equal? target-set (test-used-set-neg tst)))) - (begin - (when (and last-shape (not (shape-test? (car ls)))) - (set-test-closest-shape-tst! (car ls) last-shape) - (set-test-used-set! (car ls) last-shape) - (set-test-times-used! (car ls) (length last-shape))) - #t)) - ((shape-test? (car ls)) - (easy-tag (cdr ls) (test-used-set (car ls)) target-set)) - (else - (easy-tag (cdr ls) last-shape target-set)))) - - (define (tag-negate-tests ls-of-ls) - (letrec ((gen-target-set-help - (lambda (init length) - (if (zero? length) - '() - (cons init - (gen-target-set-help (add1 init) - (sub1 length)))))) - (gen-target-set - (lambda (length) - (gen-target-set-help 2 length))) - (tag-help - (lambda (ls target-set) - (if (null? target-set) - '() - (begin - (tag-neg-test (car ls) - (reverse target-set)) - (tag-help - (cdr ls) - (cdr target-set))))))) - (tag-help (map car ls-of-ls) (gen-target-set (sub1 (length ls-of-ls)))))) - - - ; (define (move-negates-to-tags ls-of-ls) - ; (map (lambda (l) (cons (move-neg-to-tag (car l)) - ; (cdr l))) - ; ls-of-ls)) - - - ; (define (move-neg-to-tag ls) - ; (let-values (((list-without-neg-tests neg-tests) - ; (let loop ((l ls) - ; (ntsf '())) - ; (cond ((null? l) (values '() ntsf)) - ; ((negate-test? (car l)) - ; (loop (cdr l) (append ntsf (list (car l))))) - ; (else - ; (let-values (((lwnt ntsf) (loop (cdr l) ntsf))) - ; (values (cons (car l) lwnt) - ; ntsf))))))) - ; ;(write 'lwnt--)(pretty-print list-without-neg-tests) - ; ;(write 'neg-test)(pretty-print neg-tests) - ; (letrec ((insert-negtest - ; (lambda (t-list neg-test) - ; (cond ((null? t-list) - ; '()) - ; ((and (equal? (test-used-set (car t-list)) - ; (test-closest-shape-tst neg-test)) - ; (or (null? (cdr t-list)) - ; (not (equal? (test-used-set (cadr t-list)) - ; (test-closest-shape-tst neg-test))))) - ; (cons (car t-list) - ; (cons neg-test - ; (cdr t-list)))) - ; ; ((equal? (test-tst (car t-list)) - ; ; (test-closest-shape-tst neg-test)) - ; ; (cons (car t-list) - ; ; (cons neg-test - ; ; (cdr t-list)))) - ; (else - ; (cons (car t-list) - ; (insert-negtest (cdr t-list) - ; neg-test))))))) - ; (let loop2 ((t-list list-without-neg-tests) - ; (ntst neg-tests)) - ; ;(write 't-list)(pretty-print t-list) - ; ;(write 'ntst ) (pretty-print ntst) - ; ;(write 'insert) (pretty-print (insert-negtest t-list (car ntst)) ) - ; (cond ((null? ntst) t-list) - ; (else (insert-negtest t-list (car ntst)))))))) - ; ; (cond ((null? ntst) - ; ; t-list) - ; ; (loop2 (insert-negtest t-list (car ntst)) - ; ; (cdr ntst))))))) - - - - ) diff --git a/collects/mzlib/private/match/test-no-order.ss b/collects/mzlib/private/match/test-no-order.ss deleted file mode 100644 index 2929d9e89b..0000000000 --- a/collects/mzlib/private/match/test-no-order.ss +++ /dev/null @@ -1,39 +0,0 @@ -(module test-no-order mzscheme - (require mzlib/list) - - (provide match:test-no-order) - - ;;!(function match:test-no-order - ;; (form (match:test-no-order tests l last-test ddk-num) - ;; -> - ;; bool) - ;; (contract (list list test integer) -> bool)) - ;; This is a recursive depth first search for a sequence of - ;; items in list l which will satisfy all of the tests in list - ;; tests. This is used for list-no-order and hash-table patterns. - ;; This function also handles ddk patterns by passing it the last - ;; test before the ddk and the value of k. - (define (match:test-no-order tests l last-test ddk-num) - (define (handle-last-test test l) - (and (>= (length l) ddk-num) - (andmap test l))) - (define (dep-first-test head rest tests) - (cond [(null? tests) - (if last-test - (handle-last-test last-test (cons head rest)) - #f)] - [(null? rest) - (if last-test - (and (= 0 ddk-num) - (= 1 (length tests)) - ((car tests) head)) - (and (= 1 (length tests)) - ((car tests) head)))] - [else (and (pair? tests) - ((car tests) head) - (match:test-no-order (cdr tests) - rest - last-test - ddk-num))])) - (printf "~s\n" (list tests l last-test ddk-num)) - (ormap (lambda (elem) (dep-first-test elem (remove elem l) tests)) l))) diff --git a/collects/mzlib/private/match/test-structure.scm b/collects/mzlib/private/match/test-structure.scm deleted file mode 100644 index 49c18b536a..0000000000 --- a/collects/mzlib/private/match/test-structure.scm +++ /dev/null @@ -1,120 +0,0 @@ -;; This library is used by match.ss - -(module test-structure mzscheme - (provide (all-defined)) - - - - ;; This is the major data structure of the compiler. It holds a - ;; great deal of information. This structure represents a - ;; partially compiled match test. This test is the basic unit of - ;; compilation. The order of these tests greatly affects the size - ;; of the final compiled match expression. it also affects the - ;; amount of time it takes to compile a match expression. - ;; the fields: - ;; tst - an S-exp of the test such as (equal exp 5). It can also - ;; be a name of a test that isn't meant to be compared to other - ;; tests such as 'list-ddk-pat. - ;; comp - a function that takes a success-function, a fail-function and - ;; a list of let bindings - ;; shape - a boolean that is true if the test tests the shape or type - ;; of the data rather than the value of the data - ;; times-used - the number of clauses that use this test. In reality - ;; the number of clauses in which this test will eliminate - ;; tests - ;; used-set - a list of numbers which designate the test-lists that - ;; in which this test will eliminate tests - ;; bind-exp-stx - the syntax of the actual expression that is being tested - ;; by this test ex. (syntax (car (cdr x))) - ;; bind-exp - the s-exp that is being tested by this test, - ;; easily obtained by taking the syntax-object->datum - ;; of bind-exp-stx - ;; bind-count - is the number of times in the bind-exp is found in the - ;; test list in which this test is a member - ;; used-set-neg - ??? - ;; closest-shape-tst - ??? - ;; equal-set - ??? - (define-struct test (tst - comp - shape - times-used - used-set - bind-exp-stx - bind-exp - bind-count - used-set-neg - closest-shape-tst - equal-set) - #f) - - ;;!(function make-shape-test - ;; (form (make-shape-test test exp comp) -> test-struct) - ;; (contract (s-exp syntax (((list list -> syntax) - ;; (list list -> syntax) list) - ;; -> - ;; (list list -> syntax))) - ;; -> test)) - ;; This function is essentially a constructor for a test struct. - ;; This constructor makes a "shape" test - test that tests for type - ;; rather than value. - ;; Arguments: - ;; test - s-exp of the test - ;; exp - the syntax of the expression being tested - ;; comp - the compilation function which will finish the compilation - ;; after tests have been reordered - (define (make-shape-test test exp comp) - (make-test test comp #t 0 '() exp (syntax-object->datum exp) 1 '() #f '())) - - ;;!(function make-reg-test - ;; (form (make-shape-test test exp comp) -> test-struct) - ;; (contract (s-exp syntax (((list list -> syntax) - ;; (list list -> syntax) list) - ;; -> (list list -> syntax))) - ;; -> test)) - ;; This function is essentially a constructor for a test struct. - ;; This constructor makes a "regular" test - ;; Arguments: - ;; test - s-exp of the test - ;; exp - the syntax of the expression being tested - ;; comp - the compilation function which will finish the compilation - ;; after tests have been reordered - (define (make-reg-test test exp comp) - (make-test test comp #f 0 '() exp (syntax-object->datum exp) 1 '() #f '())) - - ;;!(function make-act-test - ;; (form (make-shape-test test exp comp) -> test-struct) - ;; (contract (s-exp syntax (((list list -> syntax) - ;; (list list -> syntax) list) -> (list list -> syntax))) - ;; -> test)) - ;; This function is essentially a constructor for a test struct. - ;; This constructor makes an "action" test - an action test is not - ;; neccessarily a test so to speak but rather an action that needs to be - ;; taken in order to verify that a certain expression matches a pattern. - ;; A good example of this is the binding of a pattern variable. - ;; Arguments: - ;; act-name - - ;; exp - the syntax of the expression being tested - ;; comp - the compilation function which will finish the compilation - ;; after tests have been reordered - (define (make-act act-name exp comp) - (make-test act-name comp #f -1 '() exp (syntax-object->datum exp) 1 '() #f '())) - - ;;!(function action-test? - ;; (form (action-test? test) -> bool) - ;; (contract test -> bool)) - ;; a predicate that returns true if a test is an action test - (define (action-test? test) - (= -1 (test-times-used test))) - - ;;!(function shape-test? - ;; (form (shape-test? test) -> bool) - ;; (contract test -> bool)) - ;; a predicate that returns true if a test is an shape test - (define (shape-test? test) - (test-shape test)) - - - (define (negate-test? test) - (test-closest-shape-tst test)) - - ) diff --git a/collects/mzlib/private/match/update-binding-counts.scm b/collects/mzlib/private/match/update-binding-counts.scm deleted file mode 100644 index e59525759d..0000000000 --- a/collects/mzlib/private/match/update-binding-counts.scm +++ /dev/null @@ -1,109 +0,0 @@ -;; This library is used by match.ss -(module update-binding-counts mzscheme - (provide update-binding-counts update-binding-count) - - (require "test-structure.scm") - (require mzlib/etc) - - - ;;!(function update-binding-count - ;; (form (update-binding-count render-list) -> list) - ;; (contract list -> list)) - ;; This function is normally executed for its side effect of - ;; setting the count for the number of times an expression used in - ;; a test if found in the rest of the list of tests. This does - ;; not only count occurrances of the exp in other tests but - ;; whether the expression is also a sub expression in the other tests. - ;; Arg: - ;; render-list - a list of test structs - (define update-binding-count - (lambda (render-list) - (define (inc-bind-count test) - (set-test-bind-count! test - (add1 (test-bind-count test)))) - (if (null? render-list) - '() - (let ((cur-test (car render-list))) - (update-binding-count - (let loop ((l (cdr render-list))) - (cond ((null? l) '()) - ((>= (test-bind-count cur-test) 2) l) - ((and (valid-for-let-binding (test-bind-exp cur-test)) - (equal? (test-bind-exp cur-test) - (test-bind-exp (car l)))) - (begin - (inc-bind-count cur-test) - (loop (cdr l)))) - ((sub-exp-contains (test-bind-exp cur-test) - (test-bind-exp (car l))) - (begin - (inc-bind-count cur-test) - (cons (car l) (loop (cdr l))))) - (else (cons (car l) (loop (cdr l))))))))))) - - ;;!(function valid-for-let-binding - ;; (form (valid-for-let-binding exp) -> bool) - ;; (contract s-exp -> bool) - ;; (example (valid-for-let-binding 'x) -> #f)) - ;; This function is a predicate that determins if an expression - ;; should be considered for let binding. - (define valid-for-let-binding - (lambda (exp) - ;; it must be a pair - ;; the index must be an integer - #;(match exp - (('vector-ref _ n) (number? n)) - ((? pair?) #t) - (_ #f)) - ;; the following is expanded fromt the above match expression - (let ((x exp)) - (if (pair? x) - (if (and (equal? (car x) 'vector-ref) - (pair? (cdr x)) - (pair? (cdr (cdr x))) - (null? (cdr (cdr (cdr x))))) - ((lambda (n) (number? n)) (car (cdr (cdr x)))) - ((lambda () #t))) - ((lambda () #f)))))) - - ;;!(function sub-exp-contains - ;; (form (sub-exp-contains exp1 exp2) -> bool) - ;; (contract (s-exp s-exp) -> bool) - ;; (example (sub-exp-contains '(cdr x) '(car (cdr x))) -> #t)) - ;; This function returns true if exp2 contains a sub-expression - ;; that is equal? to exp1. For this function to work the subexp - ;; must always be in the second position in a exp. This is a - ;; convention that is followed throughout the match program. - (define sub-exp-contains - (lambda (exp1 exp2) - #;(match exp2 - (() #f) - ((_ sub-exp _ ...) - (if (and (valid-for-let-binding sub-exp) - (equal? sub-exp exp1)) - #t - (sub-exp-contains exp1 sub-exp))) - (_ #f)) - ;; The following was expanded from the above match expression - (let ((x exp2)) - (if (null? x) - ((lambda () #f)) - (if (and (pair? x) (pair? (cdr x)) (list? (cdr (cdr x)))) - ((lambda (sub-exp) - (if (and (pair? sub-exp) - (equal? sub-exp exp1)) - #t - (sub-exp-contains exp1 sub-exp))) - (car (cdr x))) - ((lambda () #f))))))) - - ;;!(function update-binding-counts - ;; (form (update-binding-counts render-lists) -> list) - ;; (contract list -> list)) - ;; This function calls update-binding-count for each render list - ;; in the list of render lists. This is used mainly for its side - ;; affects. The result is of no consequence. - (define update-binding-counts - (lambda (render-lists) - (map (compose update-binding-count car) render-lists))) - ) diff --git a/collects/mzlib/private/match/update-counts.scm b/collects/mzlib/private/match/update-counts.scm deleted file mode 100644 index 0c7a862920..0000000000 --- a/collects/mzlib/private/match/update-counts.scm +++ /dev/null @@ -1,148 +0,0 @@ -;; This library is used by match.ss -;; This requires the test data structure. - -(module update-counts mzscheme - (provide update-counts) - - (require "test-structure.scm" - "match-helper.ss" - mzlib/etc - mzlib/list) - - ;;!(function test-filter - ;; (form (test-filter test-list) -> test-list) - ;; (contract list -> list)) - ;; This function filters out tests that do not need to be to have - ;; their counts updated for reordering purposes. These are the - ;; more complex patterns such as or-patterns or ddk patterns. - - (define (test-filter tlist) - (filter (lambda (t) (not (= -1 (test-times-used t)))) tlist)) - - - ;; !(function inverse-in - ;; (form (inverse-in test test-list) -> bool) - ;; (contract (s-exp list) -> bool)) - ;; This function checks to see if any of the members of the test-list - ;; would be eliminated by the function if the test was in the test so far - ;; list. This is the opposite of what the in function does. - (define (inverse-in test test-list) - (or (pos-inverse-in test test-list) - (neg-inverse-in test test-list))) - - (define (pos-inverse-in test test-list) - (let ([test-with-implied (cons test (implied test))]) - (ormap (lambda (t) (in t test-with-implied)) - test-list))) - - - (define (neg-inverse-in test test-list) - (let ([test-with-implied (cons test (implied test))]) - (ormap (lambda (t) (in `(not ,t) test-with-implied)) - test-list))) - - - (define (logical-member item lst) - (ormap (lambda (cur) - (logical-equal? item cur)) - lst)) - - (define (logical-equal? a b) - (or (equal? a b) - (and - ;; error checking - (list? a) - (list? b) - (list? (cdr a)) - (list? (cdr b)) - (null? (cddr a)) - (null? (cddr b)) - ;; end error checking - (eq? (car a) 'list?) - (eq? (car b) 'null?) - (equal? (cadr a) (cadr b))))) - - ;; truncate-list : int listof[int] -> listof[int] - ;; truncate-list-neg : int listof[int] -> listof[int] - ;; truncate-list removes all elements of a list after the element at least as large as p - ;; truncate-list-neg removes the found element as well - (define-values (truncate-list truncate-list-neg) - (let ([mk (lambda (pos-f) - (define (f p l) - (cond [(null? l) - '()] - [(>= p (car l)) - (pos-f p)] - [else - (cons (car l) - (f p (cdr l)))])) - f)]) - (values (mk list) (mk (lambda (x) '()))))) - - - - ;; update-count : test listof[test] int -> void - ;; This function updates the test-times-used and test-used-set - ;; fields of the test structs. These fields are essential to - ;; determining the order of the tests. - (define (update-count test tests-rest pos mem-table) - (let loop ([l tests-rest] - [p (add1 pos)]) - (if (null? l) - (hash-table-get mem-table (test-tst test) - (lambda () - (hash-table-put! - mem-table - (test-tst test) - (list (test-used-set test) - (test-used-set-neg test))))) - (let ([entry-pair - (hash-table-get mem-table (test-tst test) - (lambda () - (when (logical-member (test-tst test) (car l)) - (set-test-times-used! test (add1 (test-times-used test))) - (set-test-used-set! test (cons p (test-used-set test))) - (set-test-equal-set! test (cons p (test-equal-set test)))) - (when (neg-inverse-in (test-tst test) (car l)) - (set-test-used-set-neg! test (cons p (test-used-set-neg test)))) - (loop (cdr l) (add1 p))))]) - (when (and (list? entry-pair) (not (null? entry-pair))) - (let ([trun-used (truncate-list pos (car entry-pair))]) - (set-test-used-set! test trun-used) - (set-test-equal-set! test trun-used) - (set-test-times-used! test (length trun-used)) - (set-test-used-set-neg! test (truncate-list-neg pos (cadr entry-pair))))))))) - - - ;; update-counts : listof[(cons test any)] -> void - ;; This function essentially calls update-count on every test in - ;; all of the test lists. - (define (update-counts render-list) - (let* ([mem-table (make-hash-table 'equal)] - [test-master-list (map (compose test-filter car) render-list)] - [test-so-far-lists ;; horrible name - (map - (lambda (tl) (map test-tst (test-filter tl))) - test-master-list)]) - (let loop ([tml test-master-list] - [tsf test-so-far-lists] - [pos 1]) - (if (null? tml) - (void) - (begin - (for-each - (lambda (t) - (set-test-times-used! t 1) - (set-test-used-set! - t - (cons pos (test-used-set t))) - (set-test-equal-set! - t - (cons pos (test-equal-set t))) - (update-count t (cdr tsf) pos mem-table)) - (car tml)) - (loop (cdr tml) (cdr tsf) (add1 pos))))))) - ) - - - diff --git a/collects/scheme/match/compiler.ss b/collects/scheme/match/compiler.ss index d07523f194..14579c0edc 100644 --- a/collects/scheme/match/compiler.ss +++ b/collects/scheme/match/compiler.ss @@ -41,34 +41,29 @@ rows) esc)]) #`[(#,predicate-stx #,x) rhs])) + (define (compile-con-pat accs pred pat-acc) + (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 (pat-acc p1) ps) (Row-rhs row) (Row-unmatch row) (Row-vars-seen row))) + rows) + esc)]) + #`[(pred #,x) + (let ([tmps (accs #,x)] ...) + body)]))) (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)]))] + (compile-con-pat (list #'unbox) #'box? (compose list Box-p))] [(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)]))] + (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? + (lambda (p) (list (MPair-a p) (MPair-d p))))] [(eq? 'string k) (constant-pat #'string?)] [(eq? 'number k) (constant-pat #'number?)] [(eq? 'symbol k) (constant-pat #'symbol?)] @@ -78,6 +73,8 @@ [(eq? 'regexp k) (constant-pat #'regexp?)] [(eq? 'boolean k) (constant-pat #'boolean?)] [(eq? 'null k) (constant-pat #'null?)] + ;; vectors are handled specially + ;; 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)) @@ -110,21 +107,10 @@ (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)])))] + (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))) diff --git a/collects/scheme/match/parse-helper.ss b/collects/scheme/match/parse-helper.ss index c23bd62836..b7ecd75e9e 100644 --- a/collects/scheme/match/parse-helper.ss +++ b/collects/scheme/match/parse-helper.ss @@ -8,7 +8,95 @@ "compiler.ss" (only-in srfi/1 delete-duplicates)) -(provide ddk? parse-literal all-vars pattern-var? match:syntax-err match-expander-transform matchable?) +(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) + (cond [(eq? '_ (syntax-e x)) + (make-Dummy x)] + [(ddk? x) (raise-syntax-error 'match "incorrect use of ... in pattern" #'x)] + [else (make-Var x)])) + +;; stx : syntax of pattern, starting with quote +;; parse : the parse function +(define (parse-quote stx parse) + (syntax-case stx (quote) + [(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))] + [_ + (raise-syntax-error 'match "syntax error in quote pattern" stx)])) + +;; parse : the parse fn +;; p : the repeated pattern +;; dd : the ... stx +;; 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)))) + +;; stx : the syntax object for the whole pattern +;; cert : the certifier +;; parse : the pattern parser +;; struct-name : identifier +;; 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))] + [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))]) + ;; 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 (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)))))))) + +(define (trans-match pred transformer pat) + (make-And (list (make-Pred pred) (make-App transformer pat)))) ;; transform a match-expander application ;; parse/cert : stx certifier -> pattern @@ -30,6 +118,7 @@ [cert* (lambda (id) (certifier (cert id) #f introducer))]) (parse/cert result cert*)))) +;; can we pass this value to regexp-match? (define (matchable? e) (or (string? e) (bytes? e))) diff --git a/collects/scheme/match/parse-legacy.ss b/collects/scheme/match/parse-legacy.ss index bfff1639cb..a845db4e92 100644 --- a/collects/scheme/match/parse-legacy.ss +++ b/collects/scheme/match/parse-legacy.ss @@ -19,8 +19,6 @@ [(expander args ...) (and (identifier? #'expander) - ;; for debugging - (syntax-transforming?) (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")] @@ -44,34 +42,7 @@ (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 (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])]) - (make-Struct id pred (get-lineage (cert #'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)))))))] + (parse-struct stx cert parse #'s #'pats)] [(? p q1 qs ...) (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))] [(? p) @@ -80,47 +51,20 @@ (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))] + [(quote . rest) + (parse-quote stx parse)] [() (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))))] + (dd-parse parse #'p #'.. #'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)])] + (parse-id #'x)] [v (or (parse-literal (syntax-e #'v)) (raise-syntax-error 'match "syntax error in pattern" stx))])) diff --git a/collects/scheme/match/parse.ss b/collects/scheme/match/parse.ss index fddf182cd0..5234bf8430 100644 --- a/collects/scheme/match/parse.ss +++ b/collects/scheme/match/parse.ss @@ -13,12 +13,19 @@ (provide parse/cert) +(define (ht-pat-transform p) + (syntax-case p () + [(a b) #'(list a b)] + [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) + list-rest list-no-order hash-table quasiquote mcons list*) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) [(expander args ...) @@ -40,62 +47,36 @@ (let ([ps (map (compose make-Not parse) (syntax->list #'(p ...)))]) (make-And ps))] [(regexp r) - (make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (make-Pred #'values))))] + (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (make-Pred #'values))] [(regexp r p) - (make-And (list (make-Pred #'matchable?) (make-App #'(lambda (e) (regexp-match r e)) (parse #'p))))] + (trans-match #'matchable? #'(lambda (e) (regexp-match r e)) (parse #'p))] [(pregexp r) - (make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r - (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) - (make-And (list (make-Pred #'matchable?) (make-App (syntax/loc #'r - (lambda (e) (regexp-match (if (pregexp? r) - r - (pregexp r)) - e))) - (parse #'p))))] + (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 ...))) - (make-And (list (make-Pred #'vector?) (make-App #'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) (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)))))))] + (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 ... 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 ...)))))))] + (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) @@ -133,67 +114,22 @@ (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)))))] + (dd-parse parse #'p #'.. (syntax/loc stx (list . rest)))] [(list e es ...) (make-Pair (parse #'e) (parse (syntax/loc stx (list es ...))))] + [(list* . rest) + (parse (syntax/loc stx (list-rest . rest)))] [(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)))))] + (dd-parse parse #'p #'dd (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))] + [(mcons e1 e2) (make-MPair (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 (cond [(null? acc) acc] [(not (car acc)) (cdr acc)] [else acc])]) - (make-Struct id pred (get-lineage (cert #'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)))))))] + (parse-struct stx cert parse #'s #'pats)] [(? p q1 qs ...) (make-And (cons (make-Pred (cert #'p)) (map parse (syntax->list #'(q1 qs ...)))))] [(? p) @@ -202,27 +138,13 @@ (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))] + [(quasiquote . _) + (raise-syntax-error 'match "illegal use of quasiquote")] + [(quote . _) + (parse-quote stx parse)] [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)])] + (parse-id #'x)] [v (or (parse-literal (syntax-e #'v)) (raise-syntax-error 'match "syntax error in pattern" stx))])) diff --git a/collects/scheme/match/patterns.ss b/collects/scheme/match/patterns.ss index 904d5f5bff..90adc11cc9 100644 --- a/collects/scheme/match/patterns.ss +++ b/collects/scheme/match/patterns.ss @@ -43,6 +43,7 @@ (define-struct (VectorSeq Pat) (p count start) #:transparent) (define-struct (Pair CPat) (a d) #:transparent) +(define-struct (MPair CPat) (a d) #:transparent) (define-struct (Box CPat) (p) #:transparent) @@ -121,6 +122,7 @@ [(Box? p) 'box] [(Vector? p) 'vector] [(Pair? p) 'pair] + [(MPair? p) 'mpair] [(String? p) 'string] [(Symbol? p) 'symbol] [(Number? p) 'number] @@ -171,6 +173,8 @@ [(Atom? p) null] [(Pair? p) (merge (list (bound-vars (Pair-a p)) (bound-vars (Pair-d p))))] + [(MPair? p) + (merge (list (bound-vars (MPair-a p)) (bound-vars (MPair-d p))))] [(GSeq? p) (merge (cons (bound-vars (GSeq-tail p)) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 5891dd3eab..8c73784b78 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -7,7 +7,7 @@ string-constants/string-constant #;'#%more-scheme #;'#%qq-and-or - (lib "match-error.ss" "mzlib" "private" "match")) + (only-in scheme/match/patterns match:error)) ) @@ -20,7 +20,7 @@ (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss" string-constants/string-constant - (lib "match-error.ss" "mzlib" "private" "match") + (only-in scheme/match/patterns match:error) "tc-structs.ss") (require (for-syntax @@ -32,7 +32,7 @@ (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss" string-constants/string-constant - (lib "match-error.ss" "mzlib" "private" "match") + (only-in scheme/match/patterns match:error) "tc-structs.ss")) (define-for-syntax (initialize-others)