From bd93217061d4304ed840fb1106666fabcbf0a930 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 17 Sep 2007 02:27:05 +0000 Subject: [PATCH] refactored the contract system so that contracts do not depend on the class system, and now the class contracts are exported from class.ss svn: r7357 --- collects/help/help-desk.ss | 3 +- collects/mzlib/class.ss | 4 + collects/mzlib/contract.ss | 3 +- collects/mzlib/private/contract-arr-checks.ss | 198 ++ .../mzlib/private/contract-arr-obj-helpers.ss | 1121 +++++++++++ collects/mzlib/private/contract-arrow.ss | 1748 +---------------- collects/mzlib/private/contract-guts.ss | 5 +- collects/mzlib/private/contract-helpers.ss | 161 +- collects/mzlib/private/contract-object.ss | 429 ++++ collects/mzlib/private/contract.ss | 78 +- .../profj/libs/java/lang/Object-composite.ss | 4 +- collects/profj/to-scheme.ss | 12 +- collects/tests/mzscheme/contract-test.ss | 19 +- collects/texpict/mrpict.ss | 1 + 14 files changed, 1996 insertions(+), 1790 deletions(-) create mode 100644 collects/mzlib/private/contract-arr-checks.ss create mode 100644 collects/mzlib/private/contract-arr-obj-helpers.ss create mode 100644 collects/mzlib/private/contract-object.ss diff --git a/collects/help/help-desk.ss b/collects/help/help-desk.ss index 8a91cd6bb2..1182c134a2 100644 --- a/collects/help/help-desk.ss +++ b/collects/help/help-desk.ss @@ -8,7 +8,8 @@ "private/standard-urls.ss" "private/link.ss" - (lib "contract.ss")) + (lib "contract.ss") + (lib "class.ss")) (helpdesk-platform 'internal-browser-simple) diff --git a/collects/mzlib/class.ss b/collects/mzlib/class.ss index 536df91025..08dae8b48b 100644 --- a/collects/mzlib/class.ss +++ b/collects/mzlib/class.ss @@ -1,5 +1,9 @@ (module class mzscheme + ;; povide contracts for objects + (require "private/contract-object.ss") + (provide (all-from "private/contract-object.ss")) + ;; All of the implementation is actually in private/class-internal.ss, ;; which provides extra (private) functionality to contract.ss. (require "private/class-internal.ss") diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 8a8f09eb65..1b4c1c79fa 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -21,7 +21,8 @@ ;; from contract-guts.ss - (provide and/c + (provide any + and/c any/c none/c make-none/c diff --git a/collects/mzlib/private/contract-arr-checks.ss b/collects/mzlib/private/contract-arr-checks.ss new file mode 100644 index 0000000000..6f6e7bd48c --- /dev/null +++ b/collects/mzlib/private/contract-arr-checks.ss @@ -0,0 +1,198 @@ +(module contract-arr-checks mzscheme + (provide (all-defined)) + (require (lib "list.ss") + "contract-guts.ss") + + (define empty-case-lambda/c + (flat-named-contract '(case->) + (λ (x) (and (procedure? x) (null? (procedure-arity x)))))) + + ;; ---------------------------------------- + ;; Checks and error functions used in macro expansions + + ;; procedure-accepts-and-more? : procedure number -> boolean + ;; returns #t if val accepts dom-length arguments and + ;; any number of arguments more than dom-length. + ;; returns #f otherwise. + (define (procedure-accepts-and-more? val dom-length) + (let ([arity (procedure-arity val)]) + (cond + [(number? arity) #f] + [(arity-at-least? arity) + (<= (arity-at-least-value arity) dom-length)] + [else + (let ([min-at-least (let loop ([ars arity] + [acc #f]) + (cond + [(null? ars) acc] + [else (let ([ar (car ars)]) + (cond + [(arity-at-least? ar) + (if (and acc + (< acc (arity-at-least-value ar))) + (loop (cdr ars) acc) + (loop (cdr ars) (arity-at-least-value ar)))] + [(number? ar) + (loop (cdr ars) acc)]))]))]) + (and min-at-least + (begin + (let loop ([counts (sort (filter number? arity) >=)]) + (unless (null? counts) + (let ([count (car counts)]) + (cond + [(= (+ count 1) min-at-least) + (set! min-at-least count) + (loop (cdr counts))] + [(< count min-at-least) + (void)] + [else (loop (cdr counts))])))) + (<= min-at-least dom-length))))]))) + + (define (check->* f arity-count) + (unless (procedure? f) + (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) + (unless (procedure-arity-includes? f arity-count) + (error 'object-contract + "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" + arity-count + f))) + + (define (check->*/more f arity-count) + (unless (procedure? f) + (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) + (unless (procedure-accepts-and-more? f arity-count) + (error 'object-contract + "expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e" + arity-count + (if (= 1 arity-count) "" "s") + f))) + + + (define (check-pre-expr->pp/h val pre-expr src-info blame orig-str) + (unless pre-expr + (raise-contract-error val + src-info + blame + orig-str + "pre-condition expression failure"))) + + (define (check-post-expr->pp/h val post-expr src-info blame orig-str) + (unless post-expr + (raise-contract-error val + src-info + blame + orig-str + "post-condition expression failure"))) + + (define (check-procedure val dom-length src-info blame orig-str) + (unless (and (procedure? val) + (procedure-arity-includes? val dom-length)) + (raise-contract-error + val + src-info + blame + orig-str + "expected a procedure that accepts ~a arguments, given: ~e" + dom-length + val))) + + (define ((check-procedure? arity) val) + (and (procedure? val) + (procedure-arity-includes? val arity))) + + (define ((check-procedure/more? arity) val) + (and (procedure? val) + (procedure-accepts-and-more? val arity))) + + (define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) + (unless (procedure? val) + (raise-contract-error val + src-info + blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-arity-includes? val arity) + (raise-contract-error val + src-info + blame + orig-str + "expected a ~a of arity ~a (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) + + (define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str) + (unless (procedure? val) + (raise-contract-error val + src-info + blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-accepts-and-more? val arity) + (raise-contract-error val + src-info + blame + orig-str + "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) + + (define (check-procedure/more val dom-length src-info blame orig-str) + (unless (and (procedure? val) + (procedure-accepts-and-more? val dom-length)) + (raise-contract-error + val + src-info + blame + orig-str + "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" + dom-length + dom-length + val))) + + + (define (check-rng-procedure who rng-x arity) + (unless (and (procedure? rng-x) + (procedure-arity-includes? rng-x arity)) + (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e" + arity + rng-x))) + + (define (check-rng-procedure/more rng-mk-x arity) + (unless (and (procedure? rng-mk-x) + (procedure-accepts-and-more? rng-mk-x arity)) + (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e" + arity + rng-mk-x))) + + (define (check-rng-lengths results rng-contracts) + (unless (= (length results) (length rng-contracts)) + (error '->d* + "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" + (length results) (length rng-contracts)))) + + #| + + test cases for procedure-accepts-and-more? + + (and (procedure-accepts-and-more? (lambda (x . y) 1) 3) + (procedure-accepts-and-more? (lambda (x . y) 1) 2) + (procedure-accepts-and-more? (lambda (x . y) 1) 1) + (not (procedure-accepts-and-more? (lambda (x . y) 1) 0)) + + (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3) + (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2) + (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1) + (not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0)) + + (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2) + (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) + (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0))) + + |# +) \ No newline at end of file diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss new file mode 100644 index 0000000000..0edb99e4ec --- /dev/null +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -0,0 +1,1121 @@ +(module contract-arr-obj-helpers mzscheme + (require "contract-opt-guts.ss" + "contract-helpers.ss" + (lib "list.ss") + (lib "stx.ss" "syntax") + (lib "name.ss" "syntax")) + + (require-for-template mzscheme + "contract-guts.ss" + "contract-arr-checks.ss") + + (provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h + ->pp/h ->pp-rest/h + make-case->/proc + make-opt->/proc make-opt->*/proc) + + ;; make-/proc : boolean + ;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) + ;; syntax + ;; -> (syntax -> syntax) + (define (make-/proc method-proc? /h stx) + (let-values ([(arguments-check build-proj check-val first-order-check wrapper) + (/h method-proc? stx)]) + (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) + (with-syntax ([inner-check (check-val outer-args)] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(val-args body) (wrapper outer-args)]) + (with-syntax ([inner-lambda + (set-inferred-name-from + stx + (syntax/loc stx (lambda val-args body)))]) + (let ([inner-lambda + (syntax + (lambda (val) + inner-check + inner-lambda))]) + (with-syntax ([proj-code (build-proj outer-args inner-lambda)] + [first-order-check first-order-check]) + (arguments-check + outer-args + (syntax/loc stx + (make-proj-contract + name-id + (lambda (pos-blame neg-blame src-info orig-str) + proj-code) + first-order-check)))))))))) + + (define (make-case->/proc method-proc? stx inferred-name-stx) + (syntax-case stx () + + ;; if there are no cases, this contract should only accept the "empty" case-lambda. + [(_) (syntax empty-case-lambda/c)] + + ;; if there is only a single case, just skip it. + [(_ case) (syntax case)] + + [(_ cases ...) + (let-values ([(arguments-check build-projs check-val first-order-check wrapper) + (case->/h method-proc? stx (syntax->list (syntax (cases ...))))]) + (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) + (with-syntax ([(inner-check ...) (check-val outer-args)] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(body ...) (wrapper outer-args)]) + (with-syntax ([inner-lambda + (set-inferred-name-from + inferred-name-stx + (syntax/loc stx (case-lambda body ...)))]) + (let ([inner-lambda + (syntax + (lambda (val) + inner-check ... + inner-lambda))]) + (with-syntax ([proj-code (build-projs outer-args inner-lambda)] + [first-order-check first-order-check]) + (arguments-check + outer-args + (syntax/loc stx + (make-proj-contract + (apply build-compound-type-name 'case-> name-id) + (lambda (pos-blame neg-blame src-info orig-str) + proj-code) + first-order-check)))))))))])) + + (define (make-opt->/proc method-proc? stx) + (syntax-case stx (any) + [(_ (reqs ...) (opts ...) any) + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx)] + [(_ (reqs ...) (opts ...) res) + (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx)])) + + (define (make-opt->*/proc method-proc? stx inferred-name-stx) + (syntax-case stx (any) + [(_ (reqs ...) (opts ...) any) + (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] + [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] + [cses + (reverse + (let loop ([opt-vs (reverse opt-vs)]) + (cond + [(null? opt-vs) (list req-vs)] + [else (cons (append req-vs (reverse opt-vs)) + (loop (cdr opt-vs)))])))]) + (with-syntax ([(req-vs ...) req-vs] + [(opt-vs ...) opt-vs] + [((case-doms ...) ...) cses]) + (with-syntax ([expanded-case-> + (make-case->/proc + method-proc? + (syntax (case-> (-> case-doms ... any) ...)) + inferred-name-stx)]) + (syntax/loc stx + (let ([req-vs reqs] ... + [opt-vs opts] ...) + expanded-case->)))))] + [(_ (reqs ...) (opts ...) (ress ...)) + (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))] + [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] + [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] + [cses + (reverse + (let loop ([opt-vs (reverse opt-vs)]) + (cond + [(null? opt-vs) (list req-vs)] + [else (cons (append req-vs (reverse opt-vs)) + (loop (cdr opt-vs)))])))]) + (with-syntax ([(res-vs ...) res-vs] + [(req-vs ...) req-vs] + [(opt-vs ...) opt-vs] + [((case-doms ...) ...) cses]) + (with-syntax ([(single-case-result ...) + (let* ([ress-lst (syntax->list (syntax (ress ...)))] + [only-one? + (and (pair? ress-lst) + (null? (cdr ress-lst)))]) + (map + (if only-one? + (lambda (x) (car (syntax->list (syntax (res-vs ...))))) + (lambda (x) (syntax (values res-vs ...)))) + cses))]) + (with-syntax ([expanded-case-> + (make-case->/proc + method-proc? + (syntax (case-> (-> case-doms ... single-case-result) ...)) + inferred-name-stx)]) + (set-inferred-name-from + stx + (syntax/loc stx + (let ([res-vs ress] + ... + [req-vs reqs] + ... + [opt-vs opts] + ...) + expanded-case->)))))))])) + + ;; exactract-argument-lists : syntax -> (listof syntax) + (define (extract-argument-lists stx) + (map (lambda (x) + (syntax-case x () + [(arg-list body) (syntax arg-list)])) + (syntax->list stx))) + + ;; ensure-cases-disjoint : syntax syntax[list] -> void + (define (ensure-cases-disjoint stx cases) + (let ([individual-cases null] + [dot-min #f]) + (for-each (lambda (case) + (let ([this-case (get-case case)]) + (cond + [(number? this-case) + (cond + [(member this-case individual-cases) + (raise-syntax-error + 'case-> + (format "found multiple cases with ~a arguments" this-case) + stx)] + [(and dot-min (dot-min . <= . this-case)) + (raise-syntax-error + 'case-> + (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case) + stx)] + [else (set! individual-cases (cons this-case individual-cases))])] + [(pair? this-case) + (let ([new-dot-min (car this-case)]) + (cond + [dot-min + (if (dot-min . <= . new-dot-min) + (raise-syntax-error + 'case-> + (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min) + stx) + (set! dot-min new-dot-min))] + [else + (set! dot-min new-dot-min)]))]))) + cases))) + + ;; get-case : syntax -> (union number (cons number 'more)) + (define (get-case stx) + (let ([ilist (syntax-object->datum stx)]) + (if (list? ilist) + (length ilist) + (cons + (let loop ([i ilist]) + (cond + [(pair? i) (+ 1 (loop (cdr i)))] + [else 0])) + 'more)))) + + + ;; case->/h : boolean + ;; syntax + ;; (listof syntax) + ;; -> (values (syntax -> syntax) + ;; (syntax -> syntax) + ;; (syntax -> syntax) + ;; (syntax syntax -> syntax) + ;; (syntax -> syntax) + ;; (syntax -> syntax)) + ;; like the other /h functions, but composes the wrapper functions + ;; together and combines the cases of the case-lambda into a single list. + (define (case->/h method-proc? orig-stx cases) + (let loop ([cases cases] + [name-ids '()]) + (cond + [(null? cases) + (values + (lambda (outer-args body) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [body body] + [(name-ids ...) (reverse name-ids)]) + (syntax + (let ([name-id (list name-ids ...)]) + body)))) + (lambda (x y) y) + (lambda (args) (syntax ())) + (syntax (lambda (x) #t)) + (lambda (args) (syntax ())))] + [else + (let ([/h (select/h (car cases) 'case-> orig-stx)] + [new-id (car (generate-temporaries (syntax (case->name-id))))]) + (let-values ([(arguments-checks build-projs check-vals first-order-checks wrappers) + (loop (cdr cases) (cons new-id name-ids))] + [(arguments-check build-proj check-val first-order-check wrapper) + (/h method-proc? (car cases))]) + (values + (lambda (outer-args x) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [new-id new-id]) + (arguments-check + (syntax (val pos-blame neg-blame src-info orig-str new-id)) + (arguments-checks + outer-args + x)))) + (lambda (args inner) (build-projs args (build-proj args inner))) + (lambda (args) + (with-syntax ([checks (check-vals args)] + [check (check-val args)]) + (syntax (check . checks)))) + (with-syntax ([checks first-order-checks] + [check first-order-check]) + (syntax (lambda (x) (and (checks x) (check x))))) + (lambda (args) + (with-syntax ([case (wrapper args)] + [cases (wrappers args)]) + (syntax (case . cases)))))))]))) + + ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void + (define (ensure-no-duplicates stx form-name names) + (let ([ht (make-hash-table)]) + (for-each (lambda (name) + (let ([key (syntax-e name)]) + (when (hash-table-get ht key (lambda () #f)) + (raise-syntax-error form-name + "duplicate method name" + stx + name)) + (hash-table-put! ht key #t))) + names))) + + ;; method-specifier? : syntax -> boolean + ;; returns #t if x is the syntax for a valid method specifier + (define (method-specifier? x) + (or (eq? 'public (syntax-e x)) + (eq? 'override (syntax-e x)))) + + ;; prefix-super : syntax[identifier] -> syntax[identifier] + ;; adds super- to the front of the identifier + (define (prefix-super stx) + (datum->syntax-object + #'here + (string->symbol + (format + "super-~a" + (syntax-object->datum + stx))))) + + ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier] + ;; given the syntax for a method name, constructs the name of a method + ;; that returns the super's contract for the original method. + (define (method-name->contract-method-name stx) + (datum->syntax-object + #'here + (string->symbol + (format + "ACK_DONT_GUESS_ME-super-contract-~a" + (syntax-object->datum + stx))))) + + ;; Each of the /h functions builds six pieces of syntax: + ;; - [arguments-check] + ;; code that binds the contract values to names and + ;; does error checking for the contract specs + ;; (were the arguments all contracts?) + ;; - [build-proj] + ;; code that partially applies the input contracts to build the projection + ;; - [check-val] + ;; code that does error checking on the contract'd value itself + ;; (is it a function of the right arity?) + ;; - [first-order-check] + ;; predicate function that does the first order check and returns a boolean + ;; (is it a function of the right arity?) + ;; - [pos-wrapper] + ;; a piece of syntax that has the arguments to the wrapper + ;; and the body of the wrapper. + ;; - [neg-wrapper] + ;; a piece of syntax that has the arguments to the wrapper + ;; and the body of the wrapper. + ;; the first function accepts a body expression and wraps + ;; the body expression with checks. In addition, it + ;; adds a let that binds the contract exprssions to names + ;; the results of the other functions mention these names. + ;; the second and third function's input syntax should be five + ;; names: val, blame, src-info, orig-str, name-id + ;; the fourth function returns a syntax list with two elements, + ;; the argument list (to be used as the first arg to lambda, + ;; or as a case-lambda clause) and the body of the function. + ;; They are combined into a lambda for the -> ->* ->d ->d* macros, + ;; and combined into a case-lambda for the case-> macro. + + ;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->/h method-proc? stx) + (syntax-case stx () + [(_) (raise-syntax-error '-> "expected at least one argument" stx)] + [(_ dom ... rng) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) + (with-syntax ([(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax-case* (syntax rng) (any values) module-or-top-identifier=? + [any + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([dom-contract-x (coerce-contract '-> dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] ...) + (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure? dom-length)) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (val (dom-projection-x arg-x) ...))))))] + [(values rng ...) + (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] + [(res-x ...) (generate-temporaries (syntax (rng ...)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([dom-contract-x (coerce-contract '-> dom)] + ... + [rng-contract-x (coerce-contract '-> rng)] ...) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [rng-x (contract-proc rng-contract-x)] + ...) + (let ([name-id + (build-compound-type-name + '-> + name-dom-contract-x ... + (build-compound-type-name 'values rng-contract-x ...))]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure? dom-length)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) + (values (rng-projection-x + res-x) + ...))))))))] + [rng + (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] + [(rng-contact-x) (generate-temporaries (syntax (rng)))] + [(rng-projection-x) (generate-temporaries (syntax (rng)))] + [(rng-ant-x) (generate-temporaries (syntax (rng)))] + [(res-x) (generate-temporaries (syntax (rng)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([dom-contract-x (coerce-contract '-> dom)] + ... + [rng-contract-x (coerce-contract '-> rng)]) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [rng-x (contract-proc rng-contract-x)]) + (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)]) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure? dom-length)) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let ([res-x (val (dom-projection-x arg-x) ...)]) + (rng-projection-x res-x))))))))])))])) + + ;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->*/h method-proc? stx) + (syntax-case stx (any) + [(_ (dom ...) (rng ...)) + (->/h method-proc? (syntax (-> dom ... (values rng ...))))] + [(_ (dom ...) any) + (->/h method-proc? (syntax (-> dom ... any)))] + [(_ (dom ...) rest (rng ...)) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [dom-rest-x (car (generate-temporaries (list (syntax rest))))] + [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] + [dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))] + [arg-rest-x (car (generate-temporaries (list (syntax rest))))] + + [(rng-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] + [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] + [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] + [(res-x ...) (generate-temporaries (syntax (rng ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [body body] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->* dom)] + ... + [dom-rest-contract-x (coerce-contract '->* rest)] + [rng-contract-x (coerce-contract '->* rng)] ...) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [dom-rest-x (contract-proc dom-rest-contract-x)] + [rng-x (contract-proc rng-contract-x)] + ...) + (let ([name-id + (build-compound-type-name + '->* + (build-compound-type-name dom-contract-x ...) + dom-rest-contract-x + (build-compound-type-name rng-contract-x ...))]) + body)))))) + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)] + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure/more val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure/more? dom-length)) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . arg-rest-x) + (let-values ([(res-x ...) + (apply + val + (dom-projection-x arg-x) + ... + (dom-rest-projection-x arg-rest-x))]) + (values (rng-projection-x res-x) ...))))))))] + [(_ (dom ...) rest any) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [dom-rest-x (car (generate-temporaries (list (syntax rest))))] + [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] + [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))] + [arg-rest-x (car (generate-temporaries (list (syntax rest))))] + + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->* dom)] + ... + [dom-rest-contract-x (coerce-contract '->* rest)]) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [dom-rest-x (contract-proc dom-rest-contract-x)]) + (let ([name-id (build-compound-type-name + '->* + (build-compound-type-name name-dom-contract-x ...) + dom-rest-contract-x + 'any)]) + body)))))) + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure/more val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure/more? dom-length)) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . arg-rest-x) + (apply + val + (dom-projection-x arg-x) + ... + (dom-projection-rest-x arg-rest-x))))))))])) + + ;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->d/h method-proc? stx) + (syntax-case stx () + [(_) (raise-syntax-error '->d "expected at least one argument" stx)] + [(_ dom ... rng) + (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] + [(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->d dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [rng-x rng]) + (check-rng-procedure '->d rng-x arity) + (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val arity src-info pos-blame orig-str)))) + + (syntax (check-procedure? arity)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let ([arg-x (dom-projection-x arg-x)] ...) + (let ([rng-contract (rng-x arg-x ...)]) + (((contract-proc (coerce-contract '->d rng-contract)) + pos-blame + neg-blame + src-info + orig-str) + (val arg-x ...))))))))))])) + + ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->d*/h method-proc? stx) + (syntax-case stx () + [(_ (dom ...) rng-mk) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->d* dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [rng-mk-x rng-mk]) + (check-rng-procedure '->d* rng-mk-x dom-length) + (let ([name-id (build-compound-type-name + '->d* + (build-compound-type-name name-dom-contract-x ...) + '(... ...))]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure? dom-length)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (call-with-values + (lambda () (rng-mk-x arg-x ...)) + (lambda rng-contracts + (call-with-values + (lambda () + (val (dom-projection-x arg-x) ...)) + (lambda results + (check-rng-lengths results rng-contracts) + (apply + values + (map (lambda (rng-contract result) + (((contract-proc (coerce-contract '->d* rng-contract)) + pos-blame + neg-blame + src-info + orig-str) + result)) + rng-contracts + results))))))))))))] + [(_ (dom ...) rest rng-mk) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-rest-x) (generate-temporaries (syntax (rest)))] + [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))] + [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->d* dom)] + ... + [dom-rest-contract-x (coerce-contract '->d* rest)]) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [dom-rest-x (contract-proc dom-rest-contract-x)] + [rng-mk-x rng-mk]) + (check-rng-procedure/more rng-mk-x arity) + (let ([name-id (build-compound-type-name + '->d* + (build-compound-type-name name-dom-contract-x ...) + dom-rest-contract-x + '(... ...))]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure/more val arity src-info pos-blame orig-str)))) + (syntax (check-procedure/more? arity)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . rest-arg-x) + (call-with-values + (lambda () + (apply rng-mk-x arg-x ... rest-arg-x)) + (lambda rng-contracts + (call-with-values + (lambda () + (apply + val + (dom-projection-x arg-x) + ... + (dom-rest-projection-x rest-arg-x))) + (lambda results + (check-rng-lengths results rng-contracts) + (apply + values + (map (lambda (rng-contract result) + (((contract-proc (coerce-contract '->d* rng-contract)) + pos-blame + neg-blame + src-info + orig-str) + result)) + rng-contracts + results))))))))))))])) + + ;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->r/h method-proc? stx) + (syntax-case stx () + [(_ ([x dom] ...) rng) + (syntax-case* (syntax rng) (any values) module-or-top-identifier=? + [any + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))] + [(values . args) + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))] + [rng + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))] + [_ + (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])] + + [(_ ([x dom] ...) rest-x rest-dom rng) + (syntax-case* (syntax rng) (values any) module-or-top-identifier=? + [any + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))] + [(values . whatever) + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))] + [_ + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])])) + + ;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx)) + + ;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->r-pp/h method-proc? name stx) + (syntax-case stx () + [(_ ([x dom] ...) pre-expr . result-stuff) + (and (andmap identifier? (syntax->list (syntax (x ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (x ...)))))) + (with-syntax ([stx-name name]) + (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))] + [name-stx + (with-syntax ([(name-xs ...) (if method-proc? + (cdr (syntax->list (syntax (x ...)))) + (syntax (x ...)))]) + (syntax + (build-compound-type-name 'stx-name + (build-compound-type-name + (build-compound-type-name 'name-xs '(... ...)) + ...) + '(... ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([name-id name-stx]) + body)))) + (lambda (outer-args inner-lambda) inner-lambda) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [kind-of-thing (if method-proc? 'method 'procedure)]) + (syntax + (begin + (check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) + + (syntax (check-procedure? arity)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=? + [(any) + (syntax + ((x ...) + (begin + (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ...) + (val (dom-id x) ...)))))] + [((values (rng-ids rng-ctc) ...) post-expr) + (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) + (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) + (syntax + ((x ...) + (begin + (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ...) + (let-values ([(rng-ids ...) (val (dom-id x) ...)]) + (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) + pos-blame neg-blame src-info orig-str)] ...) + (values (rng-ids-x rng-ids) ...))))))))] + [((values (rng-ids rng-ctc) ...) post-expr) + (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) + (raise-syntax-error name "duplicate identifier" stx dup))] + [((values (rng-ids rng-ctc) ...) post-expr) + (for-each (lambda (rng-id) + (unless (identifier? rng-id) + (raise-syntax-error name "expected identifier" stx rng-id))) + (syntax->list (syntax (rng-ids ...))))] + [((values . x) . junk) + (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] + [(rng res-id post-expr) + (syntax + ((x ...) + (begin + (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)]) + (let ([res-id (rng-id (val (dom-id x) ...))]) + (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + res-id)))))] + [_ + (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] + + [(_ ([x dom] ...) pre-expr . result-stuff) + (andmap identifier? (syntax->list (syntax (x ...)))) + (raise-syntax-error + name + "duplicate identifier" + stx + (check-duplicate-identifier (syntax->list (syntax (x ...)))))] + [(_ ([x dom] ...) pre-expr . result-stuff) + (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) + (syntax->list (syntax (x ...))))] + [(_ (x ...) pre-expr . result-stuff) + (for-each (lambda (x) + (syntax-case x () + [(x y) (identifier? (syntax x)) (void)] + [bad (raise-syntax-error name "expected identifier and contract" stx (syntax bad))])) + (syntax->list (syntax (x ...))))] + [(_ x dom pre-expr . result-stuff) + (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) + + ;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx)) + + ;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) + (define (->r-pp-rest/h method-proc? name stx) + (syntax-case stx () + [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) + (and (identifier? (syntax rest-x)) + (andmap identifier? (syntax->list (syntax (x ...)))) + (not (check-duplicate-identifier (cons (syntax rest-x) (syntax->list (syntax (x ...))))))) + (with-syntax ([stx-name name]) + (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))] + [name-stx + (with-syntax ([(name-xs ...) (if method-proc? + (cdr (syntax->list (syntax (x ...)))) + (syntax (x ...)))]) + (syntax + (build-compound-type-name 'stx-name + `(,(build-compound-type-name 'name-xs '(... ...)) ...) + 'rest-x + '(... ...) + '(... ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([name-id name-stx]) + body)))) + (lambda (outer-args inner-lambda) inner-lambda) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [kind-of-thing (if method-proc? 'method 'procedure)]) + (syntax + (begin + (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) + (syntax (check-procedure/more? arity)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=? + [(any) + (syntax + ((x ... . rest-x) + (begin + (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)]) + (apply val (dom-id x) ... (rest-id rest-x))))))] + [(any . x) + (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] + [((values (rng-ids rng-ctc) ...) post-expr) + (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) + (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) + (syntax + ((x ... . rest-x) + (begin + (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)]) + (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) + (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) + pos-blame neg-blame src-info orig-str)] ...) + (values (rng-ids-x rng-ids) ...))))))))] + [((values (rng-ids rng-ctc) ...) . whatever) + (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) + (raise-syntax-error name "expected exactly on post-expression at the end" stx)] + [((values (rng-ids rng-ctc) ...) . whatever) + (andmap identifier? (syntax->list (syntax (rng-ids ...)))) + (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) + (raise-syntax-error name "duplicate identifier" stx dup))] + [((values (rng-ids rng-ctc) ...) . whatever) + (for-each (lambda (rng-id) + (unless (identifier? rng-id) + (raise-syntax-error name "expected identifier" stx rng-id))) + (syntax->list (syntax (rng-ids ...))))] + [((values . x) . whatever) + (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] + [(rng res-id post-expr) + (identifier? (syntax res-id)) + (syntax + ((x ... . rest-x) + (begin + (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) + (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] + ... + [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)] + [rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)]) + (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) + (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + res-id)))))] + [(rng res-id post-expr) + (not (identifier? (syntax res-id))) + (raise-syntax-error name "expected an identifier" stx (syntax res-id))] + [_ + (raise-syntax-error name "malformed result sepecification" stx (syntax result-stuff))]))))))] + [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) + (not (identifier? (syntax rest-x))) + (raise-syntax-error name "expected identifier" stx (syntax rest-x))] + [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) + (and (identifier? (syntax rest-x)) + (andmap identifier? (cons (syntax rest-x) (syntax->list (syntax (x ...)))))) + (raise-syntax-error + name + "duplicate identifier" + stx + (check-duplicate-identifier (syntax->list (syntax (x ...)))))] + + [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) + (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) + (cons + (syntax rest-x) + (syntax->list (syntax (x ...)))))] + [(_ x dom rest-x rest-dom rng . result-stuff) + (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) + + ;; select/h : syntax -> /h-function + (define (select/h stx err-name ctxt-stx) + (syntax-case* stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) (λ (x y) (eq? (syntax-e x) (syntax-e y))) + [(-> . args) ->/h] + [(->* . args) ->*/h] + [(->d . args) ->d/h] + [(->d* . args) ->d*/h] + [(->r . args) ->r/h] + [(->pp . args) ->pp/h] + [(->pp-rest . args) ->pp-rest/h] + [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] + [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) + + + ;; set-inferred-name-from : syntax syntax -> syntax + (define (set-inferred-name-from with-name to-be-named) + (let ([name (syntax-local-infer-name with-name)]) + (cond + [(identifier? name) + (with-syntax ([rhs (syntax-property to-be-named 'inferred-name (syntax-e name))] + [name (syntax-e name)]) + (syntax (let ([name rhs]) name)))] + [(symbol? name) + (with-syntax ([rhs (syntax-property to-be-named 'inferred-name name)] + [name name]) + (syntax (let ([name rhs]) name)))] + [else to-be-named]))) + + ;; generate-indicies : syntax[list] -> (cons number (listof number)) + ;; given a syntax list of length `n', returns a list containing + ;; the number n followed by th numbers from 0 to n-1 + (define (generate-indicies stx) + (let ([n (length (syntax->list stx))]) + (cons n + (let loop ([i n]) + (cond + [(zero? i) null] + [else (cons (- n i) + (loop (- i 1)))])))))) \ No newline at end of file diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 351bc4cb75..ab2f38d26a 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -2,18 +2,17 @@ (require (lib "etc.ss") (lib "list.ss") "contract-guts.ss" + "contract-arr-checks.ss" "contract-opt.ss" - "contract-opt-guts.ss" - "class-internal.ss") - + "contract-opt-guts.ss") (require-for-syntax "contract-opt-guts.ss" "contract-helpers.ss" + "contract-arr-obj-helpers.ss" (lib "list.ss") (lib "stx.ss" "syntax") (lib "name.ss" "syntax")) - (provide any - -> + (provide -> ->d ->* ->d* @@ -24,16 +23,8 @@ opt-> opt->* unconstrained-domain-> - object-contract - mixin-contract - make-mixin-contract - is-a?/c - subclass?/c - implementation?/c - check-procedure) - (define-syntax (unconstrained-domain-> stx) (syntax-case stx () [(_ rngs ...) @@ -59,9 +50,6 @@ "expected a procedure"))))) procedure?))))])) - (define-syntax (any stx) - (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx)) - ;; FIXME: need to pass in the name of the contract combinator. (define (build--> name doms doms-rest rngs rng-any? func) (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] @@ -161,7 +149,7 @@ (define arity-seven-wrapper (lambda (chk a53 b54 c55 d56 e57 f58 g59 r60) (lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52))))))) - + (define-syntax-set (-> ->*) (define (->/proc stx) (let-values ([(stx _1 _2) (->/proc/main stx)]) @@ -314,1500 +302,19 @@ inner-args/body (syntax (dom-x ... rst-x)))))))]))) - (define empty-case-lambda/c - (flat-named-contract '(case->) - (λ (x) (and (procedure? x) (null? (procedure-arity x)))))) - - (define-syntax-set (->/real ->*/real ->d ->d* ->r ->pp ->pp-rest case-> object-contract opt-> opt->*) - + #; + (define-syntax-set (->/real ->*/real) (define (->/real/proc stx) (make-/proc #f ->/h stx)) - (define (->*/real/proc stx) (make-/proc #f ->*/h stx)) - (define (->d/proc stx) (make-/proc #f ->d/h stx)) - (define (->d*/proc stx) (make-/proc #f ->d*/h stx)) - (define (->r/proc stx) (make-/proc #f ->r/h stx)) - (define (->pp/proc stx) (make-/proc #f ->pp/h stx)) - (define (->pp-rest/proc stx) (make-/proc #f ->pp-rest/h stx)) - - (define (obj->/proc stx) (make-/proc #t ->/h stx)) - (define (obj->*/proc stx) (make-/proc #t ->*/h stx)) - (define (obj->d/proc stx) (make-/proc #t ->d/h stx)) - (define (obj->d*/proc stx) (make-/proc #t ->d*/h stx)) - (define (obj->r/proc stx) (make-/proc #t ->r/h stx)) - (define (obj->pp/proc stx) (make-/proc #t ->pp/h stx)) - (define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx)) - - (define (case->/proc stx) (make-case->/proc #f stx stx)) - (define (obj-case->/proc stx) (make-case->/proc #t stx stx)) - - (define (obj-opt->/proc stx) (make-opt->/proc #t stx)) - (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx)) - (define (opt->/proc stx) (make-opt->/proc #f stx)) - (define (opt->*/proc stx) (make-opt->*/proc #f stx stx)) + (define (->*/real/proc stx) (make-/proc #f ->*/h stx))) - ;; make-/proc : boolean - ;; (syntax -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))) - ;; syntax - ;; -> (syntax -> syntax) - (define (make-/proc method-proc? /h stx) - (let-values ([(arguments-check build-proj check-val first-order-check wrapper) - (/h method-proc? stx)]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) - (with-syntax ([inner-check (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(val-args body) (wrapper outer-args)]) - (with-syntax ([inner-lambda - (set-inferred-name-from - stx - (syntax/loc stx (lambda val-args body)))]) - (let ([inner-lambda - (syntax - (lambda (val) - inner-check - inner-lambda))]) - (with-syntax ([proj-code (build-proj outer-args inner-lambda)] - [first-order-check first-order-check]) - (arguments-check - outer-args - (syntax/loc stx - (make-proj-contract - name-id - (lambda (pos-blame neg-blame src-info orig-str) - proj-code) - first-order-check)))))))))) - - (define (make-case->/proc method-proc? stx inferred-name-stx) - (syntax-case stx () - - ;; if there are no cases, this contract should only accept the "empty" case-lambda. - [(_) (syntax empty-case-lambda/c)] - - ;; if there is only a single case, just skip it. - [(_ case) (syntax case)] - - [(_ cases ...) - (let-values ([(arguments-check build-projs check-val first-order-check wrapper) - (case->/h method-proc? stx (syntax->list (syntax (cases ...))))]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id))]) - (with-syntax ([(inner-check ...) (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(body ...) (wrapper outer-args)]) - (with-syntax ([inner-lambda - (set-inferred-name-from - inferred-name-stx - (syntax/loc stx (case-lambda body ...)))]) - (let ([inner-lambda - (syntax - (lambda (val) - inner-check ... - inner-lambda))]) - (with-syntax ([proj-code (build-projs outer-args inner-lambda)] - [first-order-check first-order-check]) - (arguments-check - outer-args - (syntax/loc stx - (make-proj-contract - (apply build-compound-type-name 'case-> name-id) - (lambda (pos-blame neg-blame src-info orig-str) - proj-code) - first-order-check)))))))))])) - - (define (make-opt->/proc method-proc? stx) - (syntax-case stx (any) - [(_ (reqs ...) (opts ...) any) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx)] - [(_ (reqs ...) (opts ...) res) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx)])) - - (define (make-opt->*/proc method-proc? stx inferred-name-stx) - (syntax-case stx (any) - [(_ (reqs ...) (opts ...) any) - (let* ([req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] - [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] - [cses - (reverse - (let loop ([opt-vs (reverse opt-vs)]) - (cond - [(null? opt-vs) (list req-vs)] - [else (cons (append req-vs (reverse opt-vs)) - (loop (cdr opt-vs)))])))]) - (with-syntax ([(req-vs ...) req-vs] - [(opt-vs ...) opt-vs] - [((case-doms ...) ...) cses]) - (with-syntax ([expanded-case-> - (make-case->/proc - method-proc? - (syntax (case-> (-> case-doms ... any) ...)) - inferred-name-stx)]) - (syntax/loc stx - (let ([req-vs reqs] ... - [opt-vs opts] ...) - expanded-case->)))))] - [(_ (reqs ...) (opts ...) (ress ...)) - (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))] - [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))] - [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))] - [cses - (reverse - (let loop ([opt-vs (reverse opt-vs)]) - (cond - [(null? opt-vs) (list req-vs)] - [else (cons (append req-vs (reverse opt-vs)) - (loop (cdr opt-vs)))])))]) - (with-syntax ([(res-vs ...) res-vs] - [(req-vs ...) req-vs] - [(opt-vs ...) opt-vs] - [((case-doms ...) ...) cses]) - (with-syntax ([(single-case-result ...) - (let* ([ress-lst (syntax->list (syntax (ress ...)))] - [only-one? - (and (pair? ress-lst) - (null? (cdr ress-lst)))]) - (map - (if only-one? - (lambda (x) (car (syntax->list (syntax (res-vs ...))))) - (lambda (x) (syntax (values res-vs ...)))) - cses))]) - (with-syntax ([expanded-case-> - (make-case->/proc - method-proc? - (syntax (case-> (-> case-doms ... single-case-result) ...)) - inferred-name-stx)]) - (set-inferred-name-from - stx - (syntax/loc stx - (let ([res-vs ress] - ... - [req-vs reqs] - ... - [opt-vs opts] - ...) - expanded-case->)))))))])) - - ;; exactract-argument-lists : syntax -> (listof syntax) - (define (extract-argument-lists stx) - (map (lambda (x) - (syntax-case x () - [(arg-list body) (syntax arg-list)])) - (syntax->list stx))) - - ;; ensure-cases-disjoint : syntax syntax[list] -> void - (define (ensure-cases-disjoint stx cases) - (let ([individual-cases null] - [dot-min #f]) - (for-each (lambda (case) - (let ([this-case (get-case case)]) - (cond - [(number? this-case) - (cond - [(member this-case individual-cases) - (raise-syntax-error - 'case-> - (format "found multiple cases with ~a arguments" this-case) - stx)] - [(and dot-min (dot-min . <= . this-case)) - (raise-syntax-error - 'case-> - (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case) - stx)] - [else (set! individual-cases (cons this-case individual-cases))])] - [(pair? this-case) - (let ([new-dot-min (car this-case)]) - (cond - [dot-min - (if (dot-min . <= . new-dot-min) - (raise-syntax-error - 'case-> - (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min) - stx) - (set! dot-min new-dot-min))] - [else - (set! dot-min new-dot-min)]))]))) - cases))) - - ;; get-case : syntax -> (union number (cons number 'more)) - (define (get-case stx) - (let ([ilist (syntax-object->datum stx)]) - (if (list? ilist) - (length ilist) - (cons - (let loop ([i ilist]) - (cond - [(pair? i) (+ 1 (loop (cdr i)))] - [else 0])) - 'more)))) - - - ;; case->/h : boolean - ;; syntax - ;; (listof syntax) - ;; -> (values (syntax -> syntax) - ;; (syntax -> syntax) - ;; (syntax -> syntax) - ;; (syntax syntax -> syntax) - ;; (syntax -> syntax) - ;; (syntax -> syntax)) - ;; like the other /h functions, but composes the wrapper functions - ;; together and combines the cases of the case-lambda into a single list. - (define (case->/h method-proc? orig-stx cases) - (let loop ([cases cases] - [name-ids '()]) - (cond - [(null? cases) - (values - (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [body body] - [(name-ids ...) (reverse name-ids)]) - (syntax - (let ([name-id (list name-ids ...)]) - body)))) - (lambda (x y) y) - (lambda (args) (syntax ())) - (syntax (lambda (x) #t)) - (lambda (args) (syntax ())))] - [else - (let ([/h (select/h (car cases) 'case-> orig-stx)] - [new-id (car (generate-temporaries (syntax (case->name-id))))]) - (let-values ([(arguments-checks build-projs check-vals first-order-checks wrappers) - (loop (cdr cases) (cons new-id name-ids))] - [(arguments-check build-proj check-val first-order-check wrapper) - (/h method-proc? (car cases))]) - (values - (lambda (outer-args x) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [new-id new-id]) - (arguments-check - (syntax (val pos-blame neg-blame src-info orig-str new-id)) - (arguments-checks - outer-args - x)))) - (lambda (args inner) (build-projs args (build-proj args inner))) - (lambda (args) - (with-syntax ([checks (check-vals args)] - [check (check-val args)]) - (syntax (check . checks)))) - (with-syntax ([checks first-order-checks] - [check first-order-check]) - (syntax (lambda (x) (and (checks x) (check x))))) - (lambda (args) - (with-syntax ([case (wrapper args)] - [cases (wrappers args)]) - (syntax (case . cases)))))))]))) - - (define (object-contract/proc stx) - - ;; name : syntax - ;; ctc-stx : syntax[evals to a contract] - ;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda) - (define-struct mtd (name ctc-stx mtd-arg-stx)) - - ;; name : syntax - ;; ctc-stx : syntax[evals to a contract] - (define-struct fld (name ctc-stx)) - - ;; expand-field/mtd-spec : stx -> (union mtd fld) - (define (expand-field/mtd-spec f/m-stx) - (syntax-case f/m-stx (field) - [(field field-name ctc) - (identifier? (syntax field-name)) - (make-fld (syntax field-name) (syntax ctc))] - [(field field-name ctc) - (raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))] - [(mtd-name ctc) - (identifier? (syntax mtd-name)) - (let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))]) - (make-mtd (syntax mtd-name) - ctc-stx - proc-stx))] - [(mtd-name ctc) - (raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))] - [_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)])) - - ;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg]) - (define (expand-mtd-contract mtd-stx) - (syntax-case mtd-stx (case-> opt-> opt->*) - [(case-> cases ...) - (let loop ([cases (syntax->list (syntax (cases ...)))] - [ctc-stxs null] - [args-stxs null]) - (cond - [(null? cases) - (values - (with-syntax ([(x ...) (reverse ctc-stxs)]) - (obj-case->/proc (syntax (case-> x ...)))) - (with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))]) - (syntax (x ...))))] - [else - (let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))]) - (loop (cdr cases) - (cons ctc-stx ctc-stxs) - (cons mtd-args args-stxs)))]))] - [(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...)) - (values - (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...)))) - (generate-opt->vars (syntax (req-contracts ...)) - (syntax (opt-contracts ...))))] - [(opt->* (req-contracts ...) (opt-contracts ...) any) - (values - (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any))) - (generate-opt->vars (syntax (req-contracts ...)) - (syntax (opt-contracts ...))))] - [(opt-> (req-contracts ...) (opt-contracts ...) res-contract) - (values - (obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract))) - (generate-opt->vars (syntax (req-contracts ...)) - (syntax (opt-contracts ...))))] - [else - (let-values ([(x y z) (expand-mtd-arrow mtd-stx)]) - (values (x y) z))])) - - ;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs] - (define (generate-opt->vars req-stx opt-stx) - (with-syntax ([(req-vars ...) (generate-temporaries req-stx)] - [(ths) (generate-temporaries (syntax (ths)))]) - (let loop ([opt-vars (generate-temporaries opt-stx)]) - (cond - [(null? opt-vars) (list (syntax (ths req-vars ...)))] - [else (with-syntax ([(opt-vars ...) opt-vars] - [(rests ...) (loop (cdr opt-vars))]) - (syntax ((ths req-vars ... opt-vars ...) - rests ...)))])))) - - ;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg]) - (define (expand-mtd-arrow mtd-stx) - (syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) - [(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)] - [(-> args ...) - ;; this case cheats a little bit -- - ;; (args ...) contains the right number of arguments - ;; to the method because it also contains one arg for the result! urgh. - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))]) - (values obj->/proc - (syntax (-> any/c args ...)) - (syntax ((arg-vars ...)))))] - [(->* (doms ...) (rngs ...)) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (values obj->*/proc - (syntax (->* (any/c doms ...) (rngs ...))) - (syntax ((this-var args-vars ...)))))] - [(->* (doms ...) rst (rngs ...)) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(rst-var) (generate-temporaries (syntax (rst)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (values obj->*/proc - (syntax (->* (any/c doms ...) rst (rngs ...))) - (syntax ((this-var args-vars ... . rst-var)))))] - [(->* x ...) - (raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)] - [(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)] - [(->d doms ... rng-proc) - (let ([doms-val (syntax->list (syntax (doms ...)))]) - (values - obj->d/proc - (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] - [arity-count (length doms-val)]) - (syntax - (->d any/c doms ... - (let ([f rng-proc]) - (check->* f arity-count) - (lambda (_this-var arg-vars ...) - (f arg-vars ...)))))) - (with-syntax ([(args-vars ...) (generate-temporaries doms-val)]) - (syntax ((this-var args-vars ...))))))] - [(->d* (doms ...) rng-proc) - (values - obj->d*/proc - (let ([doms-val (syntax->list (syntax (doms ...)))]) - (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] - [arity-count (length doms-val)]) - (syntax (->d* (any/c doms ...) - (let ([f rng-proc]) - (check->* f arity-count) - (lambda (_this-var arg-vars ...) - (f arg-vars ...))))))) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (syntax ((this-var args-vars ...)))))] - [(->d* (doms ...) rst-ctc rng-proc) - (let ([doms-val (syntax->list (syntax (doms ...)))]) - (values - obj->d*/proc - (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] - [(rest-var) (generate-temporaries (syntax (rst-ctc)))] - [arity-count (length doms-val)]) - (syntax (->d* (any/c doms ...) - rst-ctc - (let ([f rng-proc]) - (check->*/more f arity-count) - (lambda (_this-var arg-vars ... . rest-var) - (apply f arg-vars ... rest-var)))))) - (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] - [(rst-var) (generate-temporaries (syntax (rst-ctc)))] - [(this-var) (generate-temporaries (syntax (this-var)))]) - (syntax ((this-var args-vars ... . rst-var))))))] - [(->d* x ...) - (raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)] - - [(->r ([x dom] ...) rng) - (andmap identifier? (syntax->list (syntax (x ...)))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) - (values - obj->r/proc - (syntax (->r ([this any/c] [x dom] ...) rng)) - (syntax ((this-var arg-vars ...)))))] - - [(->r ([x dom] ...) rest-x rest-dom rng) - (andmap identifier? (syntax->list (syntax (x ...)))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) - (values - obj->r/proc - (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng)) - (syntax ((this-var arg-vars ... . rest-var)))))] - - [(->r . x) - (raise-syntax-error 'object-contract "malformed ->r declaration")] - [(->pp ([x dom] ...) . other-stuff) - (andmap identifier? (syntax->list (syntax (x ...)))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) - (values - obj->pp/proc - (syntax (->pp ([this any/c] [x dom] ...) . other-stuff)) - (syntax ((this-var arg-vars ...)))))] - [(->pp . x) - (raise-syntax-error 'object-contract "malformed ->pp declaration")] - [(->pp-rest ([x dom] ...) rest-id . other-stuff) - (and (identifier? (syntax id)) - (andmap identifier? (syntax->list (syntax (x ...))))) - (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] - [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) - (values - obj->pp-rest/proc - (syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff)) - (syntax ((this-var arg-vars ... . rest-id)))))] - [(->pp-rest . x) - (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")] - [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)])) - - ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc] - (define (build-methods-stx mtds) - (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)] - [names (map mtd-name mtds)] - [i 0]) - (cond - [(null? arg-spec-stxss) null] - [else (let ([arg-spec-stxs (car arg-spec-stxss)]) - (with-syntax ([(cases ...) - (map (lambda (arg-spec-stx) - (with-syntax ([i i]) - (syntax-case arg-spec-stx () - [(this rest-ids ...) - (syntax - ((this rest-ids ...) - ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))] - [else - (let-values ([(this rest-ids last-var) - (let ([lst (syntax->improper-list arg-spec-stx)]) - (values (car lst) - (all-but-last (cdr lst)) - (cdr (last-pair lst))))]) - (with-syntax ([this this] - [(rest-ids ...) rest-ids] - [last-var last-var]) - (syntax - ((this rest-ids ... . last-var) - (apply (field-ref this i) - (wrapper-object-wrapped this) - rest-ids ... - last-var)))))]))) - (syntax->list arg-spec-stxs))] - [name (string->symbol (format "~a method" (syntax-object->datum (car names))))]) - (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)]) - (cons (syntax (lambda (field-ref) (let ([name proc]) name))) - (loop (cdr arg-spec-stxss) - (cdr names) - (+ i 1))))))]))) - - (define (syntax->improper-list stx) - (define (se->il se) - (cond - [(pair? se) (sp->il se)] - [else se])) - (define (stx->il stx) - (se->il (syntax-e stx))) - (define (sp->il p) - (cond - [(null? (cdr p)) p] - [(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))] - [(syntax? (cdr p)) - (let ([un (syntax-e (cdr p))]) - (if (pair? un) - (cons (car p) (sp->il un)) - p))])) - (stx->il stx)) - - (syntax-case stx () - [(_ field/mtd-specs ...) - (let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))] - [mtds (filter mtd? mtd/flds)] - [flds (filter fld? mtd/flds)]) - (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)] - [(method-name ...) (map mtd-name mtds)] - [(method-ctc-var ...) (generate-temporaries mtds)] - [(method-var ...) (generate-temporaries mtds)] - [(method/app-var ...) (generate-temporaries mtds)] - [(methods ...) (build-methods-stx mtds)] - - [(field-ctc-stx ...) (map fld-ctc-stx flds)] - [(field-name ...) (map fld-name flds)] - [(field-ctc-var ...) (generate-temporaries flds)] - [(field-var ...) (generate-temporaries flds)] - [(field/app-var ...) (generate-temporaries flds)]) - (syntax - (let ([method-ctc-var method-ctc-stx] - ... - [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] - ...) - (let ([method-var (contract-proc method-ctc-var)] - ... - [field-var (contract-proc field-ctc-var)] - ...) - (let ([cls (make-wrapper-class 'wrapper-class - '(method-name ...) - (list methods ...) - '(field-name ...))]) - (make-proj-contract - `(object-contract - ,(build-compound-type-name 'method-name method-ctc-var) ... - ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - (lambda (pos-blame neg-blame src-info orig-str) - (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] - ... - [field/app-var (field-var pos-blame neg-blame src-info orig-str)] - ...) - (let ([field-names-list '(field-name ...)]) - (lambda (val) - (check-object val src-info pos-blame orig-str) - (let ([val-mtd-names - (interface->method-names - (object-interface - val))]) - (void) - (check-method val 'method-name val-mtd-names src-info pos-blame orig-str) - ...) - - (unless (field-bound? field-name val) - (field-error val 'field-name src-info pos-blame orig-str)) ... - - (let ([vtable (extract-vtable val)] - [method-ht (extract-method-ht val)]) - (make-object cls - val - (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... - (field/app-var (get-field field-name val)) ... - )))))) - #f)))))))])) - - ;; ensure-no-duplicates : syntax (listof syntax[identifier]) -> void - (define (ensure-no-duplicates stx form-name names) - (let ([ht (make-hash-table)]) - (for-each (lambda (name) - (let ([key (syntax-e name)]) - (when (hash-table-get ht key (lambda () #f)) - (raise-syntax-error form-name - "duplicate method name" - stx - name)) - (hash-table-put! ht key #t))) - names))) - - ;; method-specifier? : syntax -> boolean - ;; returns #t if x is the syntax for a valid method specifier - (define (method-specifier? x) - (or (eq? 'public (syntax-e x)) - (eq? 'override (syntax-e x)))) - - ;; prefix-super : syntax[identifier] -> syntax[identifier] - ;; adds super- to the front of the identifier - (define (prefix-super stx) - (datum->syntax-object - #'here - (string->symbol - (format - "super-~a" - (syntax-object->datum - stx))))) - - ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier] - ;; given the syntax for a method name, constructs the name of a method - ;; that returns the super's contract for the original method. - (define (method-name->contract-method-name stx) - (datum->syntax-object - #'here - (string->symbol - (format - "ACK_DONT_GUESS_ME-super-contract-~a" - (syntax-object->datum - stx))))) - - ;; Each of the /h functions builds six pieces of syntax: - ;; - [arguments-check] - ;; code that binds the contract values to names and - ;; does error checking for the contract specs - ;; (were the arguments all contracts?) - ;; - [build-proj] - ;; code that partially applies the input contracts to build the projection - ;; - [check-val] - ;; code that does error checking on the contract'd value itself - ;; (is it a function of the right arity?) - ;; - [first-order-check] - ;; predicate function that does the first order check and returns a boolean - ;; (is it a function of the right arity?) - ;; - [pos-wrapper] - ;; a piece of syntax that has the arguments to the wrapper - ;; and the body of the wrapper. - ;; - [neg-wrapper] - ;; a piece of syntax that has the arguments to the wrapper - ;; and the body of the wrapper. - ;; the first function accepts a body expression and wraps - ;; the body expression with checks. In addition, it - ;; adds a let that binds the contract exprssions to names - ;; the results of the other functions mention these names. - ;; the second and third function's input syntax should be five - ;; names: val, blame, src-info, orig-str, name-id - ;; the fourth function returns a syntax list with two elements, - ;; the argument list (to be used as the first arg to lambda, - ;; or as a case-lambda clause) and the body of the function. - ;; They are combined into a lambda for the -> ->* ->d ->d* macros, - ;; and combined into a case-lambda for the case-> macro. - - ;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->/h method-proc? stx) - (syntax-case stx () - [(_) (raise-syntax-error '-> "expected at least one argument" stx)] - [(_ dom ... rng) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) - (with-syntax ([(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax-case* (syntax rng) (any values) module-or-top-identifier=? - [any - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract '-> dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ...) - (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure? dom-length)) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (val (dom-projection-x arg-x) ...))))))] - [(values rng ...) - (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] - [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] - [(res-x ...) (generate-temporaries (syntax (rng ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract '-> dom)] - ... - [rng-contract-x (coerce-contract '-> rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-x (contract-proc rng-contract-x)] - ...) - (let ([name-id - (build-compound-type-name - '-> - name-dom-contract-x ... - (build-compound-type-name 'values rng-contract-x ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure? dom-length)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) - (values (rng-projection-x - res-x) - ...))))))))] - [rng - (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] - [(rng-contact-x) (generate-temporaries (syntax (rng)))] - [(rng-projection-x) (generate-temporaries (syntax (rng)))] - [(rng-ant-x) (generate-temporaries (syntax (rng)))] - [(res-x) (generate-temporaries (syntax (rng)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract '-> dom)] - ... - [rng-contract-x (coerce-contract '-> rng)]) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-x (contract-proc rng-contract-x)]) - (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)]) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure? dom-length)) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let ([res-x (val (dom-projection-x arg-x) ...)]) - (rng-projection-x res-x))))))))])))])) - - ;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->*/h method-proc? stx) - (syntax-case stx (any) - [(_ (dom ...) (rng ...)) - (->/h method-proc? (syntax (-> dom ... (values rng ...))))] - [(_ (dom ...) any) - (->/h method-proc? (syntax (-> dom ... any)))] - [(_ (dom ...) rest (rng ...)) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [dom-rest-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))] - [arg-rest-x (car (generate-temporaries (list (syntax rest))))] - - [(rng-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] - [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] - [(res-x ...) (generate-temporaries (syntax (rng ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [body body] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->* dom)] - ... - [dom-rest-contract-x (coerce-contract '->* rest)] - [rng-contract-x (coerce-contract '->* rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [dom-rest-x (contract-proc dom-rest-contract-x)] - [rng-x (contract-proc rng-contract-x)] - ...) - (let ([name-id - (build-compound-type-name - '->* - (build-compound-type-name dom-contract-x ...) - dom-rest-contract-x - (build-compound-type-name rng-contract-x ...))]) - body)))))) - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)] - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure/more val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure/more? dom-length)) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . arg-rest-x) - (let-values ([(res-x ...) - (apply - val - (dom-projection-x arg-x) - ... - (dom-rest-projection-x arg-rest-x))]) - (values (rng-projection-x res-x) ...))))))))] - [(_ (dom ...) rest any) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [dom-rest-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] - [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))] - [arg-rest-x (car (generate-temporaries (list (syntax rest))))] - - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->* dom)] - ... - [dom-rest-contract-x (coerce-contract '->* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [dom-rest-x (contract-proc dom-rest-contract-x)]) - (let ([name-id (build-compound-type-name - '->* - (build-compound-type-name name-dom-contract-x ...) - dom-rest-contract-x - 'any)]) - body)))))) - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure/more val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure/more? dom-length)) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . arg-rest-x) - (apply - val - (dom-projection-x arg-x) - ... - (dom-projection-rest-x arg-rest-x))))))))])) - - ;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->d/h method-proc? stx) - (syntax-case stx () - [(_) (raise-syntax-error '->d "expected at least one argument" stx)] - [(_ dom ... rng) - (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] - [(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->d dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-x rng]) - (check-rng-procedure '->d rng-x arity) - (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val arity src-info pos-blame orig-str)))) - - (syntax (check-procedure? arity)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let ([arg-x (dom-projection-x arg-x)] ...) - (let ([rng-contract (rng-x arg-x ...)]) - (((contract-proc (coerce-contract '->d rng-contract)) - pos-blame - neg-blame - src-info - orig-str) - (val arg-x ...))))))))))])) - - ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->d*/h method-proc? stx) - (syntax-case stx () - [(_ (dom ...) rng-mk) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->d* dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-mk-x rng-mk]) - (check-rng-procedure '->d* rng-mk-x dom-length) - (let ([name-id (build-compound-type-name - '->d* - (build-compound-type-name name-dom-contract-x ...) - '(... ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure? dom-length)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (call-with-values - (lambda () (rng-mk-x arg-x ...)) - (lambda rng-contracts - (call-with-values - (lambda () - (val (dom-projection-x arg-x) ...)) - (lambda results - (check-rng-lengths results rng-contracts) - (apply - values - (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str) - result)) - rng-contracts - results))))))))))))] - [(_ (dom ...) rest rng-mk) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-rest-x) (generate-temporaries (syntax (rest)))] - [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))] - [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->d* dom)] - ... - [dom-rest-contract-x (coerce-contract '->d* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [dom-rest-x (contract-proc dom-rest-contract-x)] - [rng-mk-x rng-mk]) - (check-rng-procedure/more rng-mk-x arity) - (let ([name-id (build-compound-type-name - '->d* - (build-compound-type-name name-dom-contract-x ...) - dom-rest-contract-x - '(... ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure/more val arity src-info pos-blame orig-str)))) - (syntax (check-procedure/more? arity)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . rest-arg-x) - (call-with-values - (lambda () - (apply rng-mk-x arg-x ... rest-arg-x)) - (lambda rng-contracts - (call-with-values - (lambda () - (apply - val - (dom-projection-x arg-x) - ... - (dom-rest-projection-x rest-arg-x))) - (lambda results - (check-rng-lengths results rng-contracts) - (apply - values - (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str) - result)) - rng-contracts - results))))))))))))])) - - ;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r/h method-proc? stx) - (syntax-case stx () - [(_ ([x dom] ...) rng) - (syntax-case* (syntax rng) (any values) module-or-top-identifier=? - [any - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))] - [(values . args) - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))] - [rng - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))] - [_ - (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])] - - [(_ ([x dom] ...) rest-x rest-dom rng) - (syntax-case* (syntax rng) (values any) module-or-top-identifier=? - [any - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))] - [(values . whatever) - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))] - [_ - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])])) - - ;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx)) - - ;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r-pp/h method-proc? name stx) - (syntax-case stx () - [(_ ([x dom] ...) pre-expr . result-stuff) - (and (andmap identifier? (syntax->list (syntax (x ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (x ...)))))) - (with-syntax ([stx-name name]) - (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))] - [name-stx - (with-syntax ([(name-xs ...) (if method-proc? - (cdr (syntax->list (syntax (x ...)))) - (syntax (x ...)))]) - (syntax - (build-compound-type-name 'stx-name - (build-compound-type-name - (build-compound-type-name 'name-xs '(... ...)) - ...) - '(... ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([name-id name-stx]) - body)))) - (lambda (outer-args inner-lambda) inner-lambda) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [kind-of-thing (if method-proc? 'method 'procedure)]) - (syntax - (begin - (check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) - - (syntax (check-procedure? arity)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=? - [(any) - (syntax - ((x ...) - (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] - ...) - (val (dom-id x) ...)))))] - [((values (rng-ids rng-ctc) ...) post-expr) - (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) - (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) - (syntax - ((x ...) - (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] - ...) - (let-values ([(rng-ids ...) (val (dom-id x) ...)]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) - pos-blame neg-blame src-info orig-str)] ...) - (values (rng-ids-x rng-ids) ...))))))))] - [((values (rng-ids rng-ctc) ...) post-expr) - (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) - (raise-syntax-error name "duplicate identifier" stx dup))] - [((values (rng-ids rng-ctc) ...) post-expr) - (for-each (lambda (rng-id) - (unless (identifier? rng-id) - (raise-syntax-error name "expected identifier" stx rng-id))) - (syntax->list (syntax (rng-ids ...))))] - [((values . x) . junk) - (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] - [(rng res-id post-expr) - (syntax - ((x ...) - (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] - ... - [rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)]) - (let ([res-id (rng-id (val (dom-id x) ...))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - res-id)))))] - [_ - (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] - - [(_ ([x dom] ...) pre-expr . result-stuff) - (andmap identifier? (syntax->list (syntax (x ...)))) - (raise-syntax-error - name - "duplicate identifier" - stx - (check-duplicate-identifier (syntax->list (syntax (x ...)))))] - [(_ ([x dom] ...) pre-expr . result-stuff) - (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) - (syntax->list (syntax (x ...))))] - [(_ (x ...) pre-expr . result-stuff) - (for-each (lambda (x) - (syntax-case x () - [(x y) (identifier? (syntax x)) (void)] - [bad (raise-syntax-error name "expected identifier and contract" stx (syntax bad))])) - (syntax->list (syntax (x ...))))] - [(_ x dom pre-expr . result-stuff) - (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) - - ;; ->pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->pp-rest/h method-proc? stx) (->r-pp-rest/h method-proc? '->pp-rest stx)) - - ;; ->r-pp-rest/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r-pp-rest/h method-proc? name stx) - (syntax-case stx () - [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) - (and (identifier? (syntax rest-x)) - (andmap identifier? (syntax->list (syntax (x ...)))) - (not (check-duplicate-identifier (cons (syntax rest-x) (syntax->list (syntax (x ...))))))) - (with-syntax ([stx-name name]) - (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))] - [name-stx - (with-syntax ([(name-xs ...) (if method-proc? - (cdr (syntax->list (syntax (x ...)))) - (syntax (x ...)))]) - (syntax - (build-compound-type-name 'stx-name - `(,(build-compound-type-name 'name-xs '(... ...)) ...) - 'rest-x - '(... ...) - '(... ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([name-id name-stx]) - body)))) - (lambda (outer-args inner-lambda) inner-lambda) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [kind-of-thing (if method-proc? 'method 'procedure)]) - (syntax - (begin - (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) - (syntax (check-procedure/more? arity)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=? - [(any) - (syntax - ((x ... . rest-x) - (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] - ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)]) - (apply val (dom-id x) ... (rest-id rest-x))))))] - [(any . x) - (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] - [((values (rng-ids rng-ctc) ...) post-expr) - (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) - (with-syntax ([(rng-ids-x ...) (generate-temporaries (syntax (rng-ids ...)))]) - (syntax - ((x ... . rest-x) - (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] - ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)]) - (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) - pos-blame neg-blame src-info orig-str)] ...) - (values (rng-ids-x rng-ids) ...))))))))] - [((values (rng-ids rng-ctc) ...) . whatever) - (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (rng-ids ...)))))) - (raise-syntax-error name "expected exactly on post-expression at the end" stx)] - [((values (rng-ids rng-ctc) ...) . whatever) - (andmap identifier? (syntax->list (syntax (rng-ids ...)))) - (let ([dup (check-duplicate-identifier (syntax->list (syntax (rng-ids ...))))]) - (raise-syntax-error name "duplicate identifier" stx dup))] - [((values (rng-ids rng-ctc) ...) . whatever) - (for-each (lambda (rng-id) - (unless (identifier? rng-id) - (raise-syntax-error name "expected identifier" stx rng-id))) - (syntax->list (syntax (rng-ids ...))))] - [((values . x) . whatever) - (raise-syntax-error name "malformed multiple values result" stx (syntax (values . x)))] - [(rng res-id post-expr) - (identifier? (syntax res-id)) - (syntax - ((x ... . rest-x) - (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) neg-blame pos-blame src-info orig-str)] - ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) neg-blame pos-blame src-info orig-str)] - [rng-id ((contract-proc (coerce-contract 'stx-name rng)) pos-blame neg-blame src-info orig-str)]) - (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - res-id)))))] - [(rng res-id post-expr) - (not (identifier? (syntax res-id))) - (raise-syntax-error name "expected an identifier" stx (syntax res-id))] - [_ - (raise-syntax-error name "malformed result sepecification" stx (syntax result-stuff))]))))))] - [(_ ([x dom] ...) rest-x rest-dom pre-expr . result-stuff) - (not (identifier? (syntax rest-x))) - (raise-syntax-error name "expected identifier" stx (syntax rest-x))] - [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) - (and (identifier? (syntax rest-x)) - (andmap identifier? (cons (syntax rest-x) (syntax->list (syntax (x ...)))))) - (raise-syntax-error - name - "duplicate identifier" - stx - (check-duplicate-identifier (syntax->list (syntax (x ...)))))] - - [(_ ([x dom] ...) rest-x rest-dom rng . result-stuff) - (for-each (lambda (x) (unless (identifier? x) (raise-syntax-error name "expected identifier" stx x))) - (cons - (syntax rest-x) - (syntax->list (syntax (x ...)))))] - [(_ x dom rest-x rest-dom rng . result-stuff) - (raise-syntax-error name "expected list of identifiers and expression pairs" stx (syntax x))])) - - ;; select/h : syntax -> /h-function - (define (select/h stx err-name ctxt-stx) - (syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) - [(-> . args) ->/h] - [(->* . args) ->*/h] - [(->d . args) ->d/h] - [(->d* . args) ->d*/h] - [(->r . args) ->r/h] - [(->pp . args) ->pp/h] - [(->pp-rest . args) ->pp-rest/h] - [(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))] - [_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)])) - - - ;; set-inferred-name-from : syntax syntax -> syntax - (define (set-inferred-name-from with-name to-be-named) - (let ([name (syntax-local-infer-name with-name)]) - (cond - [(identifier? name) - (with-syntax ([rhs (syntax-property to-be-named 'inferred-name (syntax-e name))] - [name (syntax-e name)]) - (syntax (let ([name rhs]) name)))] - [(symbol? name) - (with-syntax ([rhs (syntax-property to-be-named 'inferred-name name)] - [name name]) - (syntax (let ([name rhs]) name)))] - [else to-be-named]))) - - ;; generate-indicies : syntax[list] -> (cons number (listof number)) - ;; given a syntax list of length `n', returns a list containing - ;; the number n followed by th numbers from 0 to n-1 - (define (generate-indicies stx) - (let ([n (length (syntax->list stx))]) - (cons n - (let loop ([i n]) - (cond - [(zero? i) null] - [else (cons (- n i) - (loop (- i 1)))])))))) - - ;; procedure-accepts-and-more? : procedure number -> boolean - ;; returns #t if val accepts dom-length arguments and - ;; any number of arguments more than dom-length. - ;; returns #f otherwise. - (define (procedure-accepts-and-more? val dom-length) - (let ([arity (procedure-arity val)]) - (cond - [(number? arity) #f] - [(arity-at-least? arity) - (<= (arity-at-least-value arity) dom-length)] - [else - (let ([min-at-least (let loop ([ars arity] - [acc #f]) - (cond - [(null? ars) acc] - [else (let ([ar (car ars)]) - (cond - [(arity-at-least? ar) - (if (and acc - (< acc (arity-at-least-value ar))) - (loop (cdr ars) acc) - (loop (cdr ars) (arity-at-least-value ar)))] - [(number? ar) - (loop (cdr ars) acc)]))]))]) - (and min-at-least - (begin - (let loop ([counts (sort (filter number? arity) >=)]) - (unless (null? counts) - (let ([count (car counts)]) - (cond - [(= (+ count 1) min-at-least) - (set! min-at-least count) - (loop (cdr counts))] - [(< count min-at-least) - (void)] - [else (loop (cdr counts))])))) - (<= min-at-least dom-length))))]))) + (define-syntax (->d stx) (make-/proc #f ->d/h stx)) + (define-syntax (->d* stx) (make-/proc #f ->d*/h stx)) + (define-syntax (->r stx) (make-/proc #f ->r/h stx)) + (define-syntax (->pp stx) (make-/proc #f ->pp/h stx)) + (define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx)) + (define-syntax (case-> stx) (make-case->/proc #f stx stx)) + (define-syntax (opt-> stx) (make-opt->/proc #f stx)) + (define-syntax (opt->* stx) (make-opt->*/proc #f stx stx)) ;; ;; arrow opter @@ -1946,225 +453,4 @@ (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] [(-> dom ... rng) (opt/arrow-ctc (syntax->list (syntax (dom ...))) - (list #'rng))])) - - ;; ---------------------------------------- - ;; Checks and error functions used in macro expansions - - (define (check->* f arity-count) - (unless (procedure? f) - (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) - (unless (procedure-arity-includes? f arity-count) - (error 'object-contract - "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" - arity-count - f))) - - (define (check->*/more f arity-count) - (unless (procedure? f) - (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) - (unless (procedure-accepts-and-more? f arity-count) - (error 'object-contract - "expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e" - arity-count - (if (= 1 arity-count) "" "s") - f))) - - - (define (check-pre-expr->pp/h val pre-expr src-info blame orig-str) - (unless pre-expr - (raise-contract-error val - src-info - blame - orig-str - "pre-condition expression failure"))) - - (define (check-post-expr->pp/h val post-expr src-info blame orig-str) - (unless post-expr - (raise-contract-error val - src-info - blame - orig-str - "post-condition expression failure"))) - - (define (check-procedure val dom-length src-info blame orig-str) - (unless (and (procedure? val) - (procedure-arity-includes? val dom-length)) - (raise-contract-error - val - src-info - blame - orig-str - "expected a procedure that accepts ~a arguments, given: ~e" - dom-length - val))) - - (define ((check-procedure? arity) val) - (and (procedure? val) - (procedure-arity-includes? val arity))) - - (define ((check-procedure/more? arity) val) - (and (procedure? val) - (procedure-accepts-and-more? val arity))) - - (define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) - (unless (procedure? val) - (raise-contract-error val - src-info - blame - orig-str - "expected a procedure, got ~e" - val)) - (unless (procedure-arity-includes? val arity) - (raise-contract-error val - src-info - blame - orig-str - "expected a ~a of arity ~a (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) - - (define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str) - (unless (procedure? val) - (raise-contract-error val - src-info - blame - orig-str - "expected a procedure, got ~e" - val)) - (unless (procedure-accepts-and-more? val arity) - (raise-contract-error val - src-info - blame - orig-str - "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) - - (define (check-procedure/more val dom-length src-info blame orig-str) - (unless (and (procedure? val) - (procedure-accepts-and-more? val dom-length)) - (raise-contract-error - val - src-info - blame - orig-str - "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" - dom-length - dom-length - val))) - - - (define (check-rng-procedure who rng-x arity) - (unless (and (procedure? rng-x) - (procedure-arity-includes? rng-x arity)) - (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e" - arity - rng-x))) - - (define (check-rng-procedure/more rng-mk-x arity) - (unless (and (procedure? rng-mk-x) - (procedure-accepts-and-more? rng-mk-x arity)) - (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e" - arity - rng-mk-x))) - - (define (check-rng-lengths results rng-contracts) - (unless (= (length results) (length rng-contracts)) - (error '->d* - "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" - (length results) (length rng-contracts)))) - - (define (check-object val src-info blame orig-str) - (unless (object? val) - (raise-contract-error val - src-info - blame - orig-str - "expected an object, got ~e" - val))) - - (define (check-method val method-name val-mtd-names src-info blame orig-str) - (unless (memq method-name val-mtd-names) - (raise-contract-error val - src-info - blame - orig-str - "expected an object with method ~s" - method-name))) - - (define (field-error val field-name src-info blame orig-str) - (raise-contract-error val - src-info - blame - orig-str - "expected an object with field ~s" - field-name)) - - #| - - test cases for procedure-accepts-and-more? - - (and (procedure-accepts-and-more? (lambda (x . y) 1) 3) - (procedure-accepts-and-more? (lambda (x . y) 1) 2) - (procedure-accepts-and-more? (lambda (x . y) 1) 1) - (not (procedure-accepts-and-more? (lambda (x . y) 1) 0)) - - (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3) - (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2) - (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1) - (not (procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0)) - - (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2) - (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) - (not (procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0))) - - |# - - (define (make-mixin-contract . %/<%>s) - ((and/c (flat-contract class?) - (apply and/c (map sub/impl?/c %/<%>s))) - . ->d . - subclass?/c)) - - (define (subclass?/c %) - (unless (class? %) - (error 'subclass?/c "expected , given: ~e" %)) - (let ([name (object-name %)]) - (flat-named-contract - `(subclass?/c ,(or name 'unknown%)) - (lambda (x) (subclass? x %))))) - - (define (implementation?/c <%>) - (unless (interface? <%>) - (error 'implementation?/c "expected , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - `(implementation?/c ,(or name 'unknown<%>)) - (lambda (x) (implementation? x <%>))))) - - (define (sub/impl?/c %/<%>) - (cond - [(interface? %/<%>) (implementation?/c %/<%>)] - [(class? %/<%>) (subclass?/c %/<%>)] - [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) - - (define (is-a?/c <%>) - (unless (or (interface? <%>) - (class? <%>)) - (error 'is-a?/c "expected or , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - (cond - [name - `(is-a?/c ,name)] - [(class? <%>) - `(is-a?/c unknown%)] - [else `(is-a?/c unknown<%>)]) - (lambda (x) (is-a? x <%>))))) - - (define mixin-contract (class? . ->d . subclass?/c))) + (list #'rng))]))) diff --git a/collects/mzlib/private/contract-guts.ss b/collects/mzlib/private/contract-guts.ss index bbc81cbb49..06f774a4cf 100644 --- a/collects/mzlib/private/contract-guts.ss +++ b/collects/mzlib/private/contract-guts.ss @@ -45,8 +45,11 @@ ;; for opters check-flat-contract - check-flat-named-contract) + check-flat-named-contract + any) + (define-syntax (any stx) + (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx)) ;; define-struct/prop is a define-struct-like macro that ;; also allows properties to be defined diff --git a/collects/mzlib/private/contract-helpers.ss b/collects/mzlib/private/contract-helpers.ss index 26ba0010a9..d73afc1832 100644 --- a/collects/mzlib/private/contract-helpers.ss +++ b/collects/mzlib/private/contract-helpers.ss @@ -1,5 +1,5 @@ (module contract-helpers mzscheme - + (provide module-source-as-symbol build-src-loc-string mangle-id mangle-id-for-maker build-struct-names @@ -7,15 +7,9 @@ add-name-prop all-but-last known-good-contract?) - + (require (lib "main-collects.ss" "setup")) - - (define (known-good-contract? id) - (and (identifier? id) - (ormap (λ (x) (module-identifier=? x id)) - (list #'integer? - #'boolean? - #'number?)))) + (require-for-template mzscheme) (define (add-name-prop name stx) (cond @@ -74,7 +68,7 @@ [(null? (cdr l)) null] [(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))] [else (list (car l))])) - + ;; helper for build-src-loc-string (define (source->name src) (let* ([bs (cond [(bytes? src) src] @@ -84,9 +78,9 @@ [r (and bs (path->main-collects-relative bs))]) (and bs (bytes->string/locale (if (and (pair? r) (eq? 'collects (car r))) - (bytes-append #"/" (cdr r)) - bs))))) - + (bytes-append #"/" (cdr r)) + bs))))) + ;; build-src-loc-string : syntax -> (union #f string) (define (build-src-loc-string stx) (let* ([source (source->name (syntax-source stx))] @@ -97,8 +91,8 @@ [pos (format "~a" pos)] [else #f])]) (if (and source location) - (string-append source ":" location) - (or location source)))) + (string-append source ":" location) + (or location source)))) (define o (current-output-port)) @@ -148,4 +142,139 @@ (let loop ([i 0]) (cond [(= i n) '()] - [else (cons i (loop (+ i 1)))])))) + [else (cons i (loop (+ i 1)))]))) + + (define known-good-ids + (list #'absolute-path? + #'bound-identifier=? + #'box? + #'byte-pregexp? + #'byte-regexp? + #'byte? + #'bytes-converter? + #'bytes=? + #'bytes? + #'channel? + #'char-alphabetic? + #'char-blank? + #'char-graphic? + #'char-iso-control? + #'char-lower-case? + #'char-numeric? + #'char-punctuation? + #'char-symbolic? + #'char-title-case? + #'char-upper-case? + #'char-whitespace? + #'compiled-expression? + #'compiled-module-expression? + #'complete-path? + #'continuation-mark-set? + #'continuation-prompt-available? + #'custodian-box? + #'custodian-memory-accounting-available? + #'custodian? + #'directory-exists? + #'ephemeron? + #'evt? + #'exn:break? + #'exn:fail:contract:arity? + #'exn:fail:contract:continuation? + #'exn:fail:contract:divide-by-zero? + #'exn:fail:contract:variable? + #'exn:fail:contract? + #'exn:fail:filesystem:exists? + #'exn:fail:filesystem:version? + #'exn:fail:filesystem? + #'exn:fail:network? + #'exn:fail:out-of-memory? + #'exn:fail:read:eof? + #'exn:fail:read:non-char? + #'exn:fail:read? + #'exn:fail:syntax? + #'exn:fail:unsupported? + #'exn:fail:user? + #'exn:fail? + #'exn? + #'file-exists? + #'file-stream-port? + #'free-identifier=? + #'handle-evt? + #'hash-table? + #'identifier? + #'immutable? + #'inspector? + #'keyword? + #'link-exists? + #'module-identifier=? + #'module-path-index? + #'module-provide-protected? + #'module-template-identifier=? + #'module-transformer-identifier=? + #'namespace? + #'parameter-procedure=? + #'parameter? + #'parameterization? + #'path-for-some-system? + #'path-string? + #'path? + #'port-closed? + #'port-provides-progress-evts? + #'port-writes-atomic? + #'port-writes-special? + #'port? + #'pregexp? + #'primitive-closure? + #'primitive? + #'procedure-arity-includes? + #'procedure-closure-contents-eq? + #'procedure-struct-type? + #'promise? + #'pseudo-random-generator? + #'regexp-match? + #'regexp? + #'relative-path? + #'rename-transformer? + #'security-guard? + #'semaphore-try-wait? + #'semaphore? + #'set!-transformer? + #'special-comment? + #'string-locale-ci=? + #'string-locale=? + #'struct-accessor-procedure? + #'struct-constructor-procedure? + #'struct-mutator-procedure? + #'struct-predicate-procedure? + #'struct-type-property? + #'struct-type? + #'struct? + #'subprocess? + #'syntax-graph? + #'syntax-original? + #'syntax-transforming? + #'syntax? + #'system-big-endian? + #'tcp-accept-ready? + #'tcp-listener? + #'tcp-port? + #'terminal-port? + #'thread-cell? + #'thread-dead? + #'thread-group? + #'thread-running? + #'thread? + #'udp-bound? + #'udp-connected? + #'udp? + #'void? + #'weak-box? + #'will-executor? + #'arity-at-least? + #'exn:srclocs? + #'srcloc?)) + + (define (known-good-contract? id) + (and (identifier? id) + (ormap (λ (x) (module-identifier=? x id)) + known-good-ids)))) diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss new file mode 100644 index 0000000000..ef91b87161 --- /dev/null +++ b/collects/mzlib/private/contract-object.ss @@ -0,0 +1,429 @@ +(module contract-object mzscheme + (require (lib "etc.ss") + (lib "list.ss") + "contract-arrow.ss" + "contract-guts.ss" + "contract-opt.ss" + "contract-opt-guts.ss" + "class-internal.ss" + "contract-arr-checks.ss") + + (require-for-syntax "contract-opt-guts.ss" + "contract-helpers.ss" + "contract-arr-obj-helpers.ss" + (lib "list.ss") + (lib "stx.ss" "syntax") + (lib "name.ss" "syntax")) + + (provide mixin-contract + make-mixin-contract + is-a?/c + subclass?/c + implementation?/c + object-contract) + + (define-syntax-set (object-contract) + + (define (obj->/proc stx) (make-/proc #t ->/h stx)) + (define (obj->*/proc stx) (make-/proc #t ->*/h stx)) + (define (obj->d/proc stx) (make-/proc #t ->d/h stx)) + (define (obj->d*/proc stx) (make-/proc #t ->d*/h stx)) + (define (obj->r/proc stx) (make-/proc #t ->r/h stx)) + (define (obj->pp/proc stx) (make-/proc #t ->pp/h stx)) + (define (obj->pp-rest/proc stx) (make-/proc #t ->pp-rest/h stx)) + (define (obj-case->/proc stx) (make-case->/proc #t stx stx)) + + (define (obj-opt->/proc stx) (make-opt->/proc #t stx)) + (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx)) + + (define (object-contract/proc stx) + + ;; name : syntax + ;; ctc-stx : syntax[evals to a contract] + ;; mtd-arg-stx : syntax[list of arg-specs] (ie, for use in a case-lambda) + (define-struct mtd (name ctc-stx mtd-arg-stx)) + + ;; name : syntax + ;; ctc-stx : syntax[evals to a contract] + (define-struct fld (name ctc-stx)) + + ;; expand-field/mtd-spec : stx -> (union mtd fld) + (define (expand-field/mtd-spec f/m-stx) + (syntax-case f/m-stx (field) + [(field field-name ctc) + (identifier? (syntax field-name)) + (make-fld (syntax field-name) (syntax ctc))] + [(field field-name ctc) + (raise-syntax-error 'object-contract "expected name of field" stx (syntax field-name))] + [(mtd-name ctc) + (identifier? (syntax mtd-name)) + (let-values ([(ctc-stx proc-stx) (expand-mtd-contract (syntax ctc))]) + (make-mtd (syntax mtd-name) + ctc-stx + proc-stx))] + [(mtd-name ctc) + (raise-syntax-error 'object-contract "expected name of method" stx (syntax mtd-name))] + [_ (raise-syntax-error 'object-contract "expected field or method clause" stx f/m-stx)])) + + ;; expand-mtd-contract : syntax -> (values syntax[expanded ctc] syntax[mtd-arg]) + (define (expand-mtd-contract mtd-stx) + (syntax-case mtd-stx (case-> opt-> opt->*) + [(case-> cases ...) + (let loop ([cases (syntax->list (syntax (cases ...)))] + [ctc-stxs null] + [args-stxs null]) + (cond + [(null? cases) + (values + (with-syntax ([(x ...) (reverse ctc-stxs)]) + (obj-case->/proc (syntax (case-> x ...)))) + (with-syntax ([(x ...) (apply append (map syntax->list (reverse args-stxs)))]) + (syntax (x ...))))] + [else + (let-values ([(trans ctc-stx mtd-args) (expand-mtd-arrow (car cases))]) + (loop (cdr cases) + (cons ctc-stx ctc-stxs) + (cons mtd-args args-stxs)))]))] + [(opt->* (req-contracts ...) (opt-contracts ...) (res-contracts ...)) + (values + (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) (res-contracts ...)))) + (generate-opt->vars (syntax (req-contracts ...)) + (syntax (opt-contracts ...))))] + [(opt->* (req-contracts ...) (opt-contracts ...) any) + (values + (obj-opt->*/proc (syntax (opt->* (any/c req-contracts ...) (opt-contracts ...) any))) + (generate-opt->vars (syntax (req-contracts ...)) + (syntax (opt-contracts ...))))] + [(opt-> (req-contracts ...) (opt-contracts ...) res-contract) + (values + (obj-opt->/proc (syntax (opt-> (any/c req-contracts ...) (opt-contracts ...) res-contract))) + (generate-opt->vars (syntax (req-contracts ...)) + (syntax (opt-contracts ...))))] + [else + (let-values ([(x y z) (expand-mtd-arrow mtd-stx)]) + (values (x y) z))])) + + ;; generate-opt->vars : syntax[requried contracts] syntax[optional contracts] -> syntax[list of arg specs] + (define (generate-opt->vars req-stx opt-stx) + (with-syntax ([(req-vars ...) (generate-temporaries req-stx)] + [(ths) (generate-temporaries (syntax (ths)))]) + (let loop ([opt-vars (generate-temporaries opt-stx)]) + (cond + [(null? opt-vars) (list (syntax (ths req-vars ...)))] + [else (with-syntax ([(opt-vars ...) opt-vars] + [(rests ...) (loop (cdr opt-vars))]) + (syntax ((ths req-vars ... opt-vars ...) + rests ...)))])))) + + ;; expand-mtd-arrow : stx -> (values (syntax[ctc] -> syntax[expanded ctc]) syntax[ctc] syntax[mtd-arg]) + (define (expand-mtd-arrow mtd-stx) + (syntax-case mtd-stx (-> ->* ->d ->d* ->r ->pp ->pp-rest) + [(->) (raise-syntax-error 'object-contract "-> must have arguments" stx mtd-stx)] + [(-> args ...) + ;; this case cheats a little bit -- + ;; (args ...) contains the right number of arguments + ;; to the method because it also contains one arg for the result! urgh. + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (args ...)))]) + (values obj->/proc + (syntax (-> any/c args ...)) + (syntax ((arg-vars ...)))))] + [(->* (doms ...) (rngs ...)) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (values obj->*/proc + (syntax (->* (any/c doms ...) (rngs ...))) + (syntax ((this-var args-vars ...)))))] + [(->* (doms ...) rst (rngs ...)) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(rst-var) (generate-temporaries (syntax (rst)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (values obj->*/proc + (syntax (->* (any/c doms ...) rst (rngs ...))) + (syntax ((this-var args-vars ... . rst-var)))))] + [(->* x ...) + (raise-syntax-error 'object-contract "malformed ->*" stx mtd-stx)] + [(->d) (raise-syntax-error 'object-contract "->d must have arguments" stx mtd-stx)] + [(->d doms ... rng-proc) + (let ([doms-val (syntax->list (syntax (doms ...)))]) + (values + obj->d/proc + (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] + [arity-count (length doms-val)]) + (syntax + (->d any/c doms ... + (let ([f rng-proc]) + (check->* f arity-count) + (lambda (_this-var arg-vars ...) + (f arg-vars ...)))))) + (with-syntax ([(args-vars ...) (generate-temporaries doms-val)]) + (syntax ((this-var args-vars ...))))))] + [(->d* (doms ...) rng-proc) + (values + obj->d*/proc + (let ([doms-val (syntax->list (syntax (doms ...)))]) + (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] + [arity-count (length doms-val)]) + (syntax (->d* (any/c doms ...) + (let ([f rng-proc]) + (check->* f arity-count) + (lambda (_this-var arg-vars ...) + (f arg-vars ...))))))) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (syntax ((this-var args-vars ...)))))] + [(->d* (doms ...) rst-ctc rng-proc) + (let ([doms-val (syntax->list (syntax (doms ...)))]) + (values + obj->d*/proc + (with-syntax ([(arg-vars ...) (generate-temporaries doms-val)] + [(rest-var) (generate-temporaries (syntax (rst-ctc)))] + [arity-count (length doms-val)]) + (syntax (->d* (any/c doms ...) + rst-ctc + (let ([f rng-proc]) + (check->*/more f arity-count) + (lambda (_this-var arg-vars ... . rest-var) + (apply f arg-vars ... rest-var)))))) + (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] + [(rst-var) (generate-temporaries (syntax (rst-ctc)))] + [(this-var) (generate-temporaries (syntax (this-var)))]) + (syntax ((this-var args-vars ... . rst-var))))))] + [(->d* x ...) + (raise-syntax-error 'object-contract "malformed ->d* method contract" stx mtd-stx)] + + [(->r ([x dom] ...) rng) + (andmap identifier? (syntax->list (syntax (x ...)))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->r/proc + (syntax (->r ([this any/c] [x dom] ...) rng)) + (syntax ((this-var arg-vars ...)))))] + + [(->r ([x dom] ...) rest-x rest-dom rng) + (andmap identifier? (syntax->list (syntax (x ...)))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->r/proc + (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng)) + (syntax ((this-var arg-vars ... . rest-var)))))] + + [(->r . x) + (raise-syntax-error 'object-contract "malformed ->r declaration")] + [(->pp ([x dom] ...) . other-stuff) + (andmap identifier? (syntax->list (syntax (x ...)))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->pp/proc + (syntax (->pp ([this any/c] [x dom] ...) . other-stuff)) + (syntax ((this-var arg-vars ...)))))] + [(->pp . x) + (raise-syntax-error 'object-contract "malformed ->pp declaration")] + [(->pp-rest ([x dom] ...) rest-id . other-stuff) + (and (identifier? (syntax id)) + (andmap identifier? (syntax->list (syntax (x ...))))) + (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] + [(this-var) (generate-temporaries (syntax (this-var)))] + [this (datum->syntax-object mtd-stx 'this)]) + (values + obj->pp-rest/proc + (syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff)) + (syntax ((this-var arg-vars ... . rest-id)))))] + [(->pp-rest . x) + (raise-syntax-error 'object-contract "malformed ->pp-rest declaration")] + [else (raise-syntax-error 'object-contract "unknown method contract syntax" stx mtd-stx)])) + + ;; build-methods-stx : syntax[list of lambda arg specs] -> syntax[method realized as proc] + (define (build-methods-stx mtds) + (let loop ([arg-spec-stxss (map mtd-mtd-arg-stx mtds)] + [names (map mtd-name mtds)] + [i 0]) + (cond + [(null? arg-spec-stxss) null] + [else (let ([arg-spec-stxs (car arg-spec-stxss)]) + (with-syntax ([(cases ...) + (map (lambda (arg-spec-stx) + (with-syntax ([i i]) + (syntax-case arg-spec-stx () + [(this rest-ids ...) + (syntax + ((this rest-ids ...) + ((field-ref this i) (wrapper-object-wrapped this) rest-ids ...)))] + [else + (let-values ([(this rest-ids last-var) + (let ([lst (syntax->improper-list arg-spec-stx)]) + (values (car lst) + (all-but-last (cdr lst)) + (cdr (last-pair lst))))]) + (with-syntax ([this this] + [(rest-ids ...) rest-ids] + [last-var last-var]) + (syntax + ((this rest-ids ... . last-var) + (apply (field-ref this i) + (wrapper-object-wrapped this) + rest-ids ... + last-var)))))]))) + (syntax->list arg-spec-stxs))] + [name (string->symbol (format "~a method" (syntax-object->datum (car names))))]) + (with-syntax ([proc (syntax-property (syntax (case-lambda cases ...)) 'method-arity-error #t)]) + (cons (syntax (lambda (field-ref) (let ([name proc]) name))) + (loop (cdr arg-spec-stxss) + (cdr names) + (+ i 1))))))]))) + + (define (syntax->improper-list stx) + (define (se->il se) + (cond + [(pair? se) (sp->il se)] + [else se])) + (define (stx->il stx) + (se->il (syntax-e stx))) + (define (sp->il p) + (cond + [(null? (cdr p)) p] + [(pair? (cdr p)) (cons (car p) (sp->il (cdr p)))] + [(syntax? (cdr p)) + (let ([un (syntax-e (cdr p))]) + (if (pair? un) + (cons (car p) (sp->il un)) + p))])) + (stx->il stx)) + + (syntax-case stx () + [(_ field/mtd-specs ...) + (let* ([mtd/flds (map expand-field/mtd-spec (syntax->list (syntax (field/mtd-specs ...))))] + [mtds (filter mtd? mtd/flds)] + [flds (filter fld? mtd/flds)]) + (with-syntax ([(method-ctc-stx ...) (map mtd-ctc-stx mtds)] + [(method-name ...) (map mtd-name mtds)] + [(method-ctc-var ...) (generate-temporaries mtds)] + [(method-var ...) (generate-temporaries mtds)] + [(method/app-var ...) (generate-temporaries mtds)] + [(methods ...) (build-methods-stx mtds)] + + [(field-ctc-stx ...) (map fld-ctc-stx flds)] + [(field-name ...) (map fld-name flds)] + [(field-ctc-var ...) (generate-temporaries flds)] + [(field-var ...) (generate-temporaries flds)] + [(field/app-var ...) (generate-temporaries flds)]) + (syntax + (let ([method-ctc-var method-ctc-stx] + ... + [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] + ...) + (let ([method-var (contract-proc method-ctc-var)] + ... + [field-var (contract-proc field-ctc-var)] + ...) + (let ([cls (make-wrapper-class 'wrapper-class + '(method-name ...) + (list methods ...) + '(field-name ...))]) + (make-proj-contract + `(object-contract + ,(build-compound-type-name 'method-name method-ctc-var) ... + ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + (lambda (pos-blame neg-blame src-info orig-str) + (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str)] + ... + [field/app-var (field-var pos-blame neg-blame src-info orig-str)] + ...) + (let ([field-names-list '(field-name ...)]) + (lambda (val) + (check-object val src-info pos-blame orig-str) + (let ([val-mtd-names + (interface->method-names + (object-interface + val))]) + (void) + (check-method val 'method-name val-mtd-names src-info pos-blame orig-str) + ...) + + (unless (field-bound? field-name val) + (field-error val 'field-name src-info pos-blame orig-str)) ... + + (let ([vtable (extract-vtable val)] + [method-ht (extract-method-ht val)]) + (make-object cls + val + (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... + (field/app-var (get-field field-name val)) ... + )))))) + #f)))))))]))) + + + (define (check-object val src-info blame orig-str) + (unless (object? val) + (raise-contract-error val + src-info + blame + orig-str + "expected an object, got ~e" + val))) + + (define (check-method val method-name val-mtd-names src-info blame orig-str) + (unless (memq method-name val-mtd-names) + (raise-contract-error val + src-info + blame + orig-str + "expected an object with method ~s" + method-name))) + + (define (field-error val field-name src-info blame orig-str) + (raise-contract-error val + src-info + blame + orig-str + "expected an object with field ~s" + field-name)) + + (define (make-mixin-contract . %/<%>s) + ((and/c (flat-contract class?) + (apply and/c (map sub/impl?/c %/<%>s))) + . ->d . + subclass?/c)) + + (define (subclass?/c %) + (unless (class? %) + (error 'subclass?/c "expected , given: ~e" %)) + (let ([name (object-name %)]) + (flat-named-contract + `(subclass?/c ,(or name 'unknown%)) + (lambda (x) (subclass? x %))))) + + (define (implementation?/c <%>) + (unless (interface? <%>) + (error 'implementation?/c "expected , given: ~e" <%>)) + (let ([name (object-name <%>)]) + (flat-named-contract + `(implementation?/c ,(or name 'unknown<%>)) + (lambda (x) (implementation? x <%>))))) + + (define (sub/impl?/c %/<%>) + (cond + [(interface? %/<%>) (implementation?/c %/<%>)] + [(class? %/<%>) (subclass?/c %/<%>)] + [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) + + (define (is-a?/c <%>) + (unless (or (interface? <%>) + (class? <%>)) + (error 'is-a?/c "expected or , given: ~e" <%>)) + (let ([name (object-name <%>)]) + (flat-named-contract + (cond + [name + `(is-a?/c ,name)] + [(class? <%>) + `(is-a?/c unknown%)] + [else `(is-a?/c unknown<%>)]) + (lambda (x) (is-a? x <%>))))) + + (define mixin-contract (class? . ->d . subclass?/c))) \ No newline at end of file diff --git a/collects/mzlib/private/contract.ss b/collects/mzlib/private/contract.ss index 12ea5176e7..37a5251874 100644 --- a/collects/mzlib/private/contract.ss +++ b/collects/mzlib/private/contract.ss @@ -22,7 +22,6 @@ improve method arity mismatch contract violation error messages? (require (lib "etc.ss") (lib "list.ss") (lib "pretty.ss") - (lib "pconvert.ss") "contract-arrow.ss" "contract-guts.ss" "contract-opt.ss" @@ -116,36 +115,35 @@ improve method arity mismatch contract violation error messages? #; (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (make-set!-transformer - (let ([saved-id #f]) + (let ([saved-id-table (make-hash-table)]) (λ (stx) - (unless saved-id - (with-syntax ([contract-id contract-id] - [id id] - [pos-module-source pos-module-source]) - (set! saved-id - (syntax-local-introduce - (syntax-local-lift-expression - #'(-contract contract-id - id - pos-module-source - (module-source-as-symbol #'name) - (quote-syntax name))))))) - - (with-syntax ([saved-id (syntax-local-introduce saved-id)]) - (syntax-case stx (set!) - [(set! id body) (raise-syntax-error - #f - "cannot set! provide/contract identifier" - stx - (syntax id))] - [(name arg ...) - (syntax/loc stx - (saved-id - arg - ...))] - [name - (identifier? (syntax name)) - (syntax saved-id)])))))) + (let ([key (syntax-local-lift-context)]) + (unless (hash-table-get saved-id-table key #f) + (with-syntax ([contract-id contract-id] + [id id] + [pos-module-source pos-module-source]) + (hash-table-put! + saved-id-table + key + (syntax-local-introduce + (syntax-local-lift-expression + #'(-contract contract-id + id + pos-module-source + (module-source-as-symbol #'name) + (quote-syntax id))))))) + + (with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))]) + (syntax-case stx (set!) + [(set! id body) (raise-syntax-error + #f + "cannot set! provide/contract identifier" + stx + (syntax id))] + [(name arg ...) (syntax/loc stx (saved-id arg ...))] + [name + (identifier? (syntax name)) + (syntax saved-id)]))))))) ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding @@ -1285,6 +1283,24 @@ improve method arity mismatch contract violation error messages? (error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e" elems)) (make-one-of/c elems)) + + (define (one-of-pc x) + (cond + [(symbol? x) + `',x] + [(null? x) + ''()] + [(void? x) + '(void)] + [(or (char? x) + (boolean? x) + (keyword? x) + (number? x)) + x] + [(eq? x (letrec ([x x]) x)) + '(letrec ([x x]) x)] + [else (error 'one-of-pc "undef ~s" x)])) + (define-struct/prop one-of/c (elems) ((proj-prop flat-proj) @@ -1295,7 +1311,7 @@ improve method arity mismatch contract violation error messages? 'symbols] [else 'one-of/c]) - ,@(map print-convert elems))))) + ,@(map one-of-pc elems))))) (stronger-prop (λ (this that) (and (one-of/c? that) diff --git a/collects/profj/libs/java/lang/Object-composite.ss b/collects/profj/libs/java/lang/Object-composite.ss index 4a6fa49ca0..8be9557e21 100644 --- a/collects/profj/libs/java/lang/Object-composite.ss +++ b/collects/profj/libs/java/lang/Object-composite.ss @@ -109,7 +109,7 @@ (if (string? obj) (make-java-string string) (begin - (c:contract (c:object-contract + (c:contract (object-contract (clone (c:-> c:any/c)) (equals-java.lang.Object (c:-> c:any/c c:any/c)) (finalize (c:-> c:any/c)) @@ -1019,7 +1019,7 @@ guard-convert-Throwable static-Throwable/c) (define (wrap-convert-assert-Throwable obj p n s c) - (c:contract (c:object-contract + (c:contract (object-contract (init-cause (c:-> c:any/c c:any/c)) (get-message (c:-> c:any/c)) (get-cause (c:-> c:any/c)) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index c05c98e54a..893c4d2486 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -992,10 +992,10 @@ ;methods->contract: (list method-record) -> sexp (define (methods->contract methods) - `(c:object-contract ,@(map (lambda (m) + `(object-contract ,@(map (lambda (m) `(,(build-identifier (mangle-method-name (method-record-name m) (method-record-atypes m))) - (c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c))) + (c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c))) methods))) ;method->check/error: method-record -> sexp @@ -2128,11 +2128,11 @@ `(c:union (c:is-a?/c object%) string?) (cond ((method-contract? (unknown-ref-access type)) - `(c:object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type)))) - ,(type->contract (unknown-ref-access type) from-dynamic?)))) + `(object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type)))) + ,(type->contract (unknown-ref-access type) from-dynamic?)))) ((field-contract? (unknown-ref-access type)) - `(c:object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f")) - ,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?))))))) + `(object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f")) + ,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?))))))) ((method-contract? type) `(c:-> ,@(map (lambda (a) (type->contract a from-dynamic?)) (method-contract-args type)) ,(type->contract (method-contract-return type) from-dynamic? #t))) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index f726d8b2a5..5504e46566 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4366,6 +4366,8 @@ so that propagation occurs. (test-name 'printable/c printable/c) (test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c)) (test-name '(one-of/c 1 2 3) (one-of/c 1 2 3)) + (test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)) + (one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))) (test-name '(subclass?/c class:c%) (let ([c% (class object% (super-new))]) (subclass?/c c%))) @@ -5169,7 +5171,22 @@ so that propagation occurs. (define-syntax (unit-body stx) f f #'1))))) - + + (test/spec-passed + 'provide/contract22 + '(begin + (eval '(module provide/contract22a mzscheme + (require (lib "contract.ss")) + (provide/contract [make-bound-identifier-mapping integer?]) + (define make-bound-identifier-mapping 1))) + (eval '(module provide/contract22b mzscheme + (require-for-syntax provide/contract22a) + + (define-syntax (unit-body stx) + make-bound-identifier-mapping) + + (define-syntax (f stx) + make-bound-identifier-mapping))))) (contract-error-test #'(begin diff --git a/collects/texpict/mrpict.ss b/collects/texpict/mrpict.ss index 81d68010a6..420b0759ac 100644 --- a/collects/texpict/mrpict.ss +++ b/collects/texpict/mrpict.ss @@ -2,6 +2,7 @@ (module mrpict mzscheme (require (lib "unit.ss") (lib "contract.ss") + (lib "class.ss") (lib "mred.ss" "mred")) (require (lib "mred-sig.ss" "mred")