From 3cf6ed46738360cb84a414423d176e14bf79e803 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 3 Jan 2008 18:10:43 +0000 Subject: [PATCH] mostly finished the contract library changes svn: r8195 --- collects/mred/private/editor.ss | 14 + collects/mzlib/private/contract-object.ss | 3 +- collects/scheme/contract.ss | 6 +- collects/scheme/private/class-internal.ss | 40 +- .../scheme/private/contract-arr-checks.ss | 234 ---- .../private/contract-arr-obj-helpers.ss | 1112 ----------------- collects/scheme/private/contract-arrow.ss | 498 ++++++-- collects/scheme/private/contract-object.ss | 505 ++------ collects/scribblings/reference/class.scrbl | 73 +- .../scribblings/reference/contracts.scrbl | 26 +- collects/tests/mzscheme/contract-test.ss | 710 ++++------- 11 files changed, 853 insertions(+), 2368 deletions(-) delete mode 100644 collects/scheme/private/contract-arr-checks.ss delete mode 100644 collects/scheme/private/contract-arr-obj-helpers.ss diff --git a/collects/mred/private/editor.ss b/collects/mred/private/editor.ss index 0812ed8710..add690a678 100644 --- a/collects/mred/private/editor.ss +++ b/collects/mred/private/editor.ss @@ -81,6 +81,20 @@ set-modified set-filename get-file put-file get-max-undo-history) + (rename-super [super-on-char on-char]) + (define time 0) + (define count 0) + (override* [on-char + (λ (evt) + (let-values ([(results cpu real gc) + (time-apply (λ () (super-on-char evt)) '())]) + (set! time (+ real time)) + (set! count (+ count 1)) + (when (= count 20) + (printf "time ~s\n" time) + (set! count 0) + (set! time 0)) + (apply values results)))]) (define canvases null) (define active-canvas #f) (define auto-set-wrap? #f) diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index 4de48a079c..8d48438478 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -338,7 +338,8 @@ (let ([cls (make-wrapper-class 'wrapper-class '(method-name ...) (list methods ...) - '(field-name ...))]) + '(field-name ...) + #t)]) (make-proj-contract `(object-contract ,(build-compound-type-name 'method-name method-ctc-var) ... diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss index 718975e535..092969059e 100644 --- a/collects/scheme/contract.ss +++ b/collects/scheme/contract.ss @@ -22,7 +22,11 @@ differences from v3: (except-out (all-from-out "private/contract-ds.ss") lazy-depth-to-look) - (all-from-out "private/contract-arrow.ss") + (except-out (all-from-out "private/contract-arrow.ss") + making-a-method + procedure-accepts-and-more? + check-procedure + check-procedure/more) (except-out (all-from-out "private/contract.ss") check-between/c check-unary-between/c)) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 048f788498..2885f37f1f 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -3363,8 +3363,9 @@ ;; make-wrapper-class : symbol ;; (listof symbol) - ;; (listof (selector -> method-func-spec[object args -> result])) + ;; method-spec [depends on the boolean what it is] ;; (listof symbol) + ;; boolean ;; -> class ;; the resulting class is the "proxy" class for the contracted version of an ;; object with contracts on the method-ids. @@ -3379,7 +3380,7 @@ ;; The class accepts one initialization argument per method and ;; one init arg per field (in that order) using the make-object style ;; initialization. - (define (make-wrapper-class class-name method-ids methods field-ids) + (define (make-wrapper-class class-name method-ids methods field-ids old-style?) (let* ([supers (vector object% #f)] [method-ht (make-hash-table)] [method-count (length method-ids)] @@ -3403,7 +3404,9 @@ (list->vector (map (lambda (x) 'final) method-ids)) 'dont-use-me! - (+ 1 field-count method-count) + (if old-style? + (+ field-count method-count 1) + field-count) field-ht field-ids @@ -3423,7 +3426,9 @@ (make-struct-type 'wrapper-object struct:wrapper-object 0 - (+ (length field-ids) (length method-ids)) + (if old-style? + (+ (length field-ids) (length method-ids)) + (length field-ids)) undefined (list (cons prop:object cls)) insp)]) @@ -3435,11 +3440,8 @@ (let ([init (lambda (o continue-make-super c inited? named-args leftover-args) - ;; leftover args will contain: - ;; the original object, - ;; all of the contract-ized versions of the methods, - ;; and all of the contract-ized versions of the fields - ;; just fill them into `o'. + ;; leftover args will contain the original object and new field values + ;; fill the original object in and then fill in the fields. (set-wrapper-object-wrapped! o (car leftover-args)) (let loop ([leftover-args (cdr leftover-args)] [i 0]) @@ -3450,27 +3452,24 @@ (continue-make-super o c inited? '() '() '()))]) (set-class-init! cls init)) - ;; fill in the methods vector - (let loop ([i 0] - [methods methods]) - (when (< i method-count) - (vector-set! methods-vec i ((car methods) field-ref)) - (loop (+ i 1) - (cdr methods)))) - - ;; fill in the methods-ht + ;; fill in the methods vector & methods-ht (let loop ([i 0] + [methods methods] [method-ids method-ids]) (when (< i method-count) + (vector-set! methods-vec i (if old-style? + ((car methods) field-ref) + (car methods))) (hash-table-put! method-ht (car method-ids) i) (loop (+ i 1) + (cdr methods) (cdr method-ids)))) ;; fill in the fields-ht (let loop ([i 0] [field-ids field-ids]) (when (< i field-count) - (hash-table-put! field-ht (car field-ids) (cons cls (+ i method-count))) + (hash-table-put! field-ht (car field-ids) (cons cls i)) (loop (+ i 1) (cdr field-ids)))) @@ -3655,7 +3654,8 @@ (provide (protect-out make-wrapper-class wrapper-object-wrapped extract-vtable - extract-method-ht) + extract-method-ht + get-field/proc) (rename-out [_class class]) class* class/derived define-serializable-class define-serializable-class* diff --git a/collects/scheme/private/contract-arr-checks.ss b/collects/scheme/private/contract-arr-checks.ss deleted file mode 100644 index f4896a9114..0000000000 --- a/collects/scheme/private/contract-arr-checks.ss +++ /dev/null @@ -1,234 +0,0 @@ -#lang scheme/base - -(provide (all-defined-out)) -(require "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 (and (procedure-arity-includes? f arity-count) - (no-mandatory-keywords? f)) - (error 'object-contract - "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" - arity-count - f))) - -(define (get-mandatory-keywords f) - (let-values ([(mandatory optional) (procedure-keywords f)]) - mandatory)) - -(define (no-mandatory-keywords? f) - (let-values ([(mandatory optional) (procedure-keywords f)]) - (null? mandatory))) - -(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 optionals mandatory-kwds optional-keywords src-info blame orig-str) - (unless (and (procedure? val) - (procedure-arity-includes?/optionals val dom-length optionals) - (keywords-match mandatory-kwds optional-keywords val)) - (raise-contract-error - val - src-info - blame - orig-str - "expected a procedure that accepts ~a arguments~a, given: ~e" - dom-length - (keyword-error-text mandatory-kwds) - val))) - -(define (procedure-arity-includes?/optionals f base optionals) - (cond - [(zero? optionals) (procedure-arity-includes? f base)] - [else (and (procedure-arity-includes? f (+ base optionals)) - (procedure-arity-includes?/optionals f base (- optionals 1)))])) - -(define (keywords-match mandatory-kwds optional-kwds val) - (let-values ([(proc-mandatory proc-all) (procedure-keywords val)]) - (and (equal? proc-mandatory mandatory-kwds) - (andmap (λ (kwd) (and (member kwd proc-all) - (not (member kwd proc-mandatory)))) - optional-kwds)))) - -(define (keyword-error-text mandatory-keywords) - (cond - [(null? mandatory-keywords) " without any keywords"] - [(null? (cdr mandatory-keywords)) - (format " and the keyword ~a" (car mandatory-keywords))] - [else - (format - " and the keywords ~a~a" - (car mandatory-keywords) - (apply string-append (map (λ (x) (format " ~a" x)) (cdr mandatory-keywords))))])) - -(define ((check-procedure? arity) val) - (and (procedure? val) - (procedure-arity-includes? val arity) - (no-mandatory-keywords? val))) - -(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 mandatory-kwds optional-kwds src-info blame orig-str) - (unless (and (procedure? val) - (procedure-accepts-and-more? val dom-length) - (keywords-match mandatory-kwds optional-kwds val)) - (raise-contract-error - val - src-info - blame - orig-str - "expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e" - dom-length - (keyword-error-text mandatory-kwds) - 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))) - - |# diff --git a/collects/scheme/private/contract-arr-obj-helpers.ss b/collects/scheme/private/contract-arr-obj-helpers.ss deleted file mode 100644 index 6ca7373aad..0000000000 --- a/collects/scheme/private/contract-arr-obj-helpers.ss +++ /dev/null @@ -1,1112 +0,0 @@ -#lang scheme/base -(require syntax/stx - syntax/name) - -(require (for-syntax scheme/base)) -(require (for-template scheme/base) - (for-template "contract-guts.ss") - (for-template "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 select/h) - (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 ...))) select/h)]) - (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 select/h case-arr-stx arr-stx) - (syntax-case stx (any) - [(_ (reqs ...) (opts ...) any) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) any)) stx select/h case-arr-stx arr-stx)] - [(_ (reqs ...) (opts ...) res) - (make-opt->*/proc method-proc? (syntax (opt->* (reqs ...) (opts ...) (res))) stx select/h case-arr-stx arr-stx)])) - -(define (make-opt->*/proc method-proc? stx inferred-name-stx select/h case-arr-stx arr-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? - (with-syntax ([case-> case-arr-stx] - [-> arr-stx]) - (syntax (case-> (-> case-doms ... any) ...))) - inferred-name-stx - select/h)]) - (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? - (with-syntax ([case-> case-arr-stx] - [-> arr-stx]) - (syntax (case-> (-> case-doms ... single-case-result) ...))) - inferred-name-stx - select/h)]) - (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->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) -;; select/h -;; -> (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 select/h) - (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 - #'here - (string->symbol - (format - "super-~a" - (syntax->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 - #'here - (string->symbol - (format - "ACK_DONT_GUESS_ME-super-contract-~a" - (syntax->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 0 '() '() #|keywords|# 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 0 '() '() #|keywords|# 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 0 '() '() #|keywords|# 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 '() '() #|keywords|# 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 '() '() #|keywords|# 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 0 '() '() #|keywords|# 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 0 '() '() #|keywords|# 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 '() '() #|keywords|# 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))])) - -;; 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/scheme/private/contract-arrow.ss b/collects/scheme/private/contract-arrow.ss index 39af7bf4fe..88a6f91954 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -8,14 +8,15 @@ v4 done: - rewrote ->* using new notation - rewrote ->d using new notation - rewrote case-> +- rewrote object-contract v4 todo: -- rewrite object-contract to use new function combinators. +- add case-> to object-contract -- remove opt-> opt->* ->pp ->pp-rest ->r ->d* +- improve the generation of wrappers to avoid 'apply' and to make keywords work. -- remove extra checks from contract-arr-checks.ss (after object-contract is done). +- test object-contract with keywords (both optional and mandatory) - change mzlib/contract to rewrite into scheme/contract (maybe?) @@ -23,15 +24,16 @@ v4 todo: . multiple identical keywords syntax error, sort-keywords . split-doms +- note timing/size tests at the end of the file. + |# (require "contract-guts.ss" - "contract-arr-checks.ss" - "contract-opt.ss") + "contract-opt.ss" + scheme/stxparam) (require (for-syntax scheme/base) (for-syntax "contract-opt-guts.ss") (for-syntax "contract-helpers.ss") - (for-syntax "contract-arr-obj-helpers.ss") (for-syntax syntax/stx) (for-syntax syntax/name)) @@ -40,7 +42,13 @@ v4 todo: ->d case-> unconstrained-domain-> - the-unsupplied-arg) + the-unsupplied-arg + making-a-method + procedure-accepts-and-more? + check-procedure + check-procedure/more) + +(define-syntax-parameter making-a-method #f) (define-syntax (unconstrained-domain-> stx) (syntax-case stx () @@ -136,9 +144,10 @@ v4 todo: [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str)) optional-kwds-proj)]) (apply func - (λ (val) (if has-rest? - (check-procedure/more val dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) - (check-procedure val dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) + (λ (val mtd?) + (if has-rest? + (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) + (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) (append partial-doms partial-optional-doms partial-mandatory-kwds partial-optional-kwds partial-ranges))))))) @@ -198,7 +207,7 @@ v4 todo: (apply build-compound-type-name (append doms/c (apply append (map list kwds kwds/c)))) (apply build-compound-type-name (append optional-doms/c (apply append (map list optional-kwds optional-kwds/c)))) (if doms-rest - (list doms-rest range) + (list '#:rest doms-rest range) (list range))))] [else (let ([rng-name @@ -279,7 +288,11 @@ v4 todo: (with-syntax ([(keyword-call/ctc ...) (apply append (map syntax->list (syntax->list #'((dom-kwd (dom-kwd-ctc-id dom-kwd-arg)) ...))))] [(keyword-formal-parameters ...) (apply append (map syntax->list (syntax->list #'((dom-kwd dom-kwd-arg) ...))))] [(args ...) (generate-temporaries (syntax (doms ...)))] - [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]) + [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] + [(this-parameter ...) + (if (syntax-parameter-value #'making-a-method) + (generate-temporaries '(this)) + '())]) (syntax-case* #'last-one (-> any values) module-or-top-identifier=? [any (with-syntax ([(ignored) (generate-temporaries (syntax (rng)))]) @@ -290,7 +303,8 @@ v4 todo: (syntax (any/c)) (syntax (dom-kwd-ctc ...)) (syntax (dom-kwd ...)) - (syntax ((args ... keyword-formal-parameters ...) (val (dom-ctc args) ... keyword-call/ctc ...))) + (syntax ((this-parameter ... args ... keyword-formal-parameters ...) + (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...))) #t))] [(values rngs ...) (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rngs ...)))] @@ -302,8 +316,8 @@ v4 todo: (syntax (rngs ...)) (syntax (dom-kwd-ctc ...)) (syntax (dom-kwd ...)) - (syntax ((args ... keyword-formal-parameters ...) - (let-values ([(rng-x ...) (val (dom-ctc args) ... keyword-call/ctc ...)]) + (syntax ((this-parameter ... args ... keyword-formal-parameters ...) + (let-values ([(rng-x ...) (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...)]) (values (rng-ctc rng-x) ...)))) #f))] [rng @@ -315,9 +329,15 @@ v4 todo: (syntax (rng)) (syntax (dom-kwd-ctc ...)) (syntax (dom-kwd ...)) - (syntax ((args ... keyword-formal-parameters ...) (rng-ctc (val (dom-ctc args) ... keyword-call/ctc ...)))) + (syntax ((this-parameter ... args ... keyword-formal-parameters ...) + (rng-ctc (val this-parameter ... (dom-ctc args) ... keyword-call/ctc ...)))) #f))]))))])) +(define-for-syntax (maybe-a-method/name stx) + (if (syntax-parameter-value #'making-a-method) + (syntax-property stx 'method-arity-error #t) + stx)) + ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) (define-for-syntax (->/proc/main stx) (let-values ([(dom-names rng-names kwd-names dom-ctcs rng-ctcs kwd-ctcs kwds inner-args/body use-any?) (->-helper stx)]) @@ -330,16 +350,16 @@ v4 todo: [(kwd-ctcs ...) kwd-ctcs] [(kwds ...) kwds] [inner-lambda - (add-name-prop - (syntax-local-infer-name stx) - (syntax (lambda args body)))] + (maybe-a-method/name + (add-name-prop + (syntax-local-infer-name stx) + (syntax (lambda args body))))] [use-any? use-any?]) (with-syntax ([outer-lambda - (syntax - (lambda (chk dom-names ... kwd-names ... rng-names ...) - (lambda (val) - (chk val) - inner-lambda)))]) + #`(lambda (chk dom-names ... kwd-names ... rng-names ...) + (lambda (val) + (chk val #,(syntax-parameter-value #'making-a-method)) + inner-lambda))]) (values (syntax (build--> '-> @@ -352,8 +372,7 @@ v4 todo: (define-syntax (-> stx) (let-values ([(stx _1 _2) (->/proc/main stx)]) - stx)) - + #`(syntax-parameterize ((making-a-method #f)) #,stx))) ;; ;; arrow opter @@ -426,7 +445,7 @@ v4 todo: (dom-len (length dom-vars)) ((next-rng ...) next-rngs)) (syntax (begin - (check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str) + (check-procedure val #f dom-len 0 '() '() #| keywords |# src-info pos orig-str) (λ (dom-arg ...) (let-values ([(rng-arg ...) (val next-dom ...)]) (values next-rng ...)))))) @@ -474,7 +493,7 @@ v4 todo: ((next-dom ...) next-doms) (dom-len (length dom-vars))) (syntax (begin - (check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str) + (check-procedure val #f dom-len 0 '() '() #|keywords|# src-info pos orig-str) (λ (dom-arg ...) (val next-dom ...))))) lifts-doms @@ -572,14 +591,18 @@ v4 todo: ;; rng-ctc (or/c #f syntax) -- #f means `any', syntax is a sequence of result values (syntax-case #'rst (any values) [(any) (values #f #f)] - [(rest-expr any) (values #'rest-expr #f)] + [(#:rest rest-expr any) (values #'rest-expr #f)] [((values res-ctc ...)) (values #f #'(res-ctc ...))] - [(rest-expr (values res-ctc ...)) (values #'rest-expr #'(res-ctc ...))] + [(#:rest rest-expr (values res-ctc ...)) (values #'rest-expr #'(res-ctc ...))] [(res-ctc) (values #f #'(res-ctc))] - [(rest-expr res-ctc) (values #'rest-expr #'(res-ctc))] + [(#:rest rest-expr res-ctc) (values #'rest-expr #'(res-ctc))] [_ (raise-syntax-error #f "bad syntax" stx)])]) (with-syntax ([(rng-proj ...) (generate-temporaries (or rng-ctc '()))] - [(rng ...) (generate-temporaries (or rng-ctc '()))]) + [(rng ...) (generate-temporaries (or rng-ctc '()))] + [(this-parameter ...) + (if (syntax-parameter-value #'making-a-method) + (generate-temporaries '(this)) + '())]) #`(build--> '->* (list mandatory-dom ...) @@ -603,10 +626,11 @@ v4 todo: optional-dom-kwd-proj ... rng-proj ...) (λ (f) - (chk f) + (chk f #,(syntax-parameter-value #'making-a-method)) #,(add-name-prop (syntax-local-infer-name stx) - #`(λ (mandatory-dom-arg ... + #`(λ (this-parameter ... + mandatory-dom-arg ... [optional-dom-arg unspecified-dom] ... mandatory-dom-kwd/var-seq ... optional-dom-kwd/var-seq ... @@ -625,15 +649,16 @@ v4 todo: opt-args (cons (rev-optional-dom-proj rev-optional-dom-arg) opt-args))] ...) - #,(let ([call (if (null? (syntax->list #'(rev-sorted-dom-kwd ...))) - #'(apply f (mandatory-dom-proj mandatory-dom-arg) ... opt-args) - #'(keyword-apply f kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))]) + #,(let ([call + (if (null? (syntax->list #'(rev-sorted-dom-kwd ...))) + #'(apply f this-parameter ... (mandatory-dom-proj mandatory-dom-arg) ... opt-args) + #'(keyword-apply f this-parameter ... kwds kwd-args (mandatory-dom-proj mandatory-dom-arg) ... opt-args))]) (if rng-ctc #`(let-values ([(rng ...) #,call]) (values (rng-proj rng) ...)) call))))))))))))))])) -(define-syntax (->* stx) (->*/proc/main stx)) +(define-syntax (->* stx) #`(syntax-parameterize ((making-a-method #f)) #,(->*/proc/main stx))) @@ -656,10 +681,16 @@ v4 todo: (define-for-syntax (parse-leftover stx leftover) (let*-values ([(id/rest-id leftover) (syntax-case leftover () - [(id rest-expr . leftover) + [(#:rest id rest-expr . leftover) (and (identifier? #'id) (not (keyword? (syntax-e #'rest-expr)))) (values #'(id rest-expr) #'leftover)] + [(#:rest id rest-expr . leftover) + (begin + (unless (identifier? #'id) + (raise-syntax-error #f "expected an identifier" stx #'id)) + (when (keyword? (syntax-e #'rest-expr)) + (raise-syntax-error #f "expected an expression, not a keyword" stx #'rest-expr)))] [_ (values #f leftover)])] [(pre-cond leftover) (syntax-case leftover () @@ -670,7 +701,7 @@ v4 todo: (syntax-case leftover () [(range . leftover) (values #'range #'leftover)] [_ - (raise-syntax-error #f "bad syntax" stx)])] + (raise-syntax-error #f "expected a range expression, but found nothing" stx)])] [(post-cond leftover) (syntax-case leftover () [(#:post-cond post-cond . leftover) @@ -722,10 +753,15 @@ v4 todo: stx (syntax->list #'((optional-kwd optional-kwd-id) ... - (mandatory-kwd mandatory-kwd-id) ...)))]) + (mandatory-kwd mandatory-kwd-id) ...)))] + [(this-parameter ...) + (if (syntax-parameter-value #'making-a-method) + (list (datum->syntax stx 'this #f)) + '())]) (let-values ([(id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]) (with-syntax ([(dom-params ...) - #`(mandatory-regular-id ... + #`(this-parameter ... + mandatory-regular-id ... optional-regular-id ... #,@(if id/rest (with-syntax ([(id rst-ctc) id/rest]) @@ -738,49 +774,59 @@ v4 todo: [(values [id ctc] ... x . y) (raise-syntax-error #f "expected binding pair" stx #'x)] [any #'(() #f)] [[id ctc] #'((id) (ctc))] - [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]) + [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])] + [mtd? (syntax-parameter-value #'making-a-method)]) (let ([dup (check-duplicate-identifier (syntax->list #'(dom-params ... rng-params ...)))]) (when dup (raise-syntax-error #f "duplicate identifier" stx dup))) - #`(build-->d (list (λ (dom-params ...) mandatory-doms) ...) - (list (λ (dom-params ...) optional-doms) ...) - (list (λ (dom-params ...) mandatory-kwd-dom) ...) - (list (λ (dom-params ...) optional-kwd-dom) ...) - #,(if id/rest - (with-syntax ([(id rst-ctc) id/rest]) - #`(λ (dom-params ...) rst-ctc)) - #f) - #,(if pre-cond - #`(λ (dom-params ...) #,pre-cond) - #f) - #,(syntax-case #'rng-ctcs () - [#f #f] - [(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)]) - #,(if post-cond - #`(λ (rng-params ... dom-params ...) #,post-cond) - #f) - '(mandatory-kwd ...) - '(optional-kwd ...) - (λ (f) - #,(add-name-prop - (syntax-local-infer-name stx) - #`(λ args (apply f args))))))))))])) + #`(syntax-parameterize + ((making-a-method #f)) + (build-->d mtd? + (list (λ (dom-params ...) mandatory-doms) ...) + (list (λ (dom-params ...) optional-doms) ...) + (list (λ (dom-params ...) mandatory-kwd-dom) ...) + (list (λ (dom-params ...) optional-kwd-dom) ...) + #,(if id/rest + (with-syntax ([(id rst-ctc) id/rest]) + #`(λ (dom-params ...) rst-ctc)) + #f) + #,(if pre-cond + #`(λ (dom-params ...) #,pre-cond) + #f) + #,(syntax-case #'rng-ctcs () + [#f #f] + [(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)]) + #,(if post-cond + #`(λ (rng-params ... dom-params ...) #,post-cond) + #f) + '(mandatory-kwd ...) + '(optional-kwd ...) + (λ (f) + #,(add-name-prop + (syntax-local-infer-name stx) + #`(λ args (apply f args)))))))))))])) (define (->d-proj ->d-stct) (let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct)) - (length (->d-optional-dom-ctcs ->d-stct)))]) + (length (->d-optional-dom-ctcs ->d-stct)) + (if (->d-mtd? ->d-stct) 1 0))]) (λ (pos-blame neg-blame src-info orig-str) (λ (val) (check-procedure val + (->d-mtd? ->d-stct) (length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length (->d-mandatory-keywords ->d-stct) (->d-optional-keywords ->d-stct) src-info pos-blame orig-str) (let ([kwd-proc - (λ (kwd-args kwd-arg-vals . orig-args) - (let* ([dep-pre-args - (build-dep-ctc-args non-kwd-ctc-count orig-args (->d-rest-ctc ->d-stct) + (λ (kwd-args kwd-arg-vals . raw-orig-args) + (let* ([orig-args (if (->d-mtd? ->d-stct) + (cdr raw-orig-args) + raw-orig-args)] + [this (and (->d-mtd? ->d-stct) (car raw-orig-args))] + [dep-pre-args + (build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct) (->d-keywords ->d-stct) kwd-args kwd-arg-vals)] [thnk (λ () @@ -808,34 +854,41 @@ v4 todo: (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))])) - ;; contracted ordinary arguments - (let loop ([args orig-args] - [non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct) - (->d-optional-dom-ctcs ->d-stct))]) - (cond - [(null? args) - (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str) - '())] - [(null? non-kwd-ctcs) - (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str) - - ;; ran out of arguments, but don't have a rest parameter. - ;; procedure-reduce-arity (or whatever the new thing is - ;; going to be called) should ensure this doesn't happen. - (error 'shouldnt\ happen))] - [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str) - (loop (cdr args) - (cdr non-kwd-ctcs)))]))))]) + (append + ;; this parameter (if necc.) + (if (->d-mtd? ->d-stct) + (list (car raw-orig-args)) + '()) + + ;; contracted ordinary arguments + (let loop ([args orig-args] + [non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct) + (->d-optional-dom-ctcs ->d-stct))]) + (cond + [(null? args) + (if (->d-rest-ctc ->d-stct) + (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str) + '())] + [(null? non-kwd-ctcs) + (if (->d-rest-ctc ->d-stct) + (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str) + + ;; ran out of arguments, but don't have a rest parameter. + ;; procedure-reduce-arity (or whatever the new thing is + ;; going to be called) should ensure this doesn't happen. + (error 'shouldnt\ happen))] + [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str) + (loop (cdr args) + (cdr non-kwd-ctcs)))])))))]) (if (->d-range ->d-stct) (call-with-values thnk (λ orig-results (let* ([range-count (length (->d-range ->d-stct))] - [post-args (append orig-results orig-args)] + [post-args (append orig-results raw-orig-args)] [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] - [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count post-args (->d-rest-ctc ->d-stct) + [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count + post-args (->d-rest-ctc ->d-stct) (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) (when (->d-post-cond ->d-stct) (unless (apply (->d-post-cond ->d-stct) dep-post-args) @@ -877,7 +930,7 @@ v4 todo: (define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args) (append - ;; ordinary args + ;; ordinary args (possibly including `this' as the first element) (let loop ([count non-kwd-ctc-count] [args args]) (cond @@ -903,7 +956,8 @@ v4 todo: (define-struct unsupplied-arg ()) (define the-unsupplied-arg (make-unsupplied-arg)) -(define (build-->d mandatory-dom-ctcs optional-dom-ctcs +(define (build-->d mtd? + mandatory-dom-ctcs optional-dom-ctcs mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs rest-ctc pre-cond range post-cond mandatory-kwds optional-kwds @@ -913,7 +967,8 @@ v4 todo: (append mandatory-kwds optional-kwds) (append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs)) (λ (x y) (keywordd mandatory-dom-ctcs optional-dom-ctcs + (make-->d mtd? + mandatory-dom-ctcs optional-dom-ctcs (map cdr kwd/ctc-pairs) rest-ctc pre-cond range post-cond (map car kwd/ctc-pairs) @@ -921,7 +976,8 @@ v4 todo: optional-kwds name-wrapper))) -(define-struct/prop ->d (mandatory-dom-ctcs ;; (listof (-> ??? ctc)) +(define-struct/prop ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes. + mandatory-dom-ctcs ;; (listof (-> ??? ctc)) optional-dom-ctcs ;; (listof (-> ??? ctc)) keyword-ctcs ;; (listof (-> ??? ctc)) rest-ctc ;; (or/c false/c (-> ??? ctc)) @@ -955,7 +1011,7 @@ v4 todo: (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc)) ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc)))) ,@(if (->d-rest-ctc ctc) - (list (next-id) '...) + (list '#:rest (next-id) '...) '()) ,@(if (->d-pre-cond ctc) (list '#:pre-cond '...) @@ -1018,14 +1074,18 @@ v4 todo: [(rst-formal) (generate-temporaries '(rest-param))] [(rng-id ...) (if rng (generate-temporaries rng) - '())]) + '())] + [(this-parameter ...) + (if (syntax-parameter-value #'making-a-method) + (generate-temporaries '(this)) + '())]) #`(#,doms #,rst #,(if rng #`(list #,@rng) #f) #,(length (syntax->list doms)) ;; spec (dom-proj-x ... #,@(if rst #'(rst-proj-x) #'())) (rng-proj-x ...) - (dom-formals ... . #,(if rst #'rst-formal '())) + (this-parameter ... dom-formals ... . #,(if rst #'rst-formal '())) #,(cond [rng (with-syntax ([(rng-exp ...) #'((rng-proj-x rng-id) ...)]) @@ -1033,14 +1093,14 @@ v4 todo: (car (syntax->list #'(rng-exp ...))) #`(values rng-exp ...))]) (if rst - #`(let-values ([(rng-id ...) (apply f (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))]) + #`(let-values ([(rng-id ...) (apply f this-parameter ... (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))]) rng) - #`(let-values ([(rng-id ...) (f (dom-proj-x dom-formals) ...)]) + #`(let-values ([(rng-id ...) (f this-parameter ... (dom-proj-x dom-formals) ...)]) rng))))] [rst - #`(apply f (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))] + #`(apply f this-parameter ... (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))] [else - #`(f (dom-proj-x dom-formals) ...)])))))) + #`(f this-parameter ... (dom-proj-x dom-formals) ...)])))))) (define-syntax (case-> stx) (syntax-case stx () @@ -1055,17 +1115,19 @@ v4 todo: formals body) ...) (map (λ (x) (parse-out-case stx x)) (syntax->list #'(cases ...)))]) - #`(build-case-> (list (list dom-proj ...) ...) - (list rst-proj ...) - (list rng-proj ...) - '(spec ...) - (λ (chk - #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) - #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) - (λ (f) - (chk f) - (case-lambda - [formals body] ...))))))])) + #`(syntax-parameterize + ((making-a-method #f)) + (build-case-> (list (list dom-proj ...) ...) + (list rst-proj ...) + (list rng-proj ...) + '(spec ...) + (λ (chk + #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) + #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) + (λ (f) + (chk f #,(syntax-parameter-value #'making-a-method)) + (case-lambda + [formals body] ...)))))))])) ;; dom-ctcs : (listof (listof contract)) ;; rst-ctcs : (listof contract) @@ -1084,7 +1146,7 @@ v4 todo: (let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str)) dom-ctcs) (map (λ (f) (f pos-blame neg-blame src-info orig-str)) rng-ctcs))] [chk - (λ (val) + (λ (val mtd?) (cond [(null? specs) (unless (procedure? val) @@ -1097,8 +1159,8 @@ v4 todo: (for-each (λ (dom-length has-rest?) (if has-rest? - (check-procedure/more val dom-length '() '() src-info pos-blame orig-str) - (check-procedure val dom-length 0 '() '() src-info pos-blame orig-str))) + (check-procedure/more val mtd? dom-length '() '() src-info pos-blame orig-str) + (check-procedure val mtd? dom-length 0 '() '() src-info pos-blame orig-str))) specs rst-ctcs)]))]) (apply (case->-wrapper ctc) chk @@ -1123,7 +1185,7 @@ v4 todo: (case->-dom-ctcs ctc) (case->-rst-ctcs ctc) (case->-rng-ctcs ctc))))) - (first-order-prop (λ (ctc) #f)) + (first-order-prop (λ (ctc) (λ (val) #f))) (stronger-prop (λ (this that) #f)))) (define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper) @@ -1143,3 +1205,203 @@ v4 todo: (case->-rst-ctcs ctc)))) (define (get-case->-rng-ctcs ctc) (apply append (case->-rng-ctcs ctc))) + + +; +; +; +; ;;;; ;;;; +; ;;;; ;;;; +; ;;;;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;; ;;; ;;; ;;;;; ;;;; ;;; ;;;;; +; ;;;;;;;; ;;;;;;; ;;;;;;; ;;;;;; ;;;;;;;;; ;;;;; ;;;;;; ;;;; ;;; ;;;;;; +; ;;;; ;;;; ;; ;;;; ;; ;;;;;;; ;;;; ;;;; ;;;; ;; ;;;;;;; ;;;;;;; ;;;; +; ;;;;;;; ;;;; ;;;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;;;;; ;;;; +; ;; ;;;; ;;;; ;;;; ;;;;;;; ;;;; ;;;; ;;;;; ;;;;;;; ;;;; ;;; ;;;; +; ;;;;;;;; ;;;; ;;;; ;;;;;; ;;;; ;;;; ;;;;;; ;;;;;; ;;;; ;;; ;;;;;; +; ;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;;; ;;;; ;;;;; ;;;; ;;; ;;;;; +; +; +; + +;; ---------------------------------------- +;; 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 (get-mandatory-keywords f) + (let-values ([(mandatory optional) (procedure-keywords f)]) + mandatory)) + +(define (no-mandatory-keywords? f) + (let-values ([(mandatory optional) (procedure-keywords f)]) + (null? mandatory))) + +(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str) + (unless (and (procedure? val) + (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) + (keywords-match mandatory-kwds optional-keywords val)) + (raise-contract-error + val + src-info + blame + orig-str + "expected a ~a that accepts ~a arguments~a, given: ~e" + (if mtd? "method" "procedure") + dom-length + (keyword-error-text mandatory-kwds) + val))) + +(define (procedure-arity-includes?/optionals f base optionals) + (cond + [(zero? optionals) (procedure-arity-includes? f base)] + [else (and (procedure-arity-includes? f (+ base optionals)) + (procedure-arity-includes?/optionals f base (- optionals 1)))])) + +(define (keywords-match mandatory-kwds optional-kwds val) + (let-values ([(proc-mandatory proc-all) (procedure-keywords val)]) + (and (equal? proc-mandatory mandatory-kwds) + (andmap (λ (kwd) (and (member kwd proc-all) + (not (member kwd proc-mandatory)))) + optional-kwds)))) + +(define (keyword-error-text mandatory-keywords) + (cond + [(null? mandatory-keywords) " without any keywords"] + [(null? (cdr mandatory-keywords)) + (format " and the keyword ~a" (car mandatory-keywords))] + [else + (format + " and the keywords ~a~a" + (car mandatory-keywords) + (apply string-append (map (λ (x) (format " ~a" x)) (cdr mandatory-keywords))))])) + +(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds src-info blame orig-str) + (unless (and (procedure? val) + (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) + (keywords-match mandatory-kwds optional-kwds val)) + (raise-contract-error + val + src-info + blame + orig-str + "expected a ~a that accepts ~a arguments and and arbitrarily more~a, given: ~e" + (if mtd? "method" "procedure") + dom-length + (keyword-error-text mandatory-kwds) + val))) + +;; timing & size tests + +#; +(begin + (require (prefix-in mz: mzlib/contract)) + (define (time-test f) + (time + (let loop ([n 2000]) + (unless (zero? n) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) (f 1) + (loop (- n 1)))))) + + (define (size stx) + (let ([sp (open-output-string)]) + (write (compile stx) sp) + (close-output-port sp) + (string-length (get-output-string sp)))) + + 'raw + (size #'(λ (x) x)) + (time-test (λ (x) x)) + + '-> + (size #'(-> number? number?)) + (time-test (contract (-> number? number?) (λ (x) x) 'pos 'neg)) + + 'mz:-> + (size #'(mz:-> number? number?)) + (time-test (contract (mz:-> number? number?) (λ (x) x) 'pos 'neg)) + + '->* + (size #'(->* (number?) () number?)) + (time-test (contract (->* (number?) () number?) (λ (x) x) 'pos 'neg)) + + 'mz:->* + (size #'(mz:->* (number?) any/c (number?))) + (time-test (contract (mz:->* (number?) any/c (number?)) (λ (x . y) x) 'pos 'neg)) + + 'case-> + (size #'(case-> (-> number? number?))) + (time-test (contract (case-> (-> number? number?)) (λ (x) x) 'pos 'neg)) + + 'mz:case-> + (size #'(mz:case-> (-> number? number?))) + (time-test (contract (mz:case-> (-> number? number?)) (λ (x) x) 'pos 'neg)) + + '->d + (size #'(->d ([x number?]) () [r number?])) + (time-test (contract (->d ([x number?]) () [r number?]) (λ (x) x) 'pos 'neg)) + + 'mz:->r + (size #'(mz:->r ([x number?]) number?)) + (time-test (contract (mz:->r ([x number?]) number?) (λ (x) x) 'pos 'neg)) + + 'object-contract + (size #'(object-contract [m (-> number? number?)])) + (time-test + (let ([o (contract (object-contract [m (-> number? number?)]) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg)]) + (λ (x) (send o m x)))) + + + 'mz:object-contract + (size #'(mz:object-contract [m (mz:-> number? number?)])) + (time-test + (let ([o (contract (mz:object-contract [m (mz:-> number? number?)]) + (new (class object% (define/public (m x) x) (super-new))) + 'pos + 'neg)]) + (λ (x) (send o m x))))) \ No newline at end of file diff --git a/collects/scheme/private/contract-object.ss b/collects/scheme/private/contract-object.ss index 47a47aaddc..7eddf38064 100644 --- a/collects/scheme/private/contract-object.ss +++ b/collects/scheme/private/contract-object.ss @@ -2,11 +2,9 @@ (require "contract-arrow.ss" "contract-guts.ss" "class-internal.ss" - "contract-arr-checks.ss") + scheme/stxparam) -(require (for-syntax scheme/base - "contract-helpers.ss" - "contract-arr-obj-helpers.ss")) +(require (for-syntax scheme/base)) (provide mixin-contract make-mixin-contract @@ -15,396 +13,127 @@ implementation?/c object-contract) -(define-syntax object-contract - (let () - (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 select/h)) - - ;; WARNING: select/h is copied from contract-arrow.ss. I'm not sure how - ;; I can avoid this duplication -robby - (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)])) - - - (define (obj-opt->/proc stx) (make-opt->/proc #t stx select/h #'case-> #'->)) - (define (obj-opt->*/proc stx) (make-opt->*/proc #t stx stx select/h #'case-> #'->)) - - (λ (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 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 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 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 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) - - (define (last-pair l) - (cond - [(not (pair? (cdr l))) l] - [else (last-pair (cdr l))])) - - (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->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)))))))])))) +;; example of how one contract is constructed +#; +(let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))] + [cf (-> integer? integer?)] + [m-proj (((proj-get cm) cm) 'pos 'neg #'here "whatever")] + [f-proj (((proj-get cf) cf) 'pos 'neg #'here "whatever")] + [cls (make-wrapper-class 'wrapper-class + '(m) + (list + (m-proj (λ (this x) (send (wrapper-object-wrapped this) m x)))) + '(f) + #f)] + [o (new (class object% + (field [f (λ (x) x)]) + (define/public (m x) x) + (super-new)))] + [wo (make-object cls o (f-proj (get-field/proc 'f o)))]) + ((get-field/proc 'f wo) #f)) +(define-for-syntax (parse-object-contract stx args) + (let loop ([args (syntax->list args)] + [mtds '()] + [flds '()]) + (cond + [(null? args) (list mtds flds)] + [else (syntax-case (car args) (field) + [(field id ctc) + (identifier? #'id) + (loop (cdr args) mtds (cons #'(id ctc) flds))] + [(field . rst) + (raise-syntax-error #f "malformed field specification" stx (car args))] + [(id ctc) + (identifier? #'id) + (loop (cdr args) (cons #`(id ctc) mtds) flds)] + [_ + (raise-syntax-error #f "malformed object-contract clause" stx (car args))])]))) -(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-struct/prop object-contract (methods method-ctcs method-wrappers fields field-ctcs) + ((proj-prop + (λ (ctc) + (let ([meth-names (object-contract-methods ctc)] + [meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))] + [ctc-field-names (object-contract-fields ctc)] + [field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))]) + (λ (pos-blame neg-blame src-info orig-str) + (let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str)) + meth-param-projs)] + [meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))] + [cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)] + [field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str)) field-param-projs)]) + (λ (val) + + (unless (object? val) + (raise-contract-error val src-info pos-blame orig-str + "expected an object, got ~e" + val)) + + (let ([objs-mtds (interface->method-names (object-interface val))] + [vtable (extract-vtable val)] + [method-ht (extract-method-ht val)]) + (for-each (λ (m proj) + (let ([index (hash-table-get method-ht m #f)]) + (unless index + (raise-contract-error val src-info pos-blame orig-str + "expected an object with method ~s" + m)) + ;; verify the first-order properties by apply the projection and + ;; throwing the result away. Without this, the contract wrappers + ;; just check the first-order properties of the wrappers, which is + ;; the wrong thing. + (proj (vector-ref vtable index)))) + meth-names + meth-projs)) + + (let ([fields (field-names val)]) + (for-each (λ (f) + (unless (memq f fields) + (raise-contract-error val src-info pos-blame orig-str + "expected an object with field ~s" + f))) + ctc-field-names)) -(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))) + (apply make-object cls val + (map (λ (field proj) (proj (get-field/proc field val))) + ctc-field-names field-projs)))))))) + (name-prop (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) + (object-contract-fields ctc) + (object-contract-field-ctcs ctc)) + ,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc)) + (object-contract-methods ctc) + (object-contract-method-ctcs ctc))))) + (first-order-prop (λ (ctc) (λ (val) #f))) + (stronger-prop (λ (this that) #f)))) -(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-syntax (object-contract stx) + (syntax-case stx () + [(_ spec ...) + (with-syntax ([(((method-id method-ctc) ...) + ((field-id field-ctc) ...)) + (parse-object-contract stx #'(spec ...))]) + (with-syntax ([(method-name ...) (map (λ (x) (string->symbol (format "~a method" (syntax-e x)))) + (syntax->list #'(method-id ...)))]) + #'(build-object-contract '(method-id ...) + (syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...)) + (list (λ (this . x) (send (wrapper-object-wrapped this) method-id . x)) ...) + '(field-id ...) + (list field-ctc ...))))])) + +(define (build-object-contract methods method-ctcs wrappers fields field-ctcs) + (make-object-contract methods + (map (λ (x) (coerce-contract 'object-contract x)) method-ctcs) + wrappers + fields + (map (λ (x) (coerce-contract 'object-contract x)) field-ctcs))) -(define-syntax (old->d stx) (make-/proc #f ->d/h stx)) ;; just here for now so the mixin contracts work. (define (make-mixin-contract . %/<%>s) - ((and/c (flat-contract class?) - (apply and/c (map sub/impl?/c %/<%>s))) - . old->d . - subclass?/c)) + (->d ([c% (and/c (flat-contract class?) + (apply and/c (map sub/impl?/c %/<%>s)))]) + () + [res (subclass?/c c%)])) (define (subclass?/c %) (unless (class? %) @@ -442,4 +171,4 @@ [else `(is-a?/c unknown<%>)]) (lambda (x) (is-a? x <%>))))) -(define mixin-contract (class? . old->d . subclass?/c)) +(define mixin-contract (->d ([c% class?]) () [res (subclass?/c c%)])) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index b3db0d16a6..37070f2f93 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1358,7 +1358,7 @@ resulting trait is the same as for @scheme[trait-sum], otherwise the @section{Object and Class Contracts} @defform/subs[ -#:literals (field opt-> opt->* case-> -> ->* ->d ->d* ->r ->pp ->pp-rest) +#:literals (field -> ->* ->d) (object-contract member-spec ...) @@ -1367,49 +1367,42 @@ resulting trait is the same as for @scheme[trait-sum], otherwise the (field field-id contract-expr)] [method-contract - (opt-> (required-contract-expr ...) - (optional-contract-expr ...) - any) - (opt-> (required-contract-expr ...) - (optional-contract-expr ...) - result-contract-expr) - (opt->* (required-contract-expr ...) - (optional-contract-expr ...) - (result-contract-expr ...)) - (case-> arrow-contract ...) - arrow-contract] + (-> dom ... range) + (->* (mandatory-dom ...) + (optional-dom ...) + rest + range) + (->d (mandatory-dependent-dom ...) + (optional-dependent-dom ...) + dependent-rest + pre-cond + dep-range)] - [arrow-contract - (-> expr ... res-expr) - (-> expr ... (values res-expr ...)) - (->* (expr ...) (res-expr ...)) - (->* (expr ...) rest-expr (res-expr ...)) - (->d expr ... res-proc-expr) - (->d* (expr ...) res-proc-expr) - (->d* (expr ...) rest-expr res-gen-expr) - (->r ((id expr) ...) expr) - (->r ((id expr) ...) id expr expr) - (->pp ((id expr) ...) pre-expr - res-expr res-id post-expr) - (->pp ((id expr) ...) pre-expr any) - (->pp ((id expr) ...) pre-expr - (values (id expr) ...) post-expr) - (->pp-rest ((id expr) ...) id expr pre-expr - res-expr res-id post-expr) - (->pp-rest ((id expr) ...) id expr pre-expr any) - (->pp-rest ((id expr) ...) id expr pre-expr - (values (id expr) ...) post-expr)])]{ + [dom dom-expr (code:line keyword dom-expr)] + [range range-expr (values range-expr ...) any] + [mandatory-dom dom-expr (code:line keyword dom-expr)] + [optional-dom dom-expr (code:line keyword dom-expr)] + [rest (code:line) (code:line #:rest rest-expr)] + [mandatory-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])] + [optional-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])] + [dependent-rest (code:line) (code:line #:rest id rest-expr)] + [pre-cond (code:line) (code:line #:pre-cond boolean-expr)] + [dep-range any + (code:line [id range-expr] post-cond) + (code:line (values [id range-expr] ...) post-cond)] + [post-cond (code:line) (code:line #:post-cond boolean-expr)] +)]{ Produces a contract for an object. -Each of the contracts for a method has the same semantics as the -corresponding function contract, but the syntax of the method contract -must be written directly in the body of the object-contract---much -like the way that methods in class definitions use the same syntax as -regular function definitions, but cannot be arbitrary procedures. The -only exception is that the @scheme[->r], @scheme[->pp], and -@scheme[->pp-rest] contracts implicitly bind @scheme[this] to the -object itself.} +Each of the contracts for a method has the same semantics as +the corresponding function contract, but the syntax of the +method contract must be written directly in the body of the +object-contract---much like the way that methods in class +definitions use the same syntax as regular function +definitions, but cannot be arbitrary procedures. The only +exception is that @scheme[->d] contracts implicitly bind +@scheme[this] to the object itself.} @defthing[mixin-contract contract?]{ diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 86d997c2e1..4f4adcfb49 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -290,6 +290,12 @@ The @scheme[any] form can only be used in a result position of contracts like @scheme[->]. Using @scheme[any] elsewhere is a syntax error.} +@defform[(promise/c expr)]{ + +Constructs a contract on a promise. The contract does not force the +promise, but when the promise is forced, the contract checks that the +result value meets the contract produced by @scheme[expr].} + @; ------------------------------------------------------------------------ @section{Function Contracts} @@ -308,7 +314,11 @@ because it requires delaying the evaluation of the contract expressions for the domain and range until the function itself is called or returns. -The @scheme[case->] contract ... +The @scheme[case->] contract is a specialized contract, +designed to match @scheme[case-lambda] and +@scheme[unconstrained-domain->] allows range checking +without requiring that the domain have any particular shape +(see below for an exmaple use). @defform*/subs[#:literals (any values) [(-> dom ... range)] @@ -359,10 +369,10 @@ each values must match its respective contract.} @defform*/subs[#:literals (any) - [(->* (mandatory-dom ...) (optional-dom ...) rest-expr range) - (->* (mandatory-dom ...) (optional-dom ...) range)] + [(->* (mandatory-dom ...) (optional-dom ...) rest range)] ([mandatory-dom dom-expr (code:line keyword dom-expr)] [optional-dom dom-expr (code:line keyword dom-expr)] + [rest (code:line) (code:line #:rest rest-expr)] [range range-expr (values range-expr ...) any])]{ The @scheme[->*] contract combinator produces contracts for @@ -388,12 +398,12 @@ symbols, and that return a symbol. @defform*/subs[#:literals (any values) [(->d (mandatory-dependent-dom ...) (optional-dependent-dom ...) - rest + dependent-rest pre-cond dep-range)] ([mandatory-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])] [optional-dependent-dom [id dom-expr] (code:line keyword [id dom-expr])] - [rest (code:line) (code:line id rest-expr)] + [dependent-rest (code:line) (code:line #:rest id rest-expr)] [pre-cond (code:line) (code:line #:pre-cond boolean-expr)] [dep-range any (code:line [id range-expr] post-cond) @@ -477,12 +487,6 @@ be blamed using the above contract: ]} -@defform[(promise/c expr)]{ - -Constructs a contract on a promise. The contract does not force the -promise, but when the promise is forced, the contract checks that the -result value meets the contract produced by @scheme[expr].} - @; ------------------------------------------------------------------------ @section{Lazy Data-structure Contracts} diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 89a230418a..09d2077653 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -10,6 +10,7 @@ (namespace-require '(for-syntax scheme/base)) (namespace-require '(for-template scheme/base)) (namespace-require 'scheme/contract) + (namespace-require '(only scheme/private/contract-arrow procedure-accepts-and-more?)) (namespace-require 'scheme/class) (namespace-require 'scheme/promise)) n)) @@ -144,7 +145,7 @@ (test/pos-blame 'contract-flat2 '(contract not #t 'pos 'neg)) - + ; ; @@ -169,17 +170,18 @@ (test/no-error '(-> (flat-contract integer?) any)) (test/no-error '(->* (integer?) () (values integer?))) - (test/no-error '(->* (integer?) () integer? integer?)) - (test/no-error '(->* (integer?) () integer? any)) + (test/no-error '(->* (integer?) () #:rest integer? integer?)) + (test/no-error '(->* (integer?) () #:rest integer? any)) (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?))) - (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?) (flat-contract integer?))) - (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?) + (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) (flat-contract integer?))) + (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) (values (flat-contract integer?) (flat-contract boolean?)))) - (test/no-error '(->* ((flat-contract integer?)) () (flat-contract integer?) any)) + (test/no-error '(->* ((flat-contract integer?)) () #:rest (flat-contract integer?) any)) (test/no-error '(->d ([x integer?]) ([y integer?]) any)) - (test/no-error '(->d ([x integer?]) ([y integer?]) (number? boolean?))) - (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) (number? boolean?))) + (test/no-error '(->d ([x integer?]) ([y integer?]) (values [a number?] [b boolean?]))) + (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) (range boolean?))) + (test/no-error '(->d ([x integer?] #:z [z integer?]) ([y integer?] #:w [w integer?]) #:rest rest any/c (range boolean?))) (test/no-error '(unconstrained-domain-> number?)) (test/no-error '(unconstrained-domain-> (flat-contract number?))) @@ -287,7 +289,7 @@ (test/spec-passed 'contract-arrow-star5 '(let-values ([(a b) ((contract (->* (integer?) () - (listof integer?) + #:rest (listof integer?) (values integer? integer?)) (lambda (x . y) (values x x)) 'pos @@ -297,7 +299,7 @@ (test/neg-blame 'contract-arrow-star6 - '((contract (->* (integer?) () (listof integer?) (values integer? integer?)) + '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) (lambda (x . y) (values x x)) 'pos 'neg) @@ -305,7 +307,7 @@ (test/pos-blame 'contract-arrow-star7 - '((contract (->* (integer?) () (listof integer?) (values integer? integer?)) + '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) (lambda (x . y) (values 1 #t)) 'pos 'neg) @@ -313,7 +315,7 @@ (test/pos-blame 'contract-arrow-star8 - '((contract (->* (integer?) () (listof integer?) (values integer? integer?)) + '((contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) (lambda (x) (values #t 1)) 'pos 'neg) @@ -321,7 +323,7 @@ (test/spec-passed 'contract-arrow-star9 - '((contract (->* (integer?) () (listof integer?) integer?) + '((contract (->* (integer?) () #:rest (listof integer?) integer?) (lambda (x . y) 1) 'pos 'neg) @@ -329,7 +331,7 @@ (test/neg-blame 'contract-arrow-star10 - '((contract (->* (integer?) () (listof integer?) integer?) + '((contract (->* (integer?) () #:rest (listof integer?) integer?) (lambda (x . y) 1) 'pos 'neg) @@ -338,7 +340,7 @@ (test/spec-passed 'contract-arrow-star11 '(let-values ([(a b) ((contract (->* (integer?) () - (listof integer?) + #:rest (listof integer?) any) (lambda (x . y) (values x x)) 'pos @@ -349,7 +351,7 @@ (test/pos-blame 'contract-arrow-star11b '(let-values ([(a b) ((contract (->* (integer?) () - (listof integer?) + #:rest (listof integer?) any) (lambda (x) (values x x)) 'pos @@ -359,7 +361,7 @@ (test/neg-blame 'contract-arrow-star12 - '((contract (->* (integer?) () (listof integer?) any) + '((contract (->* (integer?) () #:rest (listof integer?) any) (lambda (x . y) (values x x)) 'pos 'neg) @@ -367,7 +369,7 @@ (test/spec-passed 'contract-arrow-star13 - '((contract (->* (integer?) () (listof integer?) any) + '((contract (->* (integer?) () #:rest (listof integer?) any) (lambda (x . y) 1) 'pos 'neg) @@ -375,7 +377,7 @@ (test/neg-blame 'contract-arrow-star14 - '((contract (->* (integer?) () (listof integer?) any) + '((contract (->* (integer?) () #:rest (listof integer?) any) (lambda (x . y) 1) 'pos 'neg) @@ -408,63 +410,63 @@ (test/pos-blame 'contract-arrow-star-arity-check1 - '(contract (->* (integer?) () (listof integer?) (values integer? integer?)) + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) (lambda (x) (values 1 #t)) 'pos 'neg)) (test/pos-blame 'contract-arrow-star-arity-check2 - '(contract (->* (integer?) () (listof integer?) (values integer? integer?)) + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) (lambda (x y) (values 1 #t)) 'pos 'neg)) (test/pos-blame 'contract-arrow-star-arity-check3 - '(contract (->* (integer?) () (listof integer?) (values integer? integer?)) + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) (case-lambda [(x y) #f] [(x y . z) #t]) 'pos 'neg)) (test/spec-passed 'contract-arrow-star-arity-check4 - '(contract (->* (integer?) () (listof integer?) (values integer? integer?)) + '(contract (->* (integer?) () #:rest (listof integer?) (values integer? integer?)) (case-lambda [(x y) #f] [(x y . z) #t] [(x) #f]) 'pos 'neg)) (test/pos-blame 'contract-arrow-star-keyword1 - '(contract (->* (integer?) () (listof integer?) (values integer?)) + '(contract (->* (integer?) () #:rest (listof integer?) (values integer?)) (λ (x #:y y . args) x) 'pos 'neg)) (test/pos-blame 'contract-arrow-star-keyword2 - '(contract (->* (integer?) () (listof integer?) any) + '(contract (->* (integer?) () #:rest (listof integer?) any) (λ (x #:y y . args) x) 'pos 'neg)) (test/spec-passed 'contract-arrow-star-keyword3 - '(contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?)) + '(contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) (λ (x #:y y . args) x) 'pos 'neg)) (test/spec-passed 'contract-arrow-star-keyword4 - '(contract (->* (integer? #:y integer?) () (listof integer?) any) + '(contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) (λ (x #:y y . args) x) 'pos 'neg)) (test/neg-blame 'contract-arrow-star-keyword5 - '((contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?)) + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) (λ (x #:y y . args) x) 'pos 'neg) @@ -472,7 +474,7 @@ (test/neg-blame 'contract-arrow-star-keyword6 - '((contract (->* (integer? #:y integer?) () (listof integer?) any) + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) (λ (x #:y y . args) x) 'pos 'neg) @@ -480,7 +482,7 @@ (test/neg-blame 'contract-arrow-star-keyword7 - '((contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?)) + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) (λ (x #:y y . args) x) 'pos 'neg) @@ -488,7 +490,7 @@ (test/neg-blame 'contract-arrow-star-keyword8 - '((contract (->* (integer? #:y integer?) () (listof integer?) any) + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) (λ (x #:y y . args) x) 'pos 'neg) @@ -496,7 +498,7 @@ (test/spec-passed 'contract-arrow-star-keyword9 - '((contract (->* (integer? #:y integer?) () (listof integer?) (values integer? integer?)) + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) (values integer? integer?)) (λ (x #:y y . args) (values x x)) 'pos 'neg) @@ -504,7 +506,7 @@ (test/spec-passed 'contract-arrow-star-keyword10 - '((contract (->* (integer? #:y integer?) () (listof integer?) any) + '((contract (->* (integer? #:y integer?) () #:rest (listof integer?) any) (λ (x #:y y . args) (values x x)) 'pos 'neg) @@ -927,6 +929,25 @@ '((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; procedure accepts-and-more + ;; + + (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 3) + (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 2) + (ctest #t procedure-accepts-and-more? (lambda (x . y) 1) 1) + (ctest #f procedure-accepts-and-more? (lambda (x . y) 1) 0) + + (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 3) + (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 2) + (ctest #t procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 1) + (ctest #f procedure-accepts-and-more? (case-lambda [(x . y) 1] [(y) 1]) 0) + + (ctest #t procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 2) + (ctest #t procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 1) + (ctest #f procedure-accepts-and-more? (case-lambda [(x y . z) 1] [(x) 1]) 0) + ; ; @@ -986,51 +1007,51 @@ (test/spec-passed '->d11 - '((contract (->d () () rest any/c [r number?]) (lambda x 1) 'pos 'neg))) + '((contract (->d () () #:rest rest any/c [r number?]) (lambda x 1) 'pos 'neg))) (test/spec-passed '->d12 - '((contract (->d ([x number?]) () rest any/c [r number?]) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + '((contract (->d ([x number?]) () #:rest rest any/c [r number?]) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) (test/pos-blame '->d13 - '((contract (->d () () rest any/c [r number?]) 1 'pos 'neg))) + '((contract (->d () () #:rest rest any/c [r number?]) 1 'pos 'neg))) (test/pos-blame '->d14 - '((contract (->d () () rest any/c [r number?]) (lambda (x) x) 'pos 'neg))) + '((contract (->d () () #:rest rest any/c [r number?]) (lambda (x) x) 'pos 'neg))) (test/neg-blame '->d15 - '((contract (->d ([x number?]) () rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) + '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) (test/pos-blame '->d16 - '((contract (->d ([x number?]) () rest any/c [r (<=/c x)]) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + '((contract (->d ([x number?]) () #:rest rest any/c [r (<=/c x)]) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) (test/spec-passed '->d17 - '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c [r (<=/c x)]) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c [r (<=/c x)]) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) (test/neg-blame '->d18 - '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c [r (<=/c x)]) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c [r (<=/c x)]) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) (test/spec-passed '->d19 - '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c [r (<=/c x)]) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c [r (<=/c x)]) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) (test/neg-blame '->d20 - '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c [r (<=/c x)]) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c [r (<=/c x)]) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) (test/spec-passed '->d21 - '((contract (->d () () rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) 1)) + '((contract (->d () () #:rest rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) 1)) (test/neg-blame '->d22 - '((contract (->d () () rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) #f)) + '((contract (->d () () #:rest rst (listof number?) [r any/c]) (lambda w 1) 'pos 'neg) #f)) (test/spec-passed '->d-any1 @@ -1070,47 +1091,47 @@ (test/spec-passed '->d-any10 - '((contract (->d () () rest any/c any) (lambda x 1) 'pos 'neg))) + '((contract (->d () () #:rest rest any/c any) (lambda x 1) 'pos 'neg))) (test/spec-passed '->d-any11 - '((contract (->d ([x number?]) () rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) + '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) 1)) (test/pos-blame '->d-any12 - '((contract (->d () () rest any/c any) 1 'pos 'neg))) + '((contract (->d () () #:rest rest any/c any) 1 'pos 'neg))) (test/pos-blame '->d-any13 - '((contract (->d () () rest any/c any) (lambda (x) x) 'pos 'neg))) + '((contract (->d () () #:rest rest any/c any) (lambda (x) x) 'pos 'neg))) (test/neg-blame '->d-any14 - '((contract (->d ([x number?]) () rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) + '((contract (->d ([x number?]) () #:rest rest any/c any) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) (test/spec-passed '->d-any15 - '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c any) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c any) (lambda (x y . z) (- x 1)) 'pos 'neg) 1 0)) (test/neg-blame '->d-any16 - '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c any) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c any) (lambda (x y . z) (+ x 1)) 'pos 'neg) 1 2)) (test/spec-passed '->d-any17 - '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c any) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c any) (lambda (y x . z) (- x 1)) 'pos 'neg) 1 2)) (test/neg-blame '->d-any18 - '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c any) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c any) (lambda (y x . z) (+ x 1)) 'pos 'neg) 1 0)) (test/spec-passed '->d-any19 - '((contract (->d () () rst (listof number?) any) (lambda w 1) 'pos 'neg) 1)) + '((contract (->d () () #:rest rst (listof number?) any) (lambda w 1) 'pos 'neg) 1)) (test/neg-blame '->d-any20 - '((contract (->d () () rst (listof number?) any) (lambda w 1) 'pos 'neg) #f)) + '((contract (->d () () #:rest rst (listof number?) any) (lambda w 1) 'pos 'neg) #f)) (test/spec-passed '->d-values1 @@ -1171,11 +1192,11 @@ (test/spec-passed '->d-values11 - '((contract (->d () () rest any/c (values [z boolean?] [w number?])) (lambda x (values #f 1)) 'pos 'neg))) + '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) (lambda x (values #f 1)) 'pos 'neg))) (test/spec-passed '->d-values12 - '((contract (->d ([x number?]) () rest any/c (values [z boolean?] [w number?])) + '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w number?])) (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) @@ -1183,55 +1204,55 @@ (test/pos-blame '->d-values13 - '((contract (->d () () rest any/c (values [z boolean?] [w number?])) 1 'pos 'neg))) + '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) 1 'pos 'neg))) (test/pos-blame '->d-values14 - '((contract (->d () () rest any/c (values [z boolean?] [w number?])) (lambda (x) x) 'pos 'neg))) + '((contract (->d () () #:rest rest any/c (values [z boolean?] [w number?])) (lambda (x) x) 'pos 'neg))) (test/neg-blame '->d-values15 - '((contract (->d ([x number?]) () rest any/c (values [z boolean?] [w (<=/c x)])) + '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) (lambda (x . y) (+ x 1)) 'pos 'neg) #f)) (test/pos-blame '->d-values16 - '((contract (->d ([x number?]) () rest any/c (values [z boolean?] [w (<=/c x)])) + '((contract (->d ([x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) (lambda (x . y) (values #f (+ x 1))) 'pos 'neg) 1)) (test/spec-passed '->d-values17 - '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c (values [z boolean?] [w (<=/c x)])) + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) (lambda (x y . z) (values #f (- x 1))) 'pos 'neg) 1 0)) (test/neg-blame '->d-values18 - '((contract (->d ([x number?] [y (<=/c x)]) () rest any/c (values [z boolean?] [w (<=/c x)])) + '((contract (->d ([x number?] [y (<=/c x)]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) (lambda (x y . z) (values #f (+ x 1))) 'pos 'neg) 1 2)) (test/spec-passed '->d-values19 - '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c (values [z boolean?] [w (<=/c x)])) + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) (lambda (y x . z) (values #f (- x 1))) 'pos 'neg) 1 2)) (test/neg-blame '->d-values20 - '((contract (->d ([y (<=/c x)] [x number?]) () rest any/c (values [z boolean?] [w (<=/c x)])) + '((contract (->d ([y (<=/c x)] [x number?]) () #:rest rest any/c (values [z boolean?] [w (<=/c x)])) (lambda (y x . z) (values #f (+ x 1))) 'pos 'neg) 1 0)) (test/spec-passed '->d-values21 - '((contract (->d () () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) 1)) + '((contract (->d () () #:rest rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) 1)) (test/neg-blame '->d-values22 - '((contract (->d () () rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) #f)) + '((contract (->d () () #:rest rst (listof number?) (values [z boolean?] [w any/c])) (lambda w (values #f 1)) 'pos 'neg) #f)) (test/spec-passed '->d-values23 @@ -1284,7 +1305,7 @@ (test/spec-passed/result '->d26 - '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () rest-args any/c [r number?]) + '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () #:rest rest-args any/c [r number?]) (λ (i j . z) 1) 'pos 'neg) @@ -1294,7 +1315,7 @@ (test/spec-passed/result '->d27 - '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () rest-args any/c any) + '((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () #:rest rest-args any/c any) (λ (i j . z) 1) 'pos 'neg) @@ -1306,7 +1327,7 @@ '->d28 '(call-with-values (λ () - ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () rest-args any/c (values [x number?] [y number?])) + ((contract (->d ((i number?) (j (and/c number? (>=/c i)))) () #:rest rest-args any/c (values [x number?] [y number?])) (λ (i j . z) (values 1 2)) 'pos 'neg) @@ -1317,7 +1338,7 @@ (test/neg-blame '->d30 - '((contract (->d ([x number?]) () rst number? any) + '((contract (->d ([x number?]) () #:rest rst number? any) (λ (x . rst) (values 4 5)) 'pos 'neg))) @@ -1420,7 +1441,7 @@ (test/pos-blame '->d-pp-r1 - '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) (λ (x . rst) x) 'pos 'neg) @@ -1428,7 +1449,7 @@ (test/neg-blame '->d-pp-r2 - '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= x 2)) (λ (x . rst) x) 'pos 'neg) @@ -1436,7 +1457,7 @@ (test/pos-blame '->d-pp-r3 - '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) (λ (x . rst) x) 'pos 'neg) @@ -1444,7 +1465,7 @@ (test/spec-passed '->d-pp-r3.5 - '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) [result number?] #:post-cond (= result 2)) (λ (x . rst) 2) 'pos 'neg) @@ -1452,7 +1473,7 @@ (test/neg-blame '->d-pp-r4 - '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) any) + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) any) (λ (x . rst) x) 'pos 'neg) @@ -1460,7 +1481,7 @@ (test/neg-blame '->d-pp-r5 - '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= x y z 3)) + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= x y z 3)) (λ (x . rst) (values 4 5)) 'pos 'neg) @@ -1468,7 +1489,7 @@ (test/pos-blame '->d-pp-r6 - '((contract (->d ([x number?]) () rst any/c #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= z x y 3)) + '((contract (->d ([x number?]) () #:rest rst any/c #:pre-cond (= x 1) (values [z number?] [y number?]) #:post-cond (= z x y 3)) (λ (x . rst) (values 4 5)) 'pos 'neg) @@ -1493,7 +1514,7 @@ (test/spec-passed '->d-binding1 - '((contract (->d ([x number?]) () rest any/c [range any/c] #:post-cond (equal? rest '(2 3 4))) + '((contract (->d ([x number?]) () #:rest rest any/c [range any/c] #:post-cond (equal? rest '(2 3 4))) (λ (x . y) y) 'pos 'neg) @@ -1501,7 +1522,7 @@ (test/spec-passed '->d-binding2 - '((contract (->d ([x number?]) () rest any/c [range any/c] #:post-cond (equal? x 1)) + '((contract (->d ([x number?]) () #:rest rest any/c [range any/c] #:post-cond (equal? x 1)) (λ (x . y) y) 'pos 'neg) @@ -1514,7 +1535,7 @@ [r 'r]) ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) ([a number?] [b number?] #:c [c number?] #:d [d number?]) - rest any/c + #:rest rest any/c #:pre-cond (equal? (list x y z w a b c d rest p q r) (list 1 2 3 4 5 6 7 8 '(z) 'p 'q 'r)) (values [p number?] [q number?] [r number?])) @@ -1528,7 +1549,7 @@ '->d-binding4 '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) ([a number?] [b number?] #:c [c number?] #:d [d number?]) - rest any/c + #:rest rest any/c (values [p number?] [q number?] [r number?]) #:post-cond (equal? (list x y z w a b c d rest p q r) (list 1 2 3 4 5 6 7 8 '(z) 11 12 13))) @@ -1545,7 +1566,7 @@ [r 'r]) ((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) ([a number?] [b number?] #:c [c number?] #:d [d number?]) - rest any/c + #:rest rest any/c #:pre-cond (equal? (list x y z w a b c d rest p q r) (list 1 2 3 4 the-unsupplied-arg the-unsupplied-arg the-unsupplied-arg the-unsupplied-arg @@ -1561,7 +1582,7 @@ '->d-binding6 '((contract (->d ([x number?] [y number?] #:z [z number?] #:w [w number?]) ([a number?] [b number?] #:c [c number?] #:d [d number?]) - rest any/c + #:rest rest any/c (values [p number?] [q number?] [r number?]) #:post-cond (equal? (list x y z w a b c d rest p q r) (list 1 2 3 4 @@ -1578,7 +1599,7 @@ '->d-binding7 '((contract (->d () ([a number?]) - rest any/c + #:rest rest any/c any #:post-cond (equal? (list a rest) (list the-unsupplied-arg '()))) (λ ([a 1] . rest) 1) @@ -2031,7 +2052,6 @@ 'pos 'neg))) -#| ; ; @@ -2368,8 +2388,8 @@ 7) (test/pos-blame - 'object-contract-opt->*1 - '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*1 + '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a]) @@ -2379,8 +2399,8 @@ 'neg)) (test/pos-blame - 'object-contract-opt->*2 - '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*2 + '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x y [z #t]) @@ -2390,8 +2410,8 @@ 'neg)) (test/spec-passed - 'object-contract-opt->*3 - '(contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*3 + '(contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2401,8 +2421,8 @@ 'neg)) (test/spec-passed/result - 'object-contract-opt->*4 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*4 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2415,8 +2435,8 @@ 1) (test/spec-passed/result - 'object-contract-opt->*5 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*5 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2430,8 +2450,8 @@ 2) (test/spec-passed/result - 'object-contract-opt->*7 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*7 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2446,8 +2466,8 @@ 3) (test/neg-blame - 'object-contract-opt->*8 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*8 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2459,8 +2479,8 @@ #f)) (test/neg-blame - 'object-contract-opt->*9 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*9 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2473,8 +2493,8 @@ 4)) (test/neg-blame - 'object-contract-opt->*10 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*10 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2488,8 +2508,8 @@ 'y)) (test/pos-blame - 'object-contract-opt->*11 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number?)))) + 'object-contract->*11 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) number?))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2503,9 +2523,9 @@ #f)) (test/spec-passed/result - 'object-contract-opt->*12 + 'object-contract->*12 '(let-values ([(x y) - (send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?)))) + (send (contract (object-contract (m (->* (integer?) (symbol? boolean?) (values number? symbol?)))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2521,8 +2541,8 @@ (cons 1 'x)) (test/pos-blame - 'object-contract-opt->*13 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?)))) + 'object-contract->*13 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) (values number? symbol?)))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2536,8 +2556,8 @@ #f)) (test/pos-blame - 'object-contract-opt->*14 - '(send (contract (object-contract (m (opt->* (integer?) (symbol? boolean?) (number? symbol?)))) + 'object-contract->*14 + '(send (contract (object-contract (m (->* (integer?) (symbol? boolean?) (values number? symbol?)))) (new (class object% (define/public m (lambda (x [y 'a] [z #t]) @@ -2552,14 +2572,14 @@ (test/pos-blame 'object-contract->*1 - '(contract (object-contract (m (->* (integer?) (boolean?)))) + '(contract (object-contract (m (-> integer? boolean?))) (new (class object% (define/public (m x y) x) (super-new))) 'pos 'neg)) (test/neg-blame 'object-contract->*2 - '(send (contract (object-contract (m (->* (integer?) (boolean?)))) + '(send (contract (object-contract (m (-> integer? boolean?))) (new (class object% (define/public (m x) x) (super-new))) 'pos 'neg) @@ -2567,7 +2587,7 @@ (test/pos-blame 'object-contract->*3 - '(send (contract (object-contract (m (->* (integer?) (boolean?)))) + '(send (contract (object-contract (m (-> integer? boolean?))) (new (class object% (define/public (m x) x) (super-new))) 'pos 'neg) @@ -2575,7 +2595,7 @@ (test/spec-passed 'object-contract->*4 - '(send (contract (object-contract (m (->* (integer?) (boolean?)))) + '(send (contract (object-contract (m (-> integer? boolean?))) (new (class object% (define/public (m x) #f) (super-new))) 'pos 'neg) @@ -2583,14 +2603,14 @@ (test/pos-blame 'object-contract->*5 - '(contract (object-contract (m (->* (integer?) any/c (boolean?)))) + '(contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) (new (class object% (define/public (m x y . z) x) (super-new))) 'pos 'neg)) (test/neg-blame 'object-contract->*6 - '(send (contract (object-contract (m (->* (integer?) any/c (boolean?)))) + '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) (new (class object% (define/public (m x . z) x) (super-new))) 'pos 'neg) @@ -2598,7 +2618,7 @@ (test/pos-blame 'object-contract->*7 - '(send (contract (object-contract (m (->* (integer?) any/c (boolean?)))) + '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) (new (class object% (define/public (m x . z) 1) (super-new))) 'pos 'neg) @@ -2606,7 +2626,7 @@ (test/spec-passed 'object-contract->*8 - '(send (contract (object-contract (m (->* (integer?) any/c (boolean?)))) + '(send (contract (object-contract (m (->* (integer?) () #:rest any/c boolean?))) (new (class object% (define/public (m x . z) #f) (super-new))) 'pos 'neg) @@ -2614,7 +2634,7 @@ (test/spec-passed 'object-contract->*9 - '(send (contract (object-contract (m (->* () (listof number?) (boolean?)))) + '(send (contract (object-contract (m (->* () () #:rest (listof number?) boolean?))) (new (class object% (define/public (m . z) #f) (super-new))) 'pos 'neg) @@ -2622,173 +2642,16 @@ (test/neg-blame 'object-contract->*10 - '(send (contract (object-contract (m (->* () (listof number?) (boolean?)))) + '(send (contract (object-contract (m (->* () () #:rest (listof number?) boolean?))) (new (class object% (define/public (m . z) #f) (super-new))) 'pos 'neg) m #t)) - - (test/spec-passed - 'object-contract->d1 - '(contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x) 1) (super-new))) - 'pos - 'neg)) - - (test/neg-blame - 'object-contract->d2 - '(send (contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x) 1) (super-new))) - 'pos - 'neg) - m #f)) - - (test/pos-blame - 'object-contract->d3 - '(send (contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x) 1) (super-new))) - 'pos - 'neg) - m - 1)) - - (test/spec-passed - 'object-contract->d4 - '(send (contract (object-contract (m (->d integer? (lambda (x) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x) 1) (super-new))) - 'pos - 'neg) - m - 0)) - - (test/spec-passed - 'object-contract->d*1 - '(contract (object-contract (m (->d* (integer? integer?) - (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x y) 1) (super-new))) - 'pos - 'neg)) - - (test/neg-blame - 'object-contract->d*2 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x y) 1) (super-new))) - 'pos - 'neg) - m #f #f)) - - (test/neg-blame - 'object-contract->d*3 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x y) 1) (super-new))) - 'pos - 'neg) - m 1 1)) - - (test/pos-blame - 'object-contract->d*4 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x y) 1) (super-new))) - 'pos - 'neg) - m - 1 - #t)) - - (test/spec-passed - 'object-contract->d*5 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (lambda (x z) (lambda (y) (and (integer? y) (= y (+ x 1)))))))) - (new (class object% (define/public (m x y) 1) (super-new))) - 'pos - 'neg) - m - 0 - #t)) - - (test/spec-passed - 'object-contract->d*6 - '(contract (object-contract (m (->d* (integer? integer?) - any/c - (lambda (x z . rst) (lambda (y) - (= y (length rst))))))) - (new (class object% (define/public (m x y . z) 2) (super-new))) - 'pos - 'neg)) - - (test/neg-blame - 'object-contract->d*7 - '(send (contract (object-contract (m (->d* (integer? boolean?) - any/c - (lambda (x z . rst) (lambda (y) - (= y (length rst))))))) - (new (class object% (define/public (m x y . z) 2) (super-new))) - 'pos - 'neg) - m 1 1)) - - (test/neg-blame - 'object-contract->d*8 - '(send (contract (object-contract (m (->d* (integer? boolean?) - any/c - (lambda (x z . rst) (lambda (y) - (= y (length rst))))))) - (new (class object% (define/public (m x y . z) 2) (super-new))) - 'pos - 'neg) - m #t #t)) - - (test/neg-blame - 'object-contract->d*9 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (listof symbol?) - (lambda (x z . rst) (lambda (y) - (= y (length rst))))))) - (new (class object% (define/public (m x y . z) 2) (super-new))) - 'pos - 'neg) - m #t #t)) - - (test/neg-blame - 'object-contract->d*10 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (listof symbol?) - (lambda (x z . rst) (lambda (y) - (= y (length rst))))))) - (new (class object% (define/public (m x y . z) 2) (super-new))) - 'pos - 'neg) - m 1 #t #t)) - - (test/pos-blame - 'object-contract->d*11 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (listof symbol?) - (lambda (x z . rst) (lambda (y) - (= y (length rst))))))) - (new (class object% (define/public (m x y . z) 2) (super-new))) - 'pos - 'neg) - m 1 #t 'x)) - - (test/spec-passed - 'object-contract->d*12 - '(send (contract (object-contract (m (->d* (integer? boolean?) - (listof symbol?) - (lambda (x z . rst) (lambda (y) - (= y (length rst))))))) - (new (class object% (define/public (m x y . z) 2) (super-new))) - 'pos - 'neg) - m 1 #t 'x 'y)) (test/spec-passed - 'object-contract-->r1 - '(send (contract (object-contract (m (case-> (->r ([x number?]) (<=/c x))))) + 'object-contract-->d1 + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) 'pos 'neg) @@ -2796,18 +2659,17 @@ 1)) (test/spec-passed - 'object-contract-->r1b - '(send (contract (object-contract (m (case-> (->r ([x number?]) (<=/c x)) - (-> integer? integer? integer?)))) - (new (class object% (define/public m (case-lambda [(x) (- x 1)] [(x y) x])) (super-new))) + 'object-contract-->d1b + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) 'pos 'neg) m 1)) (test/pos-blame - 'object-contract-->r2 - '(send (contract (object-contract (m (case-> (->r ([x number?]) (<=/c x))))) + 'object-contract-->d2 + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) 'pos 'neg) @@ -2815,17 +2677,17 @@ 1)) (test/pos-blame - 'object-contract-->r2b - '(send (contract (object-contract (m (case-> (->r ([x number?]) (<=/c x)) (-> integer? integer? integer?)))) - (new (class object% (define/public m (case-lambda [(x) (+ x 1)] [(x y) y])) (super-new))) + 'object-contract-->d2b + '(send (contract (object-contract (m (->d ([x number?]) () [range (<=/c x)]))) + (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) 'pos 'neg) m 1)) (test/spec-passed - 'object-contract-->r3 - '(send (contract (object-contract (m (->r () rst (listof number?) any/c))) + 'object-contract-->d3 + '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) [range any/c]))) (new (class object% (define/public m (lambda w 1)) (super-new))) 'pos 'neg) @@ -2833,8 +2695,8 @@ 1)) (test/neg-blame - 'object-contract-->r4 - '(send (contract (object-contract (m (->r () rst (listof number?) any/c))) + 'object-contract-->d4 + '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) [range any/c]))) (new (class object% (define/public m (lambda w 1)) (super-new))) 'pos 'neg) @@ -2842,32 +2704,33 @@ #f)) (test/spec-passed - 'object-contract-->r5 - '(send (contract (object-contract (m (->r () any))) + 'object-contract-->d5 + '(send (contract (object-contract (m (->d () () any))) (new (class object% (define/public m (lambda () 1)) (super-new))) 'pos 'neg) m)) (test/spec-passed - 'object-contract-->r6 - '(send (contract (object-contract (m (->r () (values [x number?] [y (>=/c x)])))) + 'object-contract-->d6 + '(send (contract (object-contract (m (->d () () (values [x number?] [y (>=/c x)])))) (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) 'pos 'neg) m)) - + (test/pos-blame - 'object-contract-->r7 - '(send (contract (object-contract (m (->r () (values [x number?] [y (>=/c x)])))) + 'object-contract-->d7 + '(send (contract (object-contract (m (->d () () (values [x number?] [y (>=/c x)])))) (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) 'pos 'neg) m)) (test/neg-blame - 'object-contract-->r/this-1 - '(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + 'object-contract-->d/this-1 + '(send (contract (object-contract (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () any))) (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) 'pos @@ -2876,8 +2739,9 @@ 2)) (test/spec-passed - 'object-contract-->r/this-2 - '(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + 'object-contract-->d/this-2 + '(send (contract (object-contract (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () any))) (new (class object% (field [f 1]) (define/public m (lambda (x) 1)) (super-new))) 'pos @@ -2886,9 +2750,10 @@ 1)) (test/neg-blame - 'object-contract-->r/this-3 - '(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) - rest-var any/c + 'object-contract-->d/this-3 + '(send (contract (object-contract (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () + #:rest rest-var any/c any))) (new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) (super-new))) 'pos @@ -2897,9 +2762,10 @@ 2)) (test/spec-passed - 'object-contract-->r/this-4 - '(send (contract (object-contract (m (->r ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) - rest-var any/c + 'object-contract-->d/this-4 + '(send (contract (object-contract (m (->d ([x (and/c integer? (lambda (x) (= x (get-field f this))))]) + () + #:rest rest-var any/c any))) (new (class object% (field [f 1]) (define/public m (lambda (x . rest) 1)) (super-new))) 'pos @@ -2909,7 +2775,7 @@ (test/spec-passed 'object-contract-->pp1 - '(send (contract (object-contract (m (case-> (->pp ([x number?]) #t (<=/c x) unused #t)))) + '(send (contract (object-contract (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) (new (class object% (define/public m (lambda (x) (- x 1))) (super-new))) 'pos 'neg) @@ -2918,8 +2784,7 @@ (test/spec-passed 'object-contract-->pp1b - '(send (contract (object-contract (m (case-> (->pp ([x number?]) #t (<=/c x) unused #t) - (-> integer? integer? integer?)))) + '(send (contract (object-contract (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) (new (class object% (define/public m (case-lambda [(x) (- x 1)] [(x y) y])) @@ -2931,7 +2796,7 @@ (test/pos-blame 'object-contract-->pp2 - '(send (contract (object-contract (m (case-> (->pp ([x number?]) #t (<=/c x) unused #t)))) + '(send (contract (object-contract (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) (new (class object% (define/public m (lambda (x) (+ x 1))) (super-new))) 'pos 'neg) @@ -2940,12 +2805,9 @@ (test/pos-blame 'object-contract-->pp2b - '(send (contract (object-contract (m (case-> (->pp ([x number?]) #t (<=/c x) unused #t) - (-> integer? integer? integer?)))) + '(send (contract (object-contract (m (->d ([x number?]) () #:pre-cond #t [unused (<=/c x)] #:post-cond #t))) (new (class object% - (define/public m (case-lambda - [(x) (+ x 1)] - [(x y) x])) + (define/public m (case-lambda [(x) (+ x 1)])) (super-new))) 'pos 'neg) @@ -2954,7 +2816,7 @@ (test/spec-passed 'object-contract-->pp3 - '(send (contract (object-contract (m (->pp-rest () rst (listof number?) #t any/c unused #t))) + '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) #:pre-cond #t [unused any/c] #:post-cond #t))) (new (class object% (define/public m (lambda w 1)) (super-new))) 'pos 'neg) @@ -2963,7 +2825,7 @@ (test/neg-blame 'object-contract-->pp4 - '(send (contract (object-contract (m (->pp-rest () rst (listof number?) #t any/c unused #t))) + '(send (contract (object-contract (m (->d () () #:rest rst (listof number?) #:pre-cond #t [unused any/c] #:post-cond #t))) (new (class object% (define/public m (lambda w 1)) (super-new))) 'pos 'neg) @@ -2972,7 +2834,7 @@ (test/spec-passed 'object-contract-->pp5 - '(send (contract (object-contract (m (->pp () #t any))) + '(send (contract (object-contract (m (->d () () #:pre-cond #t any))) (new (class object% (define/public m (lambda () 1)) (super-new))) 'pos 'neg) @@ -2980,7 +2842,7 @@ (test/spec-passed 'object-contract-->pp6 - '(send (contract (object-contract (m (->pp () #t (values [x number?] [y (>=/c x)]) #t))) + '(send (contract (object-contract (m (->d () () #:pre-cond #t (values [x number?] [y (>=/c x)]) #:post-cond #t))) (new (class object% (define/public m (lambda () (values 1 2))) (super-new))) 'pos 'neg) @@ -2988,19 +2850,19 @@ (test/pos-blame 'object-contract-->pp7 - '(send (contract (object-contract (m (->pp () #t (values [x number?] [y (>=/c x)]) #t))) + '(send (contract (object-contract (m (->d () () #:pre-cond #t (values [x number?] [y (>=/c x)]) #:post-cond #t))) (new (class object% (define/public m (lambda () (values 2 1))) (super-new))) 'pos 'neg) m)) - + (test/neg-blame 'object-contract-->pp/this-1 - '(send (contract (object-contract (m (->pp () - (= 1 (get-field f this)) - any/c - result-x - (= 2 (get-field f this))))) + '(send (contract (object-contract (m (->d () + () + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) (new (class object% (field [f 2]) (define/public m (lambda () (set! f 3))) (super-new))) 'pos 'neg) @@ -3008,11 +2870,10 @@ (test/pos-blame 'object-contract-->pp/this-2 - '(send (contract (object-contract (m (->pp () - (= 1 (get-field f this)) - any/c - result-x - (= 2 (get-field f this))))) + '(send (contract (object-contract (m (->d () () + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) (new (class object% (field [f 1]) (define/public m (lambda () (set! f 3))) (super-new))) 'pos 'neg) @@ -3020,11 +2881,10 @@ (test/spec-passed 'object-contract-->pp/this-3 - '(send (contract (object-contract (m (->pp () - (= 1 (get-field f this)) - any/c - result-x - (= 2 (get-field f this))))) + '(send (contract (object-contract (m (->d () () + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) (new (class object% (field [f 1]) (define/public m (lambda () (set! f 2))) (super-new))) 'pos 'neg) @@ -3032,13 +2892,11 @@ (test/neg-blame 'object-contract-->pp/this-4 - '(send (contract (object-contract (m (->pp-rest () - rest-id - any/c - (= 1 (get-field f this)) - any/c - result-x - (= 2 (get-field f this))))) + '(send (contract (object-contract (m (->d () () + #:rest rest-id any/c + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) (new (class object% (field [f 2]) (define/public m (lambda args (set! f 3))) (super-new))) 'pos 'neg) @@ -3046,29 +2904,23 @@ (test/pos-blame 'object-contract-->pp/this-5 - '(send (contract (object-contract (m (->pp-rest () - rest-id - any/c - (= 1 (get-field f this)) - any/c - result-x - (= 2 (get-field f this))))) + '(send (contract (object-contract (m (->d () () + #:rest rest-id any/c + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) (new (class object% (field [f 1]) (define/public m (lambda args (set! f 3))) (super-new))) 'pos 'neg) m)) - - (test/spec-passed 'object-contract-->pp/this-6 - '(send (contract (object-contract (m (->pp-rest () - rest-id - any/c - (= 1 (get-field f this)) - any/c - result-x - (= 2 (get-field f this))))) + '(send (contract (object-contract (m (->d () () + #:rest rest-id any/c + #:pre-cond (= 1 (get-field f this)) + [result-x any/c] + #:post-cond (= 2 (get-field f this))))) (new (class object% (field [f 1]) (define/public m (lambda args (set! f 2))) (super-new))) 'pos 'neg) @@ -3120,6 +2972,36 @@ '(g)) + (test/spec-passed/result + 'object-contract-ho-method1 + '(send (contract (object-contract (m (-> (-> integer? integer?) integer?))) + (new (class object% (define/public (m f) (f 1)) (super-new))) + 'pos + 'neg) + m + (λ (x) x)) + 1) + + (test/spec-passed/result + 'object-contract-ho-method2 + '(send (contract (object-contract (m (-> (->* (integer?) () integer?) integer?))) + (new (class object% (define/public (m f) (f 1)) (super-new))) + 'pos + 'neg) + m + (λ (x) x)) + 1) + + (test/spec-passed/result + 'object-contract-ho-method3 + '(send (contract (object-contract (m (-> (->d ([x integer?]) () [r integer?]) integer?))) + (new (class object% (define/public (m f) (f 1)) (super-new))) + 'pos + 'neg) + m + (λ (x) x)) + 1) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; test error message has right format @@ -3136,7 +3018,7 @@ 1 2)) "procedure m method: expects 1 argument, given 2: 1 2") - + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; tests object utilities to be sure wrappers work right @@ -3189,7 +3071,6 @@ ,obj 'pos 'neg)))) - |# ; @@ -4607,7 +4488,7 @@ so that propagation occurs. (provide/contract (contract-inferred-name-test2b (-> number? (values number? number?)))) (define (contract-inferred-name-test3 x . y) x) - (provide/contract (contract-inferred-name-test3 (->* (number?) () (listof number?) number?))) + (provide/contract (contract-inferred-name-test3 (->* (number?) () #:rest (listof number?) number?))) (define (contract-inferred-name-test4) 7) (provide/contract (contract-inferred-name-test4 (->d () () any))) @@ -4651,16 +4532,17 @@ so that propagation occurs. (test-name '(-> integer? boolean? any) (->* (integer? boolean?) () any)) (test-name '(-> integer? boolean? #:x string? any) (-> integer? #:x string? boolean? any)) - (test-name '(->* (integer?) (string?) boolean? (values char? any/c)) (->* (integer?) (string?) boolean? (values char? any/c))) + (test-name '(->* (integer?) (string?) #:rest any/c (values char? any/c)) + (->* (integer?) (string?) #:rest any/c (values char? any/c))) (test-name '(->* (integer? char?) (boolean?) any) (->* (integer? char?) (boolean?) any)) (test-name '(->* (integer? char? #:z string?) (integer?) any) (->* (#:z string? integer? char?) (integer?) any)) (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) any) (->* (#:z string? integer? char?) (boolean? #:i number?) any)) - (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (listof integer?) any) - (->* (#:z string? integer? char?) (boolean? #:i number?) (listof integer?) any)) + (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) any) + (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) any)) (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (values number? boolean? symbol?)) (->* (#:z string? integer? char?) (boolean? #:i number?) (values number? boolean? symbol?))) - (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) (listof integer?) (values number? boolean? symbol?)) - (->* (#:z string? integer? char?) (boolean? #:i number?) (listof integer?) (values number? boolean? symbol?))) + (test-name '(->* (integer? char? #:z string?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?)) + (->* (#:z string? integer? char?) (boolean? #:i number?) #:rest (listof integer?) (values number? boolean? symbol?))) (test-name '(->d () () any) (->d () () any)) (test-name '(->d ([x ...] #:y [y ...]) ([z ...] #:w [w ...]) any) (->d ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any)) @@ -4798,30 +4680,15 @@ so that propagation occurs. (-> integer? integer? integer?) (-> integer? (values integer? integer?)))))) (test-name - '(object-contract (m (case-> (-> integer? symbol?) - (-> integer? boolean? symbol?) - (-> integer? boolean? number? symbol?)))) - (object-contract (m (opt->* (integer?) (boolean? number?) (symbol?))))) - (test-name - '(object-contract (m (case-> (-> integer? symbol?) - (-> integer? boolean? symbol?) - (-> integer? boolean? number? symbol?)))) - (object-contract (m (opt-> (integer?) (boolean? number?) symbol?)))) - (test-name - '(object-contract (m (case-> (-> integer? any) - (-> integer? boolean? any) - (-> integer? boolean? number? any)))) - (object-contract (m (opt->* (integer?) (boolean? number?) any)))) - (test-name - '(object-contract (m (case-> (-> integer? (values symbol? boolean?)) - (-> integer? boolean? (values symbol? boolean?))))) - (object-contract (m (opt->* (integer?) (boolean?) (symbol? boolean?))))) + '(object-contract (m (->* (integer?) (boolean? number?) symbol?))) + (object-contract (m (->* (integer?) (boolean? number?) symbol?)))) - (test-name '(object-contract (m (->r ((x ...)) ...))) (object-contract (m (->r ((x number?)) number?)))) - (test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) ...))) - (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) number?)))) - (test-name '(object-contract (m (->r ((x ...) (y ...) (z ...)) rest-x ... ...))) - (object-contract (m (->r ((x number?) (y boolean?) (z pair?)) rest-x any/c number?)))) + (test-name '(object-contract (m (->d ((x ...)) () (y ...)))) (object-contract (m (->d ((x number?)) () [result number?])))) + (test-name '(object-contract (m (->d ((x ...) (y ...) (z ...)) () [w ...]))) + (object-contract (m (->d ((x number?) (y boolean?) (z pair?)) () [result number?])))) + (test-name '(object-contract (m (->d ((x ...) (y ...) (z ...)) () #:rest w ... [x0 ...]))) + (object-contract (m (->d ((x number?) (y boolean?) (z pair?)) () #:rest rest-x any/c [result number?])))) + (test-name '(promise/c any/c) (promise/c any/c)) (test-name '(syntax/c any/c) (syntax/c any/c)) (test-name '(struct/c st integer?) @@ -5028,10 +4895,10 @@ so that propagation occurs. (ctest #f contract-first-order-passes? (-> integer? boolean? #:x integer? integer?) (λ (x y) #t)) (ctest #t contract-first-order-passes? (-> integer? boolean? #:x integer? integer?) (λ (x y #:x z) #t)) - (ctest #t contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ (x . y) #f)) - (ctest #f contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ (x y . z) #f)) - (ctest #f contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ (x) #f)) - (ctest #t contract-first-order-passes? (->* (integer?) () boolean? (values char? any/c)) (λ x #f)) + (ctest #t contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x . y) #f)) + (ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x y . z) #f)) + (ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x) #f)) + (ctest #t contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ x #f)) (ctest #t contract-first-order-passes? (listof integer?) (list 1)) (ctest #f contract-first-order-passes? (listof integer?) #f) @@ -5043,42 +4910,6 @@ so that propagation occurs. (ctest #t contract-first-order-passes? (promise/c integer?) (delay 1)) (ctest #f contract-first-order-passes? (promise/c integer?) 1) -#| - - (ctest #f contract-first-order-passes? - (case-> (-> integer? integer?) - (-> integer? integer? integer?)) - (λ () 1)) - (ctest #f contract-first-order-passes? - (case-> (-> integer? integer?) - (-> integer? integer? integer?)) - (λ (x) 1)) - (ctest #f contract-first-order-passes? - (case-> (-> integer? integer?) - (-> integer? integer? integer?)) - (λ (x y) 1)) - (ctest #f contract-first-order-passes? - (case->) - 1) - - (ctest #t contract-first-order-passes? - (case->) - (case-lambda)) - - (ctest #t contract-first-order-passes? - (case-> (-> integer? integer?) - (-> integer? integer? integer?)) - (case-lambda [(x) x] [(x y) x])) - (ctest #t contract-first-order-passes? - (case-> (-> integer? integer?) - (-> integer? integer? integer?)) - (case-lambda [() 1] [(x) x] [(x y) x])) - (ctest #t contract-first-order-passes? - (case-> (-> integer? integer?) - (-> integer? integer? integer?)) - (case-lambda [() 1] [(x) x] [(x y) x] [(x y z) x])) -|# - (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) (λ (x) x)) (ctest #t contract-first-order-passes? (and/c (-> positive? positive?) (-> integer? integer?)) values) (ctest #f contract-first-order-passes? (and/c (-> integer?) (-> integer? integer?)) (λ (x) x)) @@ -5092,13 +4923,6 @@ so that propagation occurs. (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1) - (ctest #t contract-first-order-passes? - (object-contract (m (-> integer? integer?))) - (new object%)) - (ctest #t contract-first-order-passes? - (object-contract (m (-> integer? integer?))) - 1) - (ctest #t contract-first-order-passes? (couple/c any/c any/c) (make-couple 1 2))