diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss index 5f8c88ef96..c7ce9353ab 100644 --- a/collects/scheme/contract.ss +++ b/collects/scheme/contract.ss @@ -1,64 +1,63 @@ +#lang scheme/base -(module contract mzscheme +(require "private/contract.ss" + "private/contract-arrow.ss" + "private/contract-guts.ss" + "private/contract-ds.ss" + "private/contract-opt-guts.ss" + "private/contract-opt.ss" + "private/contract-basic-opters.ss") - (require "private/contract.ss" - "private/contract-arrow.ss" - "private/contract-guts.ss" - "private/contract-ds.ss" - "private/contract-opt-guts.ss" - "private/contract-opt.ss" - "private/contract-basic-opters.ss") - - (provide - opt/c define-opt/c ;(all-from "private/contract-opt.ss") - (all-from-except "private/contract-ds.ss" - lazy-depth-to-look) +(provide + opt/c define-opt/c ;(all-from "private/contract-opt.ss") + (except-out (all-from-out "private/contract-ds.ss") + lazy-depth-to-look) + + (except-out (all-from-out "private/contract-arrow.ss") + check-procedure) + (except-out (all-from-out "private/contract.ss") + check-between/c + check-unary-between/c)) - (all-from-except "private/contract-arrow.ss" - check-procedure) - (all-from-except "private/contract.ss" - check-between/c - check-unary-between/c)) - - ;; from contract-guts.ss - - (provide any - and/c - any/c - none/c - make-none/c - - guilty-party - contract-violation->string - - contract? - contract-name - contract-proc - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-first-order-passes? - - ;; below need docs - - make-proj-contract - - contract-stronger? - - coerce-contract - flat-contract/predicate? +;; from contract-guts.ss - build-compound-type-name - raise-contract-error - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - first-order-prop first-order-get)) +(provide any + and/c + any/c + none/c + make-none/c + + guilty-party + contract-violation->string + + contract? + contract-name + contract-proc + + flat-contract? + flat-contract + flat-contract-predicate + flat-named-contract + + contract-first-order-passes? + + ;; below need docs + + make-proj-contract + + contract-stronger? + + coerce-contract + flat-contract/predicate? + + build-compound-type-name + raise-contract-error + + proj-prop proj-pred? proj-get + name-prop name-pred? name-get + stronger-prop stronger-pred? stronger-get + flat-prop flat-pred? flat-get + first-order-prop first-order-get) ;; ====================================================================== ;; The alternate implementation disables contracts. Its useful mainly to @@ -68,12 +67,12 @@ #; (module contract mzscheme - + (define-syntax provide/contract (syntax-rules () [(_ elem ...) (begin (provide-one elem) ...)])) - + (define-syntax provide-one (syntax-rules (struct rename) [(_ (struct (id par-id) ([field . rest] ...))) @@ -84,7 +83,7 @@ (provide (rename id1 id2))] [(_ (id c)) (provide id)])) - + (define-syntax (provide-struct stx) (syntax-case stx () [(_ id par-id . rest) @@ -98,9 +97,9 @@ (- len 1))))))] [ids (lambda (l) (let loop ([l l]) (cond - [(null? l) null] - [(car l) (cons (car l) (loop (cdr l)))] - [else (loop (cdr l))])))]) + [(null? l) null] + [(car l) (cons (car l) (loop (cdr l)))] + [else (loop (cdr l))])))]) (if (and info p-info (list? info) @@ -117,32 +116,32 @@ (raise-syntax-error #f (cond - [(not info) "cannot find struct info"] - [(not p-info) "cannot find parent-struct info"] - [else (format "struct or parent-struct info has unexpected shape: ~e and ~e" - info p-info)]) + [(not info) "cannot find struct info"] + [(not p-info) "cannot find parent-struct info"] + [else (format "struct or parent-struct info has unexpected shape: ~e and ~e" + info p-info)]) #'id)))])) - + (define-syntax define-contract-struct (syntax-rules () [(_ . rest) (define-struct . rest)])) - + (define-syntax define/contract (syntax-rules () [(_ id c expr) (define id expr)])) - + (define-syntax contract (syntax-rules () [(_ c expr . rest) expr])) - + (provide provide/contract define-contract-struct define/contract contract) - + (define mk* (lambda args (lambda (x) x))) - + (define-syntax mk (syntax-rules () [(_ id) (begin @@ -150,7 +149,7 @@ (provide id))] [(_ id ...) (begin (mk id) ...)])) - + (mk -> ->* opt-> @@ -166,7 +165,7 @@ union listof is-a?/c) - + (define-syntax symbols (syntax-rules () [(_ sym ...) diff --git a/collects/scheme/private/contract-arr-checks.ss b/collects/scheme/private/contract-arr-checks.ss index 87be0df224..4decfc1dcc 100644 --- a/collects/scheme/private/contract-arr-checks.ss +++ b/collects/scheme/private/contract-arr-checks.ss @@ -1,182 +1,182 @@ -(module contract-arr-checks mzscheme - (provide (all-defined)) - (require (lib "list.ss") - "contract-guts.ss") +#lang scheme/base - (define empty-case-lambda/c - (flat-named-contract '(case->) - (λ (x) (and (procedure? x) (null? (procedure-arity x)))))) - - ;; ---------------------------------------- - ;; Checks and error functions used in macro expansions - - ;; procedure-accepts-and-more? : procedure number -> boolean - ;; returns #t if val accepts dom-length arguments and - ;; any number of arguments more than dom-length. - ;; returns #f otherwise. - (define (procedure-accepts-and-more? val dom-length) - (let ([arity (procedure-arity val)]) - (cond - [(number? arity) #f] - [(arity-at-least? arity) - (<= (arity-at-least-value arity) dom-length)] - [else - (let ([min-at-least (let loop ([ars arity] - [acc #f]) - (cond - [(null? ars) acc] - [else (let ([ar (car ars)]) - (cond - [(arity-at-least? ar) - (if (and acc - (< acc (arity-at-least-value ar))) - (loop (cdr ars) acc) - (loop (cdr ars) (arity-at-least-value ar)))] - [(number? ar) - (loop (cdr ars) acc)]))]))]) - (and min-at-least - (begin - (let loop ([counts (sort (filter number? arity) >=)]) - (unless (null? counts) - (let ([count (car counts)]) - (cond - [(= (+ count 1) min-at-least) - (set! min-at-least count) - (loop (cdr counts))] - [(< count min-at-least) - (void)] - [else (loop (cdr counts))])))) - (<= min-at-least dom-length))))]))) - - (define (check->* f arity-count) - (unless (procedure? f) - (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) - (unless (procedure-arity-includes? f arity-count) - (error 'object-contract - "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" - arity-count - f))) +(provide (all-defined-out)) +(require "contract-guts.ss") - (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 empty-case-lambda/c + (flat-named-contract '(case->) + (λ (x) (and (procedure? x) (null? (procedure-arity x)))))) + +;; ---------------------------------------- +;; Checks and error functions used in macro expansions + +;; procedure-accepts-and-more? : procedure number -> boolean +;; returns #t if val accepts dom-length arguments and +;; any number of arguments more than dom-length. +;; returns #f otherwise. +(define (procedure-accepts-and-more? val dom-length) + (let ([arity (procedure-arity val)]) + (cond + [(number? arity) #f] + [(arity-at-least? arity) + (<= (arity-at-least-value arity) dom-length)] + [else + (let ([min-at-least (let loop ([ars arity] + [acc #f]) + (cond + [(null? ars) acc] + [else (let ([ar (car ars)]) + (cond + [(arity-at-least? ar) + (if (and acc + (< acc (arity-at-least-value ar))) + (loop (cdr ars) acc) + (loop (cdr ars) (arity-at-least-value ar)))] + [(number? ar) + (loop (cdr ars) acc)]))]))]) + (and min-at-least + (begin + (let loop ([counts (sort (filter number? arity) >=)]) + (unless (null? counts) + (let ([count (car counts)]) + (cond + [(= (+ count 1) min-at-least) + (set! min-at-least count) + (loop (cdr counts))] + [(< count min-at-least) + (void)] + [else (loop (cdr counts))])))) + (<= min-at-least dom-length))))]))) + +(define (check->* f arity-count) + (unless (procedure? f) + (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) + (unless (procedure-arity-includes? f arity-count) + (error 'object-contract + "expected last argument of ->d* to be a procedure that accepts ~a arguments, got ~e" + arity-count + f))) + +(define (check->*/more f arity-count) + (unless (procedure? f) + (error 'object-contract "expected last argument of ->d* to be a procedure, got ~e" f)) + (unless (procedure-accepts-and-more? f arity-count) + (error 'object-contract + "expected last argument of ->d* to be a procedure that accepts ~a argument~a and arbitrarily many more, got ~e" + arity-count + (if (= 1 arity-count) "" "s") + f))) - (define (check-pre-expr->pp/h val pre-expr src-info blame orig-str) - (unless pre-expr - (raise-contract-error val - src-info - blame - orig-str - "pre-condition expression failure"))) - - (define (check-post-expr->pp/h val post-expr src-info blame orig-str) - (unless post-expr - (raise-contract-error val - src-info - blame - orig-str - "post-condition expression failure"))) - - (define (check-procedure val dom-length src-info blame orig-str) - (unless (and (procedure? val) - (procedure-arity-includes? val dom-length)) - (raise-contract-error - val - src-info - blame - orig-str - "expected a procedure that accepts ~a arguments, given: ~e" - dom-length - val))) - - (define ((check-procedure? arity) val) - (and (procedure? val) - (procedure-arity-includes? val arity))) - - (define ((check-procedure/more? arity) val) - (and (procedure? val) - (procedure-accepts-and-more? val arity))) +(define (check-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-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-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/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 val dom-length src-info blame orig-str) + (unless (and (procedure? val) + (procedure-arity-includes? val dom-length)) + (raise-contract-error + val + src-info + blame + orig-str + "expected a procedure that accepts ~a arguments, given: ~e" + dom-length + val))) - (define (check-procedure/more val dom-length src-info blame orig-str) - (unless (and (procedure? val) - (procedure-accepts-and-more? val dom-length)) - (raise-contract-error - val - src-info - blame - orig-str - "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" - dom-length - dom-length - val))) +(define ((check-procedure? arity) val) + (and (procedure? val) + (procedure-arity-includes? val arity))) + +(define ((check-procedure/more? arity) val) + (and (procedure? val) + (procedure-accepts-and-more? val arity))) + +(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) + (unless (procedure? val) + (raise-contract-error val + src-info + blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-arity-includes? val arity) + (raise-contract-error val + src-info + blame + orig-str + "expected a ~a of arity ~a (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) + +(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str) + (unless (procedure? val) + (raise-contract-error val + src-info + blame + orig-str + "expected a procedure, got ~e" + val)) + (unless (procedure-accepts-and-more? val arity) + (raise-contract-error val + src-info + blame + orig-str + "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) + +(define (check-procedure/more val dom-length src-info blame orig-str) + (unless (and (procedure? val) + (procedure-accepts-and-more? val dom-length)) + (raise-contract-error + val + src-info + blame + orig-str + "expected a procedure that accepts ~a arguments and any number of arguments larger than ~a, given: ~e" + dom-length + dom-length + val))) - (define (check-rng-procedure who rng-x arity) - (unless (and (procedure? rng-x) - (procedure-arity-includes? rng-x arity)) - (error who "expected range position to be a procedure that accepts ~a arguments, given: ~e" - arity - rng-x))) +(define (check-rng-procedure 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-procedure/more rng-mk-x arity) + (unless (and (procedure? rng-mk-x) + (procedure-accepts-and-more? rng-mk-x arity)) + (error '->d* "expected range position to be a procedure that accepts ~a arguments and arbitrarily many more, given: ~e" + arity + rng-mk-x))) - (define (check-rng-lengths results rng-contracts) - (unless (= (length results) (length rng-contracts)) - (error '->d* - "expected range contract contructor and function to have the same number of values, given: ~a and ~a respectively" - (length results) (length rng-contracts)))) +(define (check-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? @@ -195,4 +195,3 @@ (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 index 8c4b904c98..affb0d96a9 100644 --- a/collects/scheme/private/contract-arr-obj-helpers.ss +++ b/collects/scheme/private/contract-arr-obj-helpers.ss @@ -1,373 +1,418 @@ -(module contract-arr-obj-helpers mzscheme - (require (lib "stx.ss" "syntax") - (lib "name.ss" "syntax")) - - (require-for-template mzscheme - "contract-guts.ss" - "contract-arr-checks.ss") +#lang scheme/base +(require syntax/stx + syntax/name) - (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]) +(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 ... any) ...))) + (syntax (case-> (-> case-doms ... single-case-result) ...))) 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)]) + (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 - [(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) + [(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 - [(member this-case individual-cases) - (raise-syntax-error - 'case-> - (format "found multiple cases with ~a arguments" this-case) - stx)] - [(and dot-min (dot-min . <= . this-case)) - (raise-syntax-error - 'case-> - (format "found overlapping cases (~a+ followed by ~a)" dot-min this-case) - stx)] - [else (set! individual-cases (cons this-case individual-cases))])] - [(pair? this-case) - (let ([new-dot-min (car this-case)]) - (cond - [dot-min - (if (dot-min . <= . new-dot-min) - (raise-syntax-error - 'case-> - (format "found overlapping cases (~a+ followed by ~a+)" dot-min new-dot-min) - stx) - (set! dot-min new-dot-min))] - [else - (set! dot-min new-dot-min)]))]))) - cases))) - - ;; get-case : syntax -> (union number (cons number 'more)) - (define (get-case stx) - (let ([ilist (syntax-object->datum stx)]) - (if (list? ilist) - (length ilist) - (cons - (let loop ([i ilist]) - (cond - [(pair? i) (+ 1 (loop (cdr i)))] - [else 0])) - 'more)))) - - - ;; case->/h : boolean - ;; syntax - ;; (listof syntax) - ;; 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-object - #'here - (string->symbol - (format - "super-~a" - (syntax-object->datum - stx))))) - - ;; method-name->contract-method-name : syntax[identifier] -> syntax[identifier] - ;; given the syntax for a method name, constructs the name of a method - ;; that returns the super's contract for the original method. - (define (method-name->contract-method-name stx) - (datum->syntax-object - #'here - (string->symbol - (format - "ACK_DONT_GUESS_ME-super-contract-~a" - (syntax-object->datum - stx))))) - - ;; Each of the /h functions builds six pieces of syntax: - ;; - [arguments-check] - ;; code that binds the contract values to names and - ;; does error checking for the contract specs - ;; (were the arguments all contracts?) - ;; - [build-proj] - ;; code that partially applies the input contracts to build the projection - ;; - [check-val] - ;; code that does error checking on the contract'd value itself - ;; (is it a function of the right arity?) - ;; - [first-order-check] - ;; predicate function that does the first order check and returns a boolean - ;; (is it a function of the right arity?) - ;; - [pos-wrapper] - ;; a piece of syntax that has the arguments to the wrapper - ;; and the body of the wrapper. - ;; - [neg-wrapper] - ;; a piece of syntax that has the arguments to the wrapper - ;; and the body of the wrapper. - ;; the first function accepts a body expression and wraps - ;; the body expression with checks. In addition, it - ;; adds a let that binds the contract exprssions to names - ;; the results of the other functions mention these names. - ;; the second and third function's input syntax should be five - ;; names: val, blame, src-info, orig-str, name-id - ;; the fourth function returns a syntax list with two elements, - ;; the argument list (to be used as the first arg to lambda, - ;; or as a case-lambda clause) and the body of the function. - ;; They are combined into a lambda for the -> ->* ->d ->d* macros, - ;; and combined into a case-lambda for the case-> macro. - - ;; ->/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->/h method-proc? stx) - (syntax-case stx () - [(_) (raise-syntax-error '-> "expected at least one argument" stx)] - [(_ dom ... rng) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) - (with-syntax ([(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax-case* (syntax rng) (any values) module-or-top-identifier=? - [any + [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 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)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ...) - (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) + (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 @@ -375,7 +420,53 @@ (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)] ...) + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure? dom-length)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) + (values (rng-projection-x + res-x) + ...))))))))] + [rng + (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] + [(rng-contact-x) (generate-temporaries (syntax (rng)))] + [(rng-projection-x) (generate-temporaries (syntax (rng)))] + [(rng-ant-x) (generate-temporaries (syntax (rng)))] + [(res-x) (generate-temporaries (syntax (rng)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (let ([dom-contract-x (coerce-contract '-> dom)] + ... + [rng-contract-x (coerce-contract '-> rng)]) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [rng-x (contract-proc rng-contract-x)]) + (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)]) inner-lambda)))) (lambda (outer-args) @@ -387,624 +478,548 @@ (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (syntax ((arg-x ...) - (val (dom-projection-x arg-x) ...))))))] - [(values rng ...) - (with-syntax ([(rng-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] - [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] - [(res-x ...) (generate-temporaries (syntax (rng ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract '-> dom)] - ... - [rng-contract-x (coerce-contract '-> rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-x (contract-proc rng-contract-x)] - ...) - (let ([name-id - (build-compound-type-name - '-> - name-dom-contract-x ... - (build-compound-type-name 'values rng-contract-x ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure? dom-length)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) - (values (rng-projection-x - res-x) - ...))))))))] - [rng - (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] - [(rng-contact-x) (generate-temporaries (syntax (rng)))] - [(rng-projection-x) (generate-temporaries (syntax (rng)))] - [(rng-ant-x) (generate-temporaries (syntax (rng)))] - [(res-x) (generate-temporaries (syntax (rng)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([dom-contract-x (coerce-contract '-> dom)] - ... - [rng-contract-x (coerce-contract '-> rng)]) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-x (contract-proc rng-contract-x)]) - (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)]) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure? dom-length)) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (let ([res-x (val (dom-projection-x arg-x) ...)]) - (rng-projection-x res-x))))))))])))])) - - ;; ->*/h : boolean stx -> (values (syntax -> syntax) (syntax syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->*/h method-proc? stx) - (syntax-case stx (any) - [(_ (dom ...) (rng ...)) - (->/h method-proc? (syntax (-> dom ... (values rng ...))))] - [(_ (dom ...) any) - (->/h method-proc? (syntax (-> dom ... any)))] - [(_ (dom ...) rest (rng ...)) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [dom-rest-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-projection-x (car (generate-temporaries (list (syntax rest))))] - [arg-rest-x (car (generate-temporaries (list (syntax rest))))] - - [(rng-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-contract-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-projection-x ...) (generate-temporaries (syntax (rng ...)))] - [(rng-length rng-index ...) (generate-indicies (syntax (rng ...)))] - [(rng-ant-x ...) (generate-temporaries (syntax (rng ...)))] - [(res-x ...) (generate-temporaries (syntax (rng ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [body body] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->* dom)] + (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-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-x (contract-proc dom-rest-contract-x)] + [rng-x (contract-proc rng-contract-x)] + ...) + (let ([name-id + (build-compound-type-name + '->* + (build-compound-type-name dom-contract-x ...) + dom-rest-contract-x + (build-compound-type-name rng-contract-x ...))]) + body)))))) + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)] + [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure/more val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure/more? dom-length)) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . arg-rest-x) + (let-values ([(res-x ...) + (apply + val + (dom-projection-x arg-x) + ... + (dom-rest-projection-x arg-rest-x))]) + (values (rng-projection-x res-x) ...))))))))] + [(_ (dom ...) rest any) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [dom-rest-x (car (generate-temporaries (list (syntax rest))))] + [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] + [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))] + [arg-rest-x (car (generate-temporaries (list (syntax rest))))] + + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->* dom)] + ... + [dom-rest-contract-x (coerce-contract '->* rest)]) + (let ([dom-x (contract-proc dom-contract-x)] ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)] - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure/more val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure/more? dom-length)) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . arg-rest-x) - (let-values ([(res-x ...) - (apply - val - (dom-projection-x arg-x) - ... - (dom-rest-projection-x arg-rest-x))]) - (values (rng-projection-x res-x) ...))))))))] - [(_ (dom ...) rest any) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [dom-rest-x (car (generate-temporaries (list (syntax rest))))] - [dom-rest-contract-x (car (generate-temporaries (list (syntax rest))))] - [dom-projection-rest-x (car (generate-temporaries (list (syntax rest))))] - [arg-rest-x (car (generate-temporaries (list (syntax rest))))] - - [arity (length (syntax->list (syntax (dom ...))))]) + [dom-rest-x (contract-proc dom-rest-contract-x)]) + (let ([name-id (build-compound-type-name + '->* + (build-compound-type-name name-dom-contract-x ...) + dom-rest-contract-x + 'any)]) + body)))))) + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure/more val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure/more? dom-length)) + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . arg-rest-x) + (apply + val + (dom-projection-x arg-x) + ... + (dom-projection-rest-x arg-rest-x))))))))])) + +;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) +(define (->d/h method-proc? stx) + (syntax-case stx () + [(_) (raise-syntax-error '->d "expected at least one argument" stx)] + [(_ dom ... rng) + (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] + [(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->d dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [rng-x rng]) + (check-rng-procedure '->d rng-x arity) + (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val arity src-info pos-blame orig-str)))) + + (syntax (check-procedure? arity)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (let ([arg-x (dom-projection-x arg-x)] ...) + (let ([rng-contract (rng-x arg-x ...)]) + (((contract-proc (coerce-contract '->d rng-contract)) + pos-blame + neg-blame + src-info + orig-str) + (val arg-x ...))))))))))])) + +;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) +(define (->d*/h method-proc? stx) + (syntax-case stx () + [(_ (dom ...) rng-mk) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] + [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->d* dom)] ...) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [rng-mk-x rng-mk]) + (check-rng-procedure '->d* rng-mk-x dom-length) + (let ([name-id (build-compound-type-name + '->d* + (build-compound-type-name name-dom-contract-x ...) + '(... ...))]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure val dom-length src-info pos-blame orig-str)))) + (syntax (check-procedure? dom-length)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ...) + (call-with-values + (lambda () (rng-mk-x arg-x ...)) + (lambda rng-contracts + (call-with-values + (lambda () + (val (dom-projection-x arg-x) ...)) + (lambda results + (check-rng-lengths results rng-contracts) + (apply + values + (map (lambda (rng-contract result) + (((contract-proc (coerce-contract '->d* rng-contract)) + pos-blame + neg-blame + src-info + orig-str) + result)) + rng-contracts + results))))))))))))] + [(_ (dom ...) rest rng-mk) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] + [(dom-rest-x) (generate-temporaries (syntax (rest)))] + [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))] + [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))] + [(arg-x ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))]) + (values + (lambda (outer-args body) + (with-syntax ([body body] + [(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [(name-dom-contract-x ...) + (if method-proc? + (cdr + (syntax->list + (syntax (dom-contract-x ...)))) + (syntax (dom-contract-x ...)))]) + (syntax + (let ([dom-contract-x (coerce-contract '->d* dom)] + ... + [dom-rest-contract-x (coerce-contract '->d* rest)]) + (let ([dom-x (contract-proc dom-contract-x)] + ... + [dom-rest-x (contract-proc dom-rest-contract-x)] + [rng-mk-x rng-mk]) + (check-rng-procedure/more rng-mk-x arity) + (let ([name-id (build-compound-type-name + '->d* + (build-compound-type-name name-dom-contract-x ...) + dom-rest-contract-x + '(... ...))]) + body)))))) + + ;; proj + (lambda (outer-args inner-lambda) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] + [inner-lambda inner-lambda]) + (syntax + (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] + ... + [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) + inner-lambda)))) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + (check-procedure/more val arity src-info pos-blame orig-str)))) + (syntax (check-procedure/more? arity)) + + (lambda (outer-args) + (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) + (syntax + ((arg-x ... . rest-arg-x) + (call-with-values + (lambda () + (apply rng-mk-x arg-x ... rest-arg-x)) + (lambda rng-contracts + (call-with-values + (lambda () + (apply + val + (dom-projection-x arg-x) + ... + (dom-rest-projection-x rest-arg-x))) + (lambda results + (check-rng-lengths results rng-contracts) + (apply + values + (map (lambda (rng-contract result) + (((contract-proc (coerce-contract '->d* rng-contract)) + pos-blame + neg-blame + src-info + orig-str) + result)) + rng-contracts + results))))))))))))])) + +;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) +(define (->r/h method-proc? stx) + (syntax-case stx () + [(_ ([x dom] ...) rng) + (syntax-case* (syntax rng) (any values) module-or-top-identifier=? + [any + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))] + [(values . args) + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))] + [rng + (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))] + [_ + (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])] + + [(_ ([x dom] ...) rest-x rest-dom rng) + (syntax-case* (syntax rng) (values any) module-or-top-identifier=? + [any + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))] + [(values . whatever) + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))] + [_ + (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])])) + +;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) +(define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx)) + +;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) +(define (->r-pp/h method-proc? name stx) + (syntax-case stx () + [(_ ([x dom] ...) pre-expr . result-stuff) + (and (andmap identifier? (syntax->list (syntax (x ...)))) + (not (check-duplicate-identifier (syntax->list (syntax (x ...)))))) + (with-syntax ([stx-name name]) + (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] + [arity (length (syntax->list (syntax (dom ...))))] + [name-stx + (with-syntax ([(name-xs ...) (if method-proc? + (cdr (syntax->list (syntax (x ...)))) + (syntax (x ...)))]) + (syntax + (build-compound-type-name 'stx-name + (build-compound-type-name + (build-compound-type-name 'name-xs '(... ...)) + ...) + '(... ...))))]) (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) + [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) (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) + (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] - [inner-lambda inner-lambda]) + [kind-of-thing (if method-proc? 'method 'procedure)]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure/more val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure/more? dom-length)) - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . arg-rest-x) - (apply - val - (dom-projection-x arg-x) - ... - (dom-projection-rest-x arg-rest-x))))))))])) - - ;; ->d/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->d/h method-proc? stx) - (syntax-case stx () - [(_) (raise-syntax-error '->d "expected at least one argument" stx)] - [(_ dom ... rng) - (with-syntax ([(rng-x) (generate-temporaries (syntax (rng)))] - [(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->d dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-x rng]) - (check-rng-procedure '->d rng-x arity) - (let ([name-id (build-compound-type-name '->d name-dom-contract-x ... '(... ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val arity src-info pos-blame orig-str)))) + (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 - ((arg-x ...) - (let ([arg-x (dom-projection-x arg-x)] ...) - (let ([rng-contract (rng-x arg-x ...)]) - (((contract-proc (coerce-contract '->d rng-contract)) - pos-blame - neg-blame - src-info - orig-str) - (val arg-x ...))))))))))])) - - ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->d*/h method-proc? stx) - (syntax-case stx () - [(_ (dom ...) rng-mk) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))] - [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->d* dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [rng-mk-x rng-mk]) - (check-rng-procedure '->d* rng-mk-x dom-length) - (let ([name-id (build-compound-type-name - '->d* - (build-compound-type-name name-dom-contract-x ...) - '(... ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] ...) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure val dom-length src-info pos-blame orig-str)))) - (syntax (check-procedure? dom-length)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ...) - (call-with-values - (lambda () (rng-mk-x arg-x ...)) - (lambda rng-contracts - (call-with-values - (lambda () - (val (dom-projection-x arg-x) ...)) - (lambda results - (check-rng-lengths results rng-contracts) - (apply - values - (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str) - result)) - rng-contracts - results))))))))))))] - [(_ (dom ...) rest rng-mk) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-contract-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-projection-x ...) (generate-temporaries (syntax (dom ...)))] - [(dom-rest-x) (generate-temporaries (syntax (rest)))] - [(dom-rest-contract-x) (generate-temporaries (syntax (rest)))] - [(dom-rest-projection-x) (generate-temporaries (syntax (rest)))] - [(arg-x ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [(name-dom-contract-x ...) - (if method-proc? - (cdr - (syntax->list - (syntax (dom-contract-x ...)))) - (syntax (dom-contract-x ...)))]) - (syntax - (let ([dom-contract-x (coerce-contract '->d* dom)] - ... - [dom-rest-contract-x (coerce-contract '->d* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] - ... - [dom-rest-x (contract-proc dom-rest-contract-x)] - [rng-mk-x rng-mk]) - (check-rng-procedure/more rng-mk-x arity) - (let ([name-id (build-compound-type-name - '->d* - (build-compound-type-name name-dom-contract-x ...) - dom-rest-contract-x - '(... ...))]) - body)))))) - - ;; proj - (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [inner-lambda inner-lambda]) - (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str)] - ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str)]) - inner-lambda)))) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (check-procedure/more val arity src-info pos-blame orig-str)))) - (syntax (check-procedure/more? arity)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - ((arg-x ... . rest-arg-x) - (call-with-values - (lambda () - (apply rng-mk-x arg-x ... rest-arg-x)) - (lambda rng-contracts - (call-with-values - (lambda () - (apply - val - (dom-projection-x arg-x) - ... - (dom-rest-projection-x rest-arg-x))) - (lambda results - (check-rng-lengths results rng-contracts) - (apply - values - (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str) - result)) - rng-contracts - results))))))))))))])) - - ;; ->r/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r/h method-proc? stx) - (syntax-case stx () - [(_ ([x dom] ...) rng) - (syntax-case* (syntax rng) (any values) module-or-top-identifier=? - [any - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t any)))] - [(values . args) - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng #t)))] - [rng - (->r-pp/h method-proc? '->r (syntax (->r ([x dom] ...) #t rng unused-id #t)))] - [_ - (raise-syntax-error '->r "unknown result contract spec" stx (syntax rng))])] - - [(_ ([x dom] ...) rest-x rest-dom rng) - (syntax-case* (syntax rng) (values any) module-or-top-identifier=? - [any - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t any)))] - [(values . whatever) - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng #t)))] - [_ - (->r-pp-rest/h method-proc? '->r (syntax (->r ([x dom] ...) rest-x rest-dom #t rng unused-id #t)))])])) - - ;; ->pp/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->pp/h method-proc? stx) (->r-pp/h method-proc? '->pp stx)) - - ;; ->pp/h : boolean symbol stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) - (define (->r-pp/h method-proc? name stx) - (syntax-case stx () - [(_ ([x dom] ...) pre-expr . result-stuff) - (and (andmap identifier? (syntax->list (syntax (x ...)))) - (not (check-duplicate-identifier (syntax->list (syntax (x ...)))))) - (with-syntax ([stx-name name]) - (with-syntax ([(dom-id ...) (generate-temporaries (syntax (dom ...)))] - [arity (length (syntax->list (syntax (dom ...))))] - [name-stx - (with-syntax ([(name-xs ...) (if method-proc? - (cdr (syntax->list (syntax (x ...)))) - (syntax (x ...)))]) - (syntax - (build-compound-type-name 'stx-name - (build-compound-type-name - (build-compound-type-name 'name-xs '(... ...)) - ...) - '(... ...))))]) - (values - (lambda (outer-args body) - (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax - (let ([name-id name-stx]) - body)))) - (lambda (outer-args inner-lambda) inner-lambda) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args] - [kind-of-thing (if method-proc? 'method 'procedure)]) - (syntax - (begin - (check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) - - (syntax (check-procedure? arity)) - - (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id) outer-args]) - (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=? - [(any) + (syntax-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)] ...) - (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) ...))]) + (let-values ([(rng-ids ...) (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) + (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 @@ -1012,100 +1027,86 @@ (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)))]) + (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) - 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)))])))))) + (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 7dbfeadbe2..46406103a1 100644 --- a/collects/scheme/private/contract-arrow.ss +++ b/collects/scheme/private/contract-arrow.ss @@ -1,461 +1,424 @@ -(module contract-arrow mzscheme - (require (lib "etc.ss") - "contract-guts.ss" - "contract-arr-checks.ss" - "contract-opt.ss") - (require-for-syntax "contract-opt-guts.ss" - "contract-helpers.ss" - "contract-arr-obj-helpers.ss" - (lib "stx.ss" "syntax") - (lib "name.ss" "syntax")) +#lang scheme/base +(require (lib "etc.ss") + "contract-guts.ss" + "contract-arr-checks.ss" + "contract-opt.ss") +(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 (lib "stx.ss" "syntax")) + (for-syntax (lib "name.ss" "syntax"))) - (provide -> - ->d - ->* - ->d* - ->r - ->pp - ->pp-rest - case-> - opt-> - opt->* - unconstrained-domain-> - check-procedure) - - (define-syntax (unconstrained-domain-> stx) - (syntax-case stx () - [(_ rngs ...) - (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))] - [(proj-x ...) (generate-temporaries #'(rngs ...))] - [(p-app-x ...) (generate-temporaries #'(rngs ...))] - [(res-x ...) (generate-temporaries #'(rngs ...))]) - #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x ((proj-get rngs-x) rngs-x)] ...) - (make-proj-contract - (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) - (λ (pos-blame neg-blame src-info orig-str) - (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...) - (λ (val) - (if (procedure? val) - (λ args - (let-values ([(res-x ...) (apply val args)]) - (values (p-app-x res-x) ...))) - (raise-contract-error val - src-info - pos-blame - orig-str - "expected a procedure"))))) - procedure?))))])) - - ;; FIXME: need to pass in the name of the contract combinator. - (define (build--> name doms doms-rest rngs rng-any? func) - (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] - [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)] - [doms-rest/c (and doms-rest (coerce-contract name doms-rest))]) - (make--> rng-any? doms/c doms-rest/c rngs/c func))) - - (define-struct/prop -> (rng-any? doms dom-rest rngs func) - ((proj-prop (λ (ctc) - (let* ([doms/c (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest ctc) - (append (->-doms ctc) (list (->-dom-rest ctc))) - (->-doms ctc)))] - [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] - [func (->-func ctc)] - [dom-length (length (->-doms ctc))] - [check-proc - (if (->-dom-rest ctc) - check-procedure/more - check-procedure)]) - (lambda (pos-blame neg-blame src-info orig-str) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) - doms/c)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) - rngs/c)]) - (apply func - (λ (val) (check-proc val dom-length src-info pos-blame orig-str)) - (append partial-doms partial-ranges))))))) - (name-prop (λ (ctc) (single-arrow-name-maker - (->-doms ctc) - (->-dom-rest ctc) - (->-rng-any? ctc) - (->-rngs ctc)))) - (first-order-prop - (λ (ctc) - (let ([l (length (->-doms ctc))]) - (if (->-dom-rest ctc) - (λ (x) - (and (procedure? x) - (procedure-accepts-and-more? x l))) - (λ (x) - (and (procedure? x) - (procedure-arity-includes? x l))))))) - (stronger-prop - (λ (this that) - (and (->? that) - (= (length (->-doms that)) - (length (->-doms this))) - (andmap contract-stronger? - (->-doms that) - (->-doms this)) - (= (length (->-rngs that)) - (length (->-rngs this))) - (andmap contract-stronger? - (->-rngs this) - (->-rngs that))))))) - - (define (single-arrow-name-maker doms/c doms-rest rng-any? rngs) - (cond - [doms-rest - (build-compound-type-name - '->* - (apply build-compound-type-name doms/c) - doms-rest - (cond - [rng-any? 'any] - [else (apply build-compound-type-name rngs)]))] - [else - (let ([rng-name - (cond - [rng-any? 'any] - [(null? rngs) '(values)] - [(null? (cdr rngs)) (car rngs)] - [else (apply build-compound-type-name 'values rngs)])]) - (apply build-compound-type-name '-> (append doms/c (list rng-name))))])) - - (define arity-one-wrapper - (lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1))))))) - - (define arity-two-wrapper - (lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2))))))) - - (define arity-three-wrapper - (lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8))))))) - - (define arity-four-wrapper - (lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16))))))) - - (define arity-five-wrapper - (lambda (chk a27 b28 c29 d30 e31 r32) - (lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26))))))) - - (define arity-six-wrapper - (lambda (chk a39 b40 c41 d42 e43 f44 r45) - (lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38))))))) - - (define arity-seven-wrapper - (lambda (chk a53 b54 c55 d56 e57 f58 g59 r60) - (lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52))))))) - - (define-syntax-set (-> ->*) - (define (->/proc stx) - (let-values ([(stx _1 _2) (->/proc/main stx)]) - stx)) - - ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) - (define (->/proc/main stx) - (let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)]) - (with-syntax ([(args body) inner-args/body]) - (with-syntax ([(dom-names ...) dom-names] - [(rng-names ...) rng-names] - [(dom-ctcs ...) dom-ctcs] - [(rng-ctcs ...) rng-ctcs] - [inner-lambda - (add-name-prop - (syntax-local-infer-name stx) - (syntax (lambda args body)))] - [use-any? use-any?]) - (with-syntax ([outer-lambda - (let* ([lst (syntax->list #'args)] - [len (and lst (length lst))]) - (if (and #f ;; this optimization disables the names so is turned off for now - lst - (not (syntax-e #'use-any?)) - (= len (length (syntax->list #'(dom-names ...)))) - (= 1 (length (syntax->list #'(rng-names ...)))) - (<= 1 len 7)) - (case len - [(1) #'arity-one-wrapper] - [(2) #'arity-two-wrapper] - [(3) #'arity-three-wrapper] - [(4) #'arity-four-wrapper] - [(5) #'arity-five-wrapper] - [(6) #'arity-six-wrapper] - [(7) #'arity-seven-wrapper]) - (syntax - (lambda (chk dom-names ... rng-names ...) - (lambda (val) - (chk val) - inner-lambda)))))]) - (values - (syntax (build--> '-> - (list dom-ctcs ...) - #f - (list rng-ctcs ...) - use-any? - outer-lambda)) - inner-args/body - (syntax (dom-names ... rng-names ...)))))))) - - (define (->-helper stx) - (syntax-case* stx (-> any values) module-or-top-identifier=? - [(-> doms ... any) - (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] - [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] - [(ignored) (generate-temporaries (syntax (rng)))]) - (values (syntax (dom-ctc ...)) - (syntax (ignored)) - (syntax (doms ...)) - (syntax (any/c)) - (syntax ((args ...) (val (dom-ctc args) ...))) - #t))] - [(-> doms ... (values rngs ...)) - (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] - [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] - [(rng-x ...) (generate-temporaries (syntax (rngs ...)))] - [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))]) - (values (syntax (dom-ctc ...)) - (syntax (rng-ctc ...)) - (syntax (doms ...)) - (syntax (rngs ...)) - (syntax ((args ...) - (let-values ([(rng-x ...) (val (dom-ctc args) ...)]) - (values (rng-ctc rng-x) ...)))) - #f))] - [(_ doms ... rng) - (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] - [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] - [(rng-ctc) (generate-temporaries (syntax (rng)))]) - (values (syntax (dom-ctc ...)) - (syntax (rng-ctc)) - (syntax (doms ...)) - (syntax (rng)) - (syntax ((args ...) (rng-ctc (val (dom-ctc args) ...)))) - #f))])) - - (define (->*/proc stx) - (let-values ([(stx _1 _2) (->*/proc/main stx)]) - stx)) - - ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) - (define (->*/proc/main stx) - (syntax-case* stx (->* any) module-or-top-identifier=? - [(->* (doms ...) any) - (->/proc/main (syntax (-> doms ... any)))] - [(->* (doms ...) (rngs ...)) - (->/proc/main (syntax (-> doms ... (values rngs ...))))] - [(->* (doms ...) rst (rngs ...)) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))] - [(args ...) (generate-temporaries (syntax (doms ...)))] - [(rst-x) (generate-temporaries (syntax (rst)))] - [(rest-arg) (generate-temporaries (syntax (rst)))] - [(rng-x ...) (generate-temporaries (syntax (rngs ...)))] - [(rng-args ...) (generate-temporaries (syntax (rngs ...)))]) - (let ([inner-args/body - (syntax ((args ... . rest-arg) - (let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))]) - (values (rng-x rng-args) ...))))]) - (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body]) - (add-name-prop - (syntax-local-infer-name stx) - (syntax (lambda args body))))]) - (with-syntax ([outer-lambda - (syntax - (lambda (chk dom-x ... rst-x rng-x ...) - (lambda (val) - (chk val) - inner-lambda)))]) - (values (syntax (build--> '->* - (list doms ...) - rst - (list rngs ...) - #f - outer-lambda)) - inner-args/body - (syntax (dom-x ... rst-x rng-x ...)))))))] - [(->* (doms ...) rst any) - (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))] - [(args ...) (generate-temporaries (syntax (doms ...)))] - [(rst-x) (generate-temporaries (syntax (rst)))] - [(rest-arg) (generate-temporaries (syntax (rst)))]) - (let ([inner-args/body - (syntax ((args ... . rest-arg) - (apply val (dom-x args) ... (rst-x rest-arg))))]) - (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body]) - (add-name-prop - (syntax-local-infer-name stx) - (syntax (lambda args body))))]) - (with-syntax ([outer-lambda - (syntax - (lambda (chk dom-x ... rst-x ignored) - (lambda (val) - (chk val) - inner-lambda)))]) - (values (syntax (build--> '->* - (list doms ...) - rst - (list any/c) - #t - outer-lambda)) - inner-args/body - (syntax (dom-x ... rst-x)))))))]))) - - (define-for-syntax (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-syntax (->d stx) (make-/proc #f ->d/h stx)) - (define-syntax (->d* stx) (make-/proc #f ->d*/h stx)) - (define-syntax (->r stx) (make-/proc #f ->r/h stx)) - (define-syntax (->pp stx) (make-/proc #f ->pp/h stx)) - (define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx)) - (define-syntax (case-> stx) (make-case->/proc #f stx stx select/h)) - (define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->)) - (define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->)) +(provide -> + ->d + ->* + ->d* + ->r + ->pp + ->pp-rest + case-> + opt-> + opt->* + unconstrained-domain-> + check-procedure) - ;; - ;; arrow opter - ;; - (define/opter (-> opt/i opt/info stx) - (define (opt/arrow-ctc doms rngs) - (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) - (generate-temporaries rngs))] - [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) - (let loop ([vars dom-vars] - [doms doms] - [next-doms null] - [lifts-doms null] - [superlifts-doms null] - [partials-doms null] - [stronger-ribs null]) - (cond - [(null? doms) (values (reverse next-doms) - lifts-doms - superlifts-doms - partials-doms - stronger-ribs)] - [else - (let-values ([(next lift superlift partial _ __ this-stronger-ribs) - (opt/i (opt/info-swap-blame opt/info) (car doms))]) - (loop (cdr vars) - (cdr doms) - (cons (with-syntax ((next next) - (car-vars (car vars))) - (syntax (let ((val car-vars)) next))) - next-doms) - (append lifts-doms lift) - (append superlifts-doms superlift) - (append partials-doms partial) - (append this-stronger-ribs stronger-ribs)))]))] - [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng) - (let loop ([vars rng-vars] - [rngs rngs] - [next-rngs null] - [lifts-rngs null] - [superlifts-rngs null] - [partials-rngs null] - [stronger-ribs null]) - (cond - [(null? rngs) (values (reverse next-rngs) - lifts-rngs - superlifts-rngs - partials-rngs - stronger-ribs)] - [else - (let-values ([(next lift superlift partial _ __ this-stronger-ribs) - (opt/i opt/info (car rngs))]) - (loop (cdr vars) - (cdr rngs) - (cons (with-syntax ((next next) - (car-vars (car vars))) - (syntax (let ((val car-vars)) next))) - next-rngs) - (append lifts-rngs lift) - (append superlifts-rngs superlift) - (append partials-rngs partial) - (append this-stronger-ribs stronger-ribs)))]))]) - (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - ((dom-arg ...) dom-vars) - ((rng-arg ...) rng-vars) - ((next-dom ...) next-doms) - (dom-len (length dom-vars)) - ((next-rng ...) next-rngs)) - (syntax (begin - (check-procedure val dom-len src-info pos orig-str) - (λ (dom-arg ...) - (let-values ([(rng-arg ...) (val next-dom ...)]) - (values next-rng ...)))))) - (append lifts-doms lifts-rngs) - (append superlifts-doms superlifts-rngs) - (append partials-doms partials-rngs) - #f - #f - (append stronger-ribs-dom stronger-ribs-rng)))) - - (define (opt/arrow-any-ctc doms) - (let*-values ([(dom-vars) (generate-temporaries doms)] - [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) - (let loop ([vars dom-vars] - [doms doms] - [next-doms null] - [lifts-doms null] - [superlifts-doms null] - [partials-doms null] - [stronger-ribs null]) - (cond - [(null? doms) (values (reverse next-doms) - lifts-doms - superlifts-doms - partials-doms - stronger-ribs)] - [else - (let-values ([(next lift superlift partial flat _ this-stronger-ribs) - (opt/i (opt/info-swap-blame opt/info) (car doms))]) - (loop (cdr vars) - (cdr doms) - (cons (with-syntax ((next next) - (car-vars (car vars))) - (syntax (let ((val car-vars)) next))) - next-doms) - (append lifts-doms lift) - (append superlifts-doms superlift) - (append partials-doms partial) - (append this-stronger-ribs stronger-ribs)))]))]) - (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - ((dom-arg ...) dom-vars) - ((next-dom ...) next-doms) - (dom-len (length dom-vars))) - (syntax (begin - (check-procedure val dom-len src-info pos orig-str) - (λ (dom-arg ...) - (val next-dom ...))))) - lifts-doms - superlifts-doms - partials-doms - #f - #f - stronger-ribs-dom))) - - (syntax-case* stx (-> values any) module-or-top-identifier=? - [(-> dom ... (values rng ...)) - (opt/arrow-ctc (syntax->list (syntax (dom ...))) - (syntax->list (syntax (rng ...))))] - [(-> dom ... any) - (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] - [(-> dom ... rng) - (opt/arrow-ctc (syntax->list (syntax (dom ...))) - (list #'rng))]))) +(define-syntax (unconstrained-domain-> stx) + (syntax-case stx () + [(_ rngs ...) + (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))] + [(proj-x ...) (generate-temporaries #'(rngs ...))] + [(p-app-x ...) (generate-temporaries #'(rngs ...))] + [(res-x ...) (generate-temporaries #'(rngs ...))]) + #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) + (let ([proj-x ((proj-get rngs-x) rngs-x)] ...) + (make-proj-contract + (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) + (λ (pos-blame neg-blame src-info orig-str) + (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...) + (λ (val) + (if (procedure? val) + (λ args + (let-values ([(res-x ...) (apply val args)]) + (values (p-app-x res-x) ...))) + (raise-contract-error val + src-info + pos-blame + orig-str + "expected a procedure"))))) + procedure?))))])) + +;; FIXME: need to pass in the name of the contract combinator. +(define (build--> name doms doms-rest rngs rng-any? func) + (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] + [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)] + [doms-rest/c (and doms-rest (coerce-contract name doms-rest))]) + (make--> rng-any? doms/c doms-rest/c rngs/c func))) + +(define-struct/prop -> (rng-any? doms dom-rest rngs func) + ((proj-prop (λ (ctc) + (let* ([doms/c (map (λ (x) ((proj-get x) x)) + (if (->-dom-rest ctc) + (append (->-doms ctc) (list (->-dom-rest ctc))) + (->-doms ctc)))] + [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] + [func (->-func ctc)] + [dom-length (length (->-doms ctc))] + [check-proc + (if (->-dom-rest ctc) + check-procedure/more + check-procedure)]) + (lambda (pos-blame neg-blame src-info orig-str) + (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str)) + doms/c)] + [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str)) + rngs/c)]) + (apply func + (λ (val) (check-proc val dom-length src-info pos-blame orig-str)) + (append partial-doms partial-ranges))))))) + (name-prop (λ (ctc) (single-arrow-name-maker + (->-doms ctc) + (->-dom-rest ctc) + (->-rng-any? ctc) + (->-rngs ctc)))) + (first-order-prop + (λ (ctc) + (let ([l (length (->-doms ctc))]) + (if (->-dom-rest ctc) + (λ (x) + (and (procedure? x) + (procedure-accepts-and-more? x l))) + (λ (x) + (and (procedure? x) + (procedure-arity-includes? x l))))))) + (stronger-prop + (λ (this that) + (and (->? that) + (= (length (->-doms that)) + (length (->-doms this))) + (andmap contract-stronger? + (->-doms that) + (->-doms this)) + (= (length (->-rngs that)) + (length (->-rngs this))) + (andmap contract-stronger? + (->-rngs this) + (->-rngs that))))))) + +(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs) + (cond + [doms-rest + (build-compound-type-name + '->* + (apply build-compound-type-name doms/c) + doms-rest + (cond + [rng-any? 'any] + [else (apply build-compound-type-name rngs)]))] + [else + (let ([rng-name + (cond + [rng-any? 'any] + [(null? rngs) '(values)] + [(null? (cdr rngs)) (car rngs)] + [else (apply build-compound-type-name 'values rngs)])]) + (apply build-compound-type-name '-> (append doms/c (list rng-name))))])) + +(define-syntax-set (-> ->*) + (define (->/proc stx) + (let-values ([(stx _1 _2) (->/proc/main stx)]) + stx)) + + ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) + (define (->/proc/main stx) + (let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)]) + (with-syntax ([(args body) inner-args/body]) + (with-syntax ([(dom-names ...) dom-names] + [(rng-names ...) rng-names] + [(dom-ctcs ...) dom-ctcs] + [(rng-ctcs ...) rng-ctcs] + [inner-lambda + (add-name-prop + (syntax-local-infer-name stx) + (syntax (lambda args body)))] + [use-any? use-any?]) + (with-syntax ([outer-lambda + (let* ([lst (syntax->list #'args)] + [len (and lst (length lst))]) + (syntax + (lambda (chk dom-names ... rng-names ...) + (lambda (val) + (chk val) + inner-lambda))))]) + (values + (syntax (build--> '-> + (list dom-ctcs ...) + #f + (list rng-ctcs ...) + use-any? + outer-lambda)) + inner-args/body + (syntax (dom-names ... rng-names ...)))))))) + + (define (->-helper stx) + (syntax-case* stx (-> any values) module-or-top-identifier=? + [(-> doms ... any) + (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] + [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] + [(ignored) (generate-temporaries (syntax (rng)))]) + (values (syntax (dom-ctc ...)) + (syntax (ignored)) + (syntax (doms ...)) + (syntax (any/c)) + (syntax ((args ...) (val (dom-ctc args) ...))) + #t))] + [(-> doms ... (values rngs ...)) + (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] + [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] + [(rng-x ...) (generate-temporaries (syntax (rngs ...)))] + [(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))]) + (values (syntax (dom-ctc ...)) + (syntax (rng-ctc ...)) + (syntax (doms ...)) + (syntax (rngs ...)) + (syntax ((args ...) + (let-values ([(rng-x ...) (val (dom-ctc args) ...)]) + (values (rng-ctc rng-x) ...)))) + #f))] + [(_ doms ... rng) + (with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))] + [(dom-ctc ...) (generate-temporaries (syntax (doms ...)))] + [(rng-ctc) (generate-temporaries (syntax (rng)))]) + (values (syntax (dom-ctc ...)) + (syntax (rng-ctc)) + (syntax (doms ...)) + (syntax (rng)) + (syntax ((args ...) (rng-ctc (val (dom-ctc args) ...)))) + #f))])) + + (define (->*/proc stx) + (let-values ([(stx _1 _2) (->*/proc/main stx)]) + stx)) + + ;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names]) + (define (->*/proc/main stx) + (syntax-case* stx (->* any) module-or-top-identifier=? + [(->* (doms ...) any) + (->/proc/main (syntax (-> doms ... any)))] + [(->* (doms ...) (rngs ...)) + (->/proc/main (syntax (-> doms ... (values rngs ...))))] + [(->* (doms ...) rst (rngs ...)) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))] + [(args ...) (generate-temporaries (syntax (doms ...)))] + [(rst-x) (generate-temporaries (syntax (rst)))] + [(rest-arg) (generate-temporaries (syntax (rst)))] + [(rng-x ...) (generate-temporaries (syntax (rngs ...)))] + [(rng-args ...) (generate-temporaries (syntax (rngs ...)))]) + (let ([inner-args/body + (syntax ((args ... . rest-arg) + (let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))]) + (values (rng-x rng-args) ...))))]) + (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body]) + (add-name-prop + (syntax-local-infer-name stx) + (syntax (lambda args body))))]) + (with-syntax ([outer-lambda + (syntax + (lambda (chk dom-x ... rst-x rng-x ...) + (lambda (val) + (chk val) + inner-lambda)))]) + (values (syntax (build--> '->* + (list doms ...) + rst + (list rngs ...) + #f + outer-lambda)) + inner-args/body + (syntax (dom-x ... rst-x rng-x ...)))))))] + [(->* (doms ...) rst any) + (with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))] + [(args ...) (generate-temporaries (syntax (doms ...)))] + [(rst-x) (generate-temporaries (syntax (rst)))] + [(rest-arg) (generate-temporaries (syntax (rst)))]) + (let ([inner-args/body + (syntax ((args ... . rest-arg) + (apply val (dom-x args) ... (rst-x rest-arg))))]) + (with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body]) + (add-name-prop + (syntax-local-infer-name stx) + (syntax (lambda args body))))]) + (with-syntax ([outer-lambda + (syntax + (lambda (chk dom-x ... rst-x ignored) + (lambda (val) + (chk val) + inner-lambda)))]) + (values (syntax (build--> '->* + (list doms ...) + rst + (list any/c) + #t + outer-lambda)) + inner-args/body + (syntax (dom-x ... rst-x)))))))]))) + +(define-for-syntax (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-syntax (->d stx) (make-/proc #f ->d/h stx)) +(define-syntax (->d* stx) (make-/proc #f ->d*/h stx)) +(define-syntax (->r stx) (make-/proc #f ->r/h stx)) +(define-syntax (->pp stx) (make-/proc #f ->pp/h stx)) +(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx)) +(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h)) +(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->)) +(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->)) + +;; +;; arrow opter +;; +(define/opter (-> opt/i opt/info stx) + (define (opt/arrow-ctc doms rngs) + (let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms) + (generate-temporaries rngs))] + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) + (let loop ([vars dom-vars] + [doms doms] + [next-doms null] + [lifts-doms null] + [superlifts-doms null] + [partials-doms null] + [stronger-ribs null]) + (cond + [(null? doms) (values (reverse next-doms) + lifts-doms + superlifts-doms + partials-doms + stronger-ribs)] + [else + (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (opt/i (opt/info-swap-blame opt/info) (car doms))]) + (loop (cdr vars) + (cdr doms) + (cons (with-syntax ((next next) + (car-vars (car vars))) + (syntax (let ((val car-vars)) next))) + next-doms) + (append lifts-doms lift) + (append superlifts-doms superlift) + (append partials-doms partial) + (append this-stronger-ribs stronger-ribs)))]))] + [(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng) + (let loop ([vars rng-vars] + [rngs rngs] + [next-rngs null] + [lifts-rngs null] + [superlifts-rngs null] + [partials-rngs null] + [stronger-ribs null]) + (cond + [(null? rngs) (values (reverse next-rngs) + lifts-rngs + superlifts-rngs + partials-rngs + stronger-ribs)] + [else + (let-values ([(next lift superlift partial _ __ this-stronger-ribs) + (opt/i opt/info (car rngs))]) + (loop (cdr vars) + (cdr rngs) + (cons (with-syntax ((next next) + (car-vars (car vars))) + (syntax (let ((val car-vars)) next))) + next-rngs) + (append lifts-rngs lift) + (append superlifts-rngs superlift) + (append partials-rngs partial) + (append this-stronger-ribs stronger-ribs)))]))]) + (values + (with-syntax ((pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + ((dom-arg ...) dom-vars) + ((rng-arg ...) rng-vars) + ((next-dom ...) next-doms) + (dom-len (length dom-vars)) + ((next-rng ...) next-rngs)) + (syntax (begin + (check-procedure val dom-len src-info pos orig-str) + (λ (dom-arg ...) + (let-values ([(rng-arg ...) (val next-dom ...)]) + (values next-rng ...)))))) + (append lifts-doms lifts-rngs) + (append superlifts-doms superlifts-rngs) + (append partials-doms partials-rngs) + #f + #f + (append stronger-ribs-dom stronger-ribs-rng)))) + + (define (opt/arrow-any-ctc doms) + (let*-values ([(dom-vars) (generate-temporaries doms)] + [(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom) + (let loop ([vars dom-vars] + [doms doms] + [next-doms null] + [lifts-doms null] + [superlifts-doms null] + [partials-doms null] + [stronger-ribs null]) + (cond + [(null? doms) (values (reverse next-doms) + lifts-doms + superlifts-doms + partials-doms + stronger-ribs)] + [else + (let-values ([(next lift superlift partial flat _ this-stronger-ribs) + (opt/i (opt/info-swap-blame opt/info) (car doms))]) + (loop (cdr vars) + (cdr doms) + (cons (with-syntax ((next next) + (car-vars (car vars))) + (syntax (let ((val car-vars)) next))) + next-doms) + (append lifts-doms lift) + (append superlifts-doms superlift) + (append partials-doms partial) + (append this-stronger-ribs stronger-ribs)))]))]) + (values + (with-syntax ((pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + ((dom-arg ...) dom-vars) + ((next-dom ...) next-doms) + (dom-len (length dom-vars))) + (syntax (begin + (check-procedure val dom-len src-info pos orig-str) + (λ (dom-arg ...) + (val next-dom ...))))) + lifts-doms + superlifts-doms + partials-doms + #f + #f + stronger-ribs-dom))) + + (syntax-case* stx (-> values any) module-or-top-identifier=? + [(-> dom ... (values rng ...)) + (opt/arrow-ctc (syntax->list (syntax (dom ...))) + (syntax->list (syntax (rng ...))))] + [(-> dom ... any) + (opt/arrow-any-ctc (syntax->list (syntax (dom ...))))] + [(-> dom ... rng) + (opt/arrow-ctc (syntax->list (syntax (dom ...))) + (list #'rng))])) diff --git a/collects/scheme/private/contract-basic-opters.ss b/collects/scheme/private/contract-basic-opters.ss index 5fae2d3d12..119a3628d9 100644 --- a/collects/scheme/private/contract-basic-opters.ss +++ b/collects/scheme/private/contract-basic-opters.ss @@ -1,130 +1,132 @@ -(module contract-basic-opters mzscheme - (require "contract-guts.ss" - "contract-opt.ss" - "contract.ss") - (require-for-syntax "contract-opt-guts.ss") - - ;; - ;; opt/pred helper - ;; - (define-for-syntax (opt/pred opt/info pred) - (with-syntax ((pred pred)) - (values +#lang scheme/base + +(require "contract-guts.ss" + "contract-opt.ss" + "contract.ss") +(require (for-syntax scheme/base + "contract-opt-guts.ss")) + +;; +;; opt/pred helper +;; +(define-for-syntax (opt/pred opt/info pred) + (with-syntax ((pred pred)) + (values + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (if (pred val) + val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val)))) + null + null + null + (syntax (pred val)) + #f + null))) + +;; +;; built-in predicate opters +;; +(define/opter (null? opt/i opt/info stx) + (syntax-case stx (null?) + [null? (opt/pred opt/info #'null?)])) +(define/opter (boolean? opt/i opt/info stx) + (syntax-case stx (boolean?) + [boolean? (opt/pred opt/info #'boolean?)])) +(define/opter (integer? opt/i opt/info stx) + (syntax-case stx (integer?) + [integer? (opt/pred opt/info #'integer?)])) +(define/opter (char? opt/i opt/info stx) + (syntax-case stx (char?) + [char? (opt/pred opt/info #'char?)])) +(define/opter (number? opt/i opt/info stx) + (syntax-case stx (number?) + [number? (opt/pred opt/info #'number?)])) +(define/opter (pair? opt/i opt/info stx) + (syntax-case stx (pair?) + [pair? (opt/pred opt/info #'pair?)])) +(define/opter (not opt/i opt/info stx) + (syntax-case stx (not) + [not (opt/pred opt/info #'not)])) + +;; +;; any/c +;; +(define/opter (any/c opt/i opt/info stx) + (syntax-case stx (any/c) + [any/c (values + (opt/info-val opt/info) + null + null + null + #'#t + #f + null)])) + +;; +;; false/c +;; +(define/opter (false/c opt/i opt/info stx) + (syntax-case stx (false/c) + [false/c (opt/pred opt/info #'not)])) + +;; +;; flat-contract helper +;; +(define-for-syntax (opt/flat-ctc opt/info pred checker) + (syntax-case pred (null? number? integer? boolean? pair? not) + ;; Better way of doing this? + [null? (opt/pred opt/info pred)] + [number? (opt/pred opt/info pred)] + [integer? (opt/pred opt/info pred)] + [boolean? (opt/pred opt/info pred)] + [pair? (opt/pred opt/info pred)] + [pred + (let* ((lift-vars (generate-temporaries (syntax (pred error-check)))) + (lift-pred (car lift-vars))) (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) (pos (opt/info-pos opt/info)) (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info))) - (syntax (if (pred val) - val - (raise-contract-error + (orig-str (opt/info-orig-str opt/info)) + (lift-pred lift-pred)) + (values + (syntax (if (lift-pred val) val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val)))) - null - null - null - (syntax (pred val)) - #f - null))) - - ;; - ;; built-in predicate opters - ;; - (define/opter (null? opt/i opt/info stx) - (syntax-case stx (null?) - [null? (opt/pred opt/info #'null?)])) - (define/opter (boolean? opt/i opt/info stx) - (syntax-case stx (boolean?) - [boolean? (opt/pred opt/info #'boolean?)])) - (define/opter (integer? opt/i opt/info stx) - (syntax-case stx (integer?) - [integer? (opt/pred opt/info #'integer?)])) - (define/opter (char? opt/i opt/info stx) - (syntax-case stx (char?) - [char? (opt/pred opt/info #'char?)])) - (define/opter (number? opt/i opt/info stx) - (syntax-case stx (number?) - [number? (opt/pred opt/info #'number?)])) - (define/opter (pair? opt/i opt/info stx) - (syntax-case stx (pair?) - [pair? (opt/pred opt/info #'pair?)])) - (define/opter (not opt/i opt/info stx) - (syntax-case stx (not) - [not (opt/pred opt/info #'not)])) - - ;; - ;; any/c - ;; - (define/opter (any/c opt/i opt/info stx) - (syntax-case stx (any/c) - [any/c (values - (opt/info-val opt/info) - null - null - null - #'#t - #f - null)])) - - ;; - ;; false/c - ;; - (define/opter (false/c opt/i opt/info stx) - (syntax-case stx (false/c) - [false/c (opt/pred opt/info #'not)])) + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val))) + (interleave-lifts + lift-vars + (list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)] + [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)]))) + null + null + (syntax (lift-pred val)) + #f + null)))])) - ;; - ;; flat-contract helper - ;; - (define-for-syntax (opt/flat-ctc opt/info pred checker) - (syntax-case pred (null? number? integer? boolean? pair? not) - ;; Better way of doing this? - [null? (opt/pred opt/info pred)] - [number? (opt/pred opt/info pred)] - [integer? (opt/pred opt/info pred)] - [boolean? (opt/pred opt/info pred)] - [pair? (opt/pred opt/info pred)] - [pred - (let* ((lift-vars (generate-temporaries (syntax (pred error-check)))) - (lift-pred (car lift-vars))) - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (lift-pred lift-pred)) - (values - (syntax (if (lift-pred val) - val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val))) - (interleave-lifts - lift-vars - (list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)] - [(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)]))) - null - null - (syntax (lift-pred val)) - #f - null)))])) - - ;; - ;; flat-contract and friends - ;; - (define/opter (flat-contract opt/i opt/info stx) - (syntax-case stx (flat-contract) - [(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)])) - (define/opter (flat-named-contract opt/i opt/info stx) - (syntax-case stx (flat-named-contract) - [(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)]))) \ No newline at end of file +;; +;; flat-contract and friends +;; +(define/opter (flat-contract opt/i opt/info stx) + (syntax-case stx (flat-contract) + [(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)])) +(define/opter (flat-named-contract opt/i opt/info stx) + (syntax-case stx (flat-named-contract) + [(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)])) \ No newline at end of file diff --git a/collects/scheme/private/contract-ds-helpers.ss b/collects/scheme/private/contract-ds-helpers.ss index 5d487e75ec..39dd0b458d 100644 --- a/collects/scheme/private/contract-ds-helpers.ss +++ b/collects/scheme/private/contract-ds-helpers.ss @@ -1,13 +1,13 @@ -(module contract-ds-helpers mzscheme - (provide ensure-well-formed - build-func-params - build-clauses - build-enforcer-clauses - generate-arglists) - - (require (lib "list.ss") - "contract-opt-guts.ss") - (require-for-template mzscheme) +#lang scheme/base +(provide ensure-well-formed + build-func-params + build-clauses + build-enforcer-clauses + generate-arglists) + +(require "contract-opt-guts.ss") +(require (for-template scheme/base) + (for-syntax scheme/base)) #| @@ -32,356 +32,354 @@ which are then called when the contract's fields are explored |# - (define (build-clauses name coerce-contract stx clauses) - (let* ([field-names - (let loop ([clauses (syntax->list clauses)]) - (cond - [(null? clauses) null] - [else - (let ([clause (car clauses)]) - (syntax-case* clause (where and) raw-comparison? - [where null] - [and null] - [(id . whatever) (cons (syntax id) (loop (cdr clauses)))] - [else (raise-syntax-error name - "expected a field name and a contract together" - stx - clause)]))]))] - [all-ac-ids (generate-temporaries field-names)] - [defeat-inlining - ;; makes the procedure confusing enough so that - ;; inlining doesn't consider it. this makes the - ;; call to procedure-closure-contents-eq? work - ;; properly - (λ (e) - (let loop ([n 20]) - (if (zero? n) - e - #`(if (zero? (random 1)) - #,(loop (- n 1)) - (/ 1 0)))))]) - (let loop ([clauses (syntax->list clauses)] - [ac-ids all-ac-ids] - [prior-ac-ids '()] - [maker-args '()]) - (cond - [(null? clauses) - (with-syntax ([(maker-args ...) (reverse maker-args)]) - (syntax ((maker-args ... #f) - ())))] - [else - (let ([clause (car clauses)]) - (syntax-case* clause (and where) raw-comparison? - [where - (build-clauses/where name stx (cdr clauses) field-names (reverse maker-args))] - [and - (build-clauses/and name stx (cdr clauses) '() '() (reverse maker-args))] - [else - (let ([ac-id (car ac-ids)]) - (syntax-case clause () - [(id (x ...) ctc-exp) - (and (identifier? (syntax id)) - (andmap identifier? (syntax->list (syntax (x ...))))) - (let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids) - (syntax (x ...)) - field-names) - #,(defeat-inlining - #`(#,coerce-contract '#,name ctc-exp)))]) - (loop (cdr clauses) - (cdr ac-ids) - (cons (car ac-ids) prior-ac-ids) - (cons maker-arg maker-args)))] - [(id (x ...) ctc-exp) - (begin - (unless (identifier? (syntax id)) - (raise-syntax-error name "expected identifier" stx (syntax id))) - (for-each (λ (x) (unless (identifier? x) - (raise-syntax-error name "expected identifier" stx x))) - (syntax->list (syntax (x ...)))))] - [(id ctc-exp) - (identifier? (syntax id)) +(define (build-clauses name coerce-contract stx clauses) + (let* ([field-names + (let loop ([clauses (syntax->list clauses)]) + (cond + [(null? clauses) null] + [else + (let ([clause (car clauses)]) + (syntax-case* clause (where and) raw-comparison? + [where null] + [and null] + [(id . whatever) (cons (syntax id) (loop (cdr clauses)))] + [else (raise-syntax-error name + "expected a field name and a contract together" + stx + clause)]))]))] + [all-ac-ids (generate-temporaries field-names)] + [defeat-inlining + ;; makes the procedure confusing enough so that + ;; inlining doesn't consider it. this makes the + ;; call to procedure-closure-contents-eq? work + ;; properly + (λ (e) + (let loop ([n 20]) + (if (zero? n) + e + #`(if (zero? (random 1)) + #,(loop (- n 1)) + (/ 1 0)))))]) + (let loop ([clauses (syntax->list clauses)] + [ac-ids all-ac-ids] + [prior-ac-ids '()] + [maker-args '()]) + (cond + [(null? clauses) + (with-syntax ([(maker-args ...) (reverse maker-args)]) + (syntax ((maker-args ... #f) + ())))] + [else + (let ([clause (car clauses)]) + (syntax-case* clause (and where) raw-comparison? + [where + (build-clauses/where name stx (cdr clauses) field-names (reverse maker-args))] + [and + (build-clauses/and name stx (cdr clauses) '() '() (reverse maker-args))] + [else + (let ([ac-id (car ac-ids)]) + (syntax-case clause () + [(id (x ...) ctc-exp) + (and (identifier? (syntax id)) + (andmap identifier? (syntax->list (syntax (x ...))))) + (let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids) + (syntax (x ...)) + field-names) + #,(defeat-inlining + #`(#,coerce-contract '#,name ctc-exp)))]) (loop (cdr clauses) (cdr ac-ids) (cons (car ac-ids) prior-ac-ids) - (cons #`(#,coerce-contract '#,name ctc-exp) maker-args))] - [(id ctc-exp) - (raise-syntax-error name "expected identifier" stx (syntax id))] - [_ - (raise-syntax-error name "expected name/identifier binding" stx clause)]))]))])))) - - (define (build-clauses/where name stx clauses field-names maker-args) - (with-syntax ([(field-names ...) field-names]) - (let loop ([clauses clauses] - [vars '()] - [procs '()]) - (cond - [(null? clauses) - ;; if there is no `and' clause, assume that it is always satisfied - (build-clauses/and name stx (list (syntax #t)) vars procs maker-args)] - [else - (let ([clause (car clauses)]) - (syntax-case* clause (and) raw-comparison? - [and (build-clauses/and name stx (cdr clauses) vars procs maker-args)] - [(id exp) - (identifier? (syntax id)) - (loop (cdr clauses) - (cons (syntax id) vars) - (cons (syntax (λ (field-names ...) exp)) procs))] - [(id exp) - (raise-syntax-error name "expected an identifier" stx (syntax id))] - [_ - (raise-syntax-error name "expected an identifier and an expression" stx clause)]))])))) - - - - (define (build-enforcer-clauses opt/i opt/info name stx clauses f-x/vals f-xs/vals - helper-id helper-info helper-freev) - (define (opt/enforcer-clause id stx) - (syntax-case stx () - [(f arg ...) - ;; we need to override the default optimization of recursive calls to use our helper - (and (opt/info-recf opt/info) (module-identifier=? (opt/info-recf opt/info) #'f)) - (values - #`(f #,id arg ...) - null - null - null - #f - #f - null)] - [else (opt/i (opt/info-change-val id opt/info) - stx)])) + (cons maker-arg maker-args)))] + [(id (x ...) ctc-exp) + (begin + (unless (identifier? (syntax id)) + (raise-syntax-error name "expected identifier" stx (syntax id))) + (for-each (λ (x) (unless (identifier? x) + (raise-syntax-error name "expected identifier" stx x))) + (syntax->list (syntax (x ...)))))] + [(id ctc-exp) + (identifier? (syntax id)) + (loop (cdr clauses) + (cdr ac-ids) + (cons (car ac-ids) prior-ac-ids) + (cons #`(#,coerce-contract '#,name ctc-exp) maker-args))] + [(id ctc-exp) + (raise-syntax-error name "expected identifier" stx (syntax id))] + [_ + (raise-syntax-error name "expected name/identifier binding" stx clause)]))]))])))) - (let* ([field-names - (map (λ (clause) - (syntax-case clause () - [(id . whatever) (syntax id)] - [else (raise-syntax-error name - "expected a field name and a contract together" - stx - clause)])) - (syntax->list clauses))] - [all-ac-ids (generate-temporaries field-names)]) - (let loop ([clauses (syntax->list clauses)] - [let-vars f-x/vals] - [arglists f-xs/vals] - [ac-ids all-ac-ids] - [prior-ac-ids '()] - [maker-args '()] - [lifts-ps '()] - [superlifts-ps '()] - [stronger-ribs-ps '()]) - (cond - [(null? clauses) - (values (reverse maker-args) - lifts-ps - superlifts-ps - stronger-ribs-ps)] - [else - (let ([clause (car clauses)] - [let-var (car let-vars)] - [arglist (car arglists)] - [ac-id (car ac-ids)]) - (syntax-case clause () - [(id (x ...) ctc-exp) - (and (identifier? (syntax id)) - (andmap identifier? (syntax->list (syntax (x ...))))) - (let*-values ([(next lifts superlifts partials _ _2 _3) - (opt/enforcer-clause let-var (syntax ctc-exp))] - [(maker-arg) - (with-syntax ([val (opt/info-val opt/info)] - [(new-let-bindings ...) - (match-up/bind (reverse prior-ac-ids) - (syntax (x ...)) - field-names - arglist)]) - #`(#,let-var - #,(bind-lifts - superlifts - #`(let (new-let-bindings ...) - #,(bind-lifts - (append lifts partials) - next)))))]) - (loop (cdr clauses) - (cdr let-vars) - (cdr arglists) - (cdr ac-ids) - (cons (car ac-ids) prior-ac-ids) - (cons maker-arg maker-args) - lifts-ps - superlifts-ps - stronger-ribs-ps))] - [(id (x ...) ctc-exp) - (begin - (unless (identifier? (syntax id)) - (raise-syntax-error name "expected identifier" stx (syntax id))) - (for-each (λ (x) (unless (identifier? x) - (raise-syntax-error name "expected identifier" stx x))) - (syntax->list (syntax (x ...)))))] - [(id ctc-exp) - (identifier? (syntax id)) - (let*-values ([(next lifts superlifts partials _ __ stronger-ribs) - (opt/enforcer-clause let-var (syntax ctc-exp))] - [(maker-arg) - (with-syntax ((val (opt/info-val opt/info))) - #`(#,let-var - #,(bind-lifts - partials - next)))]) - (loop (cdr clauses) - (cdr let-vars) - (cdr arglists) - (cdr ac-ids) - (cons (car ac-ids) prior-ac-ids) - (cons maker-arg maker-args) - (append lifts-ps lifts) - (append superlifts-ps superlifts) - (append stronger-ribs-ps stronger-ribs)))] - [(id ctc-exp) - (raise-syntax-error name "expected identifier" stx (syntax id))]))])))) - - (define (build-clauses/and name stx clauses synth-names synth-procs maker-args) - (unless (pair? clauses) - (raise-syntax-error name "expected an expression after `and' keyword" stx)) - (unless (null? (cdr clauses)) - (raise-syntax-error name "expected only one expression after `and' keyword" stx (cadr clauses))) - (with-syntax ([(maker-args ...) maker-args] - [(synth-names ...) synth-names] - [(synth-procs ...) synth-procs] - [exp (car clauses)]) - (syntax ((maker-args ... (list (λ (ht) (let ([synth-names (hash-table-get ht 'synth-names)] ...) exp)) - (cons 'synth-names synth-procs) ...)) - (synth-names ...))))) - - (define (raw-comparison? x y) - (and (identifier? x) - (identifier? y) - (eq? (syntax-e x) (syntax-e y)))) - - ;; generate-arglists : (listof X) -> (listof (listof X)) - ;; produces the list of arguments to the dependent contract - ;; functions, given the names of some variables. - ;; eg: (generate-arglists '(x y z w)) - ;; = (list '() '(x) '(x y) '(x y z)) - (define (generate-arglists vars) - (reverse - (let loop ([vars (reverse vars)]) - (cond - [(null? vars) null] - [else (cons (reverse (cdr vars)) - (loop (cdr vars)))])))) - - (define (match-up/bind prior-ac-ids used-field-names field-names rhss) - (let ([used-field-ids (syntax->list used-field-names)]) - (let loop ([prior-ac-ids prior-ac-ids] - [field-names field-names] - [rhss rhss]) - (cond - [(null? prior-ac-ids) null] - [else (let* ([ac-id (car prior-ac-ids)] - [field-name (car field-names)] - [id-used - (ormap (λ (used-field-id) - (and (eq? (syntax-e field-name) (syntax-e used-field-id)) - used-field-id)) - used-field-ids)]) - (if id-used - (cons (with-syntax ([id id-used] - [arg (car rhss)]) - #'[id arg]) - (loop (cdr prior-ac-ids) - (cdr field-names) - (cdr rhss))) - (loop (cdr prior-ac-ids) - (cdr field-names) - (cdr rhss))))])))) - - (define (match-up prior-ac-ids used-field-names field-names) - (let ([used-field-ids (syntax->list used-field-names)]) - (let loop ([prior-ac-ids prior-ac-ids] - [field-names field-names]) - (cond - [(null? prior-ac-ids) null] - [else (let* ([ac-id (car prior-ac-ids)] - [field-name (car field-names)] - [id-used - (ormap (λ (used-field-id) - (and (eq? (syntax-e field-name) (syntax-e used-field-id)) - used-field-id)) - used-field-ids)]) - (if id-used - (cons id-used - (loop (cdr prior-ac-ids) - (cdr field-names))) - (cons (car (generate-temporaries '(ignored-arg))) - (loop (cdr prior-ac-ids) - (cdr field-names)))))])))) - - (define (sort-wrt name stx ids current-order-field-names desired-order-field-names) - (let ([id/user-specs (map cons ids current-order-field-names)] - [ht (make-hash-table)]) - (let loop ([i 0] - [orig-field-names desired-order-field-names]) - (unless (null? orig-field-names) - (hash-table-put! ht (syntax-e (car orig-field-names)) i) - (loop (+ i 1) (cdr orig-field-names)))) - (let* ([lookup - (λ (id-pr) - (let ([id (car id-pr)] - [use-field-name (cdr id-pr)]) - (hash-table-get ht - (syntax-e use-field-name) - (λ () - (raise-syntax-error name "unknown field name" stx use-field-name)))))] - [cmp (λ (x y) (<= (lookup x) (lookup y)))] - [sorted-id/user-specs (sort id/user-specs cmp)]) - (map car sorted-id/user-specs)))) - +(define (build-clauses/where name stx clauses field-names maker-args) + (with-syntax ([(field-names ...) field-names]) + (let loop ([clauses clauses] + [vars '()] + [procs '()]) + (cond + [(null? clauses) + ;; if there is no `and' clause, assume that it is always satisfied + (build-clauses/and name stx (list (syntax #t)) vars procs maker-args)] + [else + (let ([clause (car clauses)]) + (syntax-case* clause (and) raw-comparison? + [and (build-clauses/and name stx (cdr clauses) vars procs maker-args)] + [(id exp) + (identifier? (syntax id)) + (loop (cdr clauses) + (cons (syntax id) vars) + (cons (syntax (λ (field-names ...) exp)) procs))] + [(id exp) + (raise-syntax-error name "expected an identifier" stx (syntax id))] + [_ + (raise-syntax-error name "expected an identifier and an expression" stx clause)]))])))) - (define (find-matching all-ac-ids chosen-ids field-names) - (map (λ (chosen-id) - (let* ([chosen-sym (syntax-e chosen-id)] - [id (ormap (λ (ac-id field-name) - (and (eq? (syntax-e field-name) chosen-sym) - ac-id)) - all-ac-ids - field-names)]) - (unless id - (error 'find-matching "could not find matching for ~s" chosen-id)) - id)) - (syntax->list chosen-ids))) - - (define (build-func-params ids) - (let ([temps (generate-temporaries ids)]) - (let loop ([ids (syntax->list ids)] - [temps temps] - [can-refer-to '()]) - (cond - [(null? ids) null] - [else (cons - (append (reverse can-refer-to) temps) - (loop (cdr ids) - (cdr temps) - (cons (car ids) can-refer-to)))])))) - - (define (ensure-well-formed stx field-count) + +(define (build-enforcer-clauses opt/i opt/info name stx clauses f-x/vals f-xs/vals + helper-id helper-info helper-freev) + (define (opt/enforcer-clause id stx) (syntax-case stx () - [(_ [id exp] ...) - (and (andmap identifier? (syntax->list (syntax (id ...)))) - (equal? (length (syntax->list (syntax (id ...)))) - field-count)) - (void)] - [(_ [id exp] ...) - (andmap identifier? (syntax->list (syntax (id ...)))) - (raise-syntax-error 'struct/dc - (format "expected ~a clauses, but found ~a" - field-count - (length (syntax->list (syntax (id ...))))) - stx)] - [(_ [id exp] ...) - (for-each - (λ (id) (unless (identifier? id) (raise-syntax-error 'struct/dc "expected identifier" stx id))) - (syntax->list (syntax (id ...))))]))) - + [(f arg ...) + ;; we need to override the default optimization of recursive calls to use our helper + (and (opt/info-recf opt/info) (free-identifier=? (opt/info-recf opt/info) #'f)) + (values + #`(f #,id arg ...) + null + null + null + #f + #f + null)] + [else (opt/i (opt/info-change-val id opt/info) + stx)])) + (let* ([field-names + (map (λ (clause) + (syntax-case clause () + [(id . whatever) (syntax id)] + [else (raise-syntax-error name + "expected a field name and a contract together" + stx + clause)])) + (syntax->list clauses))] + [all-ac-ids (generate-temporaries field-names)]) + (let loop ([clauses (syntax->list clauses)] + [let-vars f-x/vals] + [arglists f-xs/vals] + [ac-ids all-ac-ids] + [prior-ac-ids '()] + [maker-args '()] + [lifts-ps '()] + [superlifts-ps '()] + [stronger-ribs-ps '()]) + (cond + [(null? clauses) + (values (reverse maker-args) + lifts-ps + superlifts-ps + stronger-ribs-ps)] + [else + (let ([clause (car clauses)] + [let-var (car let-vars)] + [arglist (car arglists)] + [ac-id (car ac-ids)]) + (syntax-case clause () + [(id (x ...) ctc-exp) + (and (identifier? (syntax id)) + (andmap identifier? (syntax->list (syntax (x ...))))) + (let*-values ([(next lifts superlifts partials _ _2 _3) + (opt/enforcer-clause let-var (syntax ctc-exp))] + [(maker-arg) + (with-syntax ([val (opt/info-val opt/info)] + [(new-let-bindings ...) + (match-up/bind (reverse prior-ac-ids) + (syntax (x ...)) + field-names + arglist)]) + #`(#,let-var + #,(bind-lifts + superlifts + #`(let (new-let-bindings ...) + #,(bind-lifts + (append lifts partials) + next)))))]) + (loop (cdr clauses) + (cdr let-vars) + (cdr arglists) + (cdr ac-ids) + (cons (car ac-ids) prior-ac-ids) + (cons maker-arg maker-args) + lifts-ps + superlifts-ps + stronger-ribs-ps))] + [(id (x ...) ctc-exp) + (begin + (unless (identifier? (syntax id)) + (raise-syntax-error name "expected identifier" stx (syntax id))) + (for-each (λ (x) (unless (identifier? x) + (raise-syntax-error name "expected identifier" stx x))) + (syntax->list (syntax (x ...)))))] + [(id ctc-exp) + (identifier? (syntax id)) + (let*-values ([(next lifts superlifts partials _ __ stronger-ribs) + (opt/enforcer-clause let-var (syntax ctc-exp))] + [(maker-arg) + (with-syntax ((val (opt/info-val opt/info))) + #`(#,let-var + #,(bind-lifts + partials + next)))]) + (loop (cdr clauses) + (cdr let-vars) + (cdr arglists) + (cdr ac-ids) + (cons (car ac-ids) prior-ac-ids) + (cons maker-arg maker-args) + (append lifts-ps lifts) + (append superlifts-ps superlifts) + (append stronger-ribs-ps stronger-ribs)))] + [(id ctc-exp) + (raise-syntax-error name "expected identifier" stx (syntax id))]))])))) + +(define (build-clauses/and name stx clauses synth-names synth-procs maker-args) + (unless (pair? clauses) + (raise-syntax-error name "expected an expression after `and' keyword" stx)) + (unless (null? (cdr clauses)) + (raise-syntax-error name "expected only one expression after `and' keyword" stx (cadr clauses))) + (with-syntax ([(maker-args ...) maker-args] + [(synth-names ...) synth-names] + [(synth-procs ...) synth-procs] + [exp (car clauses)]) + (syntax ((maker-args ... (list (λ (ht) (let ([synth-names (hash-table-get ht 'synth-names)] ...) exp)) + (cons 'synth-names synth-procs) ...)) + (synth-names ...))))) + +(define (raw-comparison? x y) + (and (identifier? x) + (identifier? y) + (eq? (syntax-e x) (syntax-e y)))) + +;; generate-arglists : (listof X) -> (listof (listof X)) +;; produces the list of arguments to the dependent contract +;; functions, given the names of some variables. +;; eg: (generate-arglists '(x y z w)) +;; = (list '() '(x) '(x y) '(x y z)) +(define (generate-arglists vars) + (reverse + (let loop ([vars (reverse vars)]) + (cond + [(null? vars) null] + [else (cons (reverse (cdr vars)) + (loop (cdr vars)))])))) + +(define (match-up/bind prior-ac-ids used-field-names field-names rhss) + (let ([used-field-ids (syntax->list used-field-names)]) + (let loop ([prior-ac-ids prior-ac-ids] + [field-names field-names] + [rhss rhss]) + (cond + [(null? prior-ac-ids) null] + [else (let* ([ac-id (car prior-ac-ids)] + [field-name (car field-names)] + [id-used + (ormap (λ (used-field-id) + (and (eq? (syntax-e field-name) (syntax-e used-field-id)) + used-field-id)) + used-field-ids)]) + (if id-used + (cons (with-syntax ([id id-used] + [arg (car rhss)]) + #'[id arg]) + (loop (cdr prior-ac-ids) + (cdr field-names) + (cdr rhss))) + (loop (cdr prior-ac-ids) + (cdr field-names) + (cdr rhss))))])))) + +(define (match-up prior-ac-ids used-field-names field-names) + (let ([used-field-ids (syntax->list used-field-names)]) + (let loop ([prior-ac-ids prior-ac-ids] + [field-names field-names]) + (cond + [(null? prior-ac-ids) null] + [else (let* ([ac-id (car prior-ac-ids)] + [field-name (car field-names)] + [id-used + (ormap (λ (used-field-id) + (and (eq? (syntax-e field-name) (syntax-e used-field-id)) + used-field-id)) + used-field-ids)]) + (if id-used + (cons id-used + (loop (cdr prior-ac-ids) + (cdr field-names))) + (cons (car (generate-temporaries '(ignored-arg))) + (loop (cdr prior-ac-ids) + (cdr field-names)))))])))) + +(define (sort-wrt name stx ids current-order-field-names desired-order-field-names) + (let ([id/user-specs (map cons ids current-order-field-names)] + [ht (make-hash-table)]) + (let loop ([i 0] + [orig-field-names desired-order-field-names]) + (unless (null? orig-field-names) + (hash-table-put! ht (syntax-e (car orig-field-names)) i) + (loop (+ i 1) (cdr orig-field-names)))) + (let* ([lookup + (λ (id-pr) + (let ([id (car id-pr)] + [use-field-name (cdr id-pr)]) + (hash-table-get ht + (syntax-e use-field-name) + (λ () + (raise-syntax-error name "unknown field name" stx use-field-name)))))] + [cmp (λ (x y) (<= (lookup x) (lookup y)))] + [sorted-id/user-specs (sort id/user-specs cmp)]) + (map car sorted-id/user-specs)))) + + +(define (find-matching all-ac-ids chosen-ids field-names) + (map (λ (chosen-id) + (let* ([chosen-sym (syntax-e chosen-id)] + [id (ormap (λ (ac-id field-name) + (and (eq? (syntax-e field-name) chosen-sym) + ac-id)) + all-ac-ids + field-names)]) + (unless id + (error 'find-matching "could not find matching for ~s" chosen-id)) + id)) + (syntax->list chosen-ids))) + + +(define (build-func-params ids) + (let ([temps (generate-temporaries ids)]) + (let loop ([ids (syntax->list ids)] + [temps temps] + [can-refer-to '()]) + (cond + [(null? ids) null] + [else (cons + (append (reverse can-refer-to) temps) + (loop (cdr ids) + (cdr temps) + (cons (car ids) can-refer-to)))])))) + +(define (ensure-well-formed stx field-count) + (syntax-case stx () + [(_ [id exp] ...) + (and (andmap identifier? (syntax->list (syntax (id ...)))) + (equal? (length (syntax->list (syntax (id ...)))) + field-count)) + (void)] + [(_ [id exp] ...) + (andmap identifier? (syntax->list (syntax (id ...)))) + (raise-syntax-error 'struct/dc + (format "expected ~a clauses, but found ~a" + field-count + (length (syntax->list (syntax (id ...))))) + stx)] + [(_ [id exp] ...) + (for-each + (λ (id) (unless (identifier? id) (raise-syntax-error 'struct/dc "expected identifier" stx id))) + (syntax->list (syntax (id ...))))])) \ No newline at end of file diff --git a/collects/scheme/private/contract-ds.ss b/collects/scheme/private/contract-ds.ss index c3dbbe3f36..87ca1cf48f 100644 --- a/collects/scheme/private/contract-ds.ss +++ b/collects/scheme/private/contract-ds.ss @@ -1,3 +1,5 @@ +#lang scheme/base + #| Need to break the parent pointer links at some point. @@ -15,542 +17,541 @@ it around flattened out. |# +(require "contract-guts.ss" + "contract-opt.ss" + "contract-ds-helpers.ss" + (lib "etc.ss")) +(require (for-syntax scheme/base) + (for-syntax "contract-ds-helpers.ss") + (for-syntax "contract-helpers.ss") + (for-syntax "contract-opt-guts.ss") + (for-syntax (lib "etc.ss"))) -(module contract-ds mzscheme - (require "contract-guts.ss" - "contract-opt.ss" - "contract-ds-helpers.ss" - (lib "etc.ss")) - (require-for-syntax "contract-ds-helpers.ss" - "contract-helpers.ss" - "contract-opt-guts.ss" - (lib "etc.ss")) - - (provide define-contract-struct - - make-opt-contract/info - set-opt-contract/info-enforcer! - opt-contract/info-contract - opt-contract/info-id - opt-contract/info-enforcer - lazy-depth-to-look - - unknown? - synthesized-value) - - (define-syntax (define-contract-struct stx) - (syntax-case stx () - [(_ name (fields ...)) - (syntax (define-contract-struct name (fields ...) (current-inspector)))] - [(_ name (fields ...) inspector) - (and (identifier? (syntax name)) - (andmap identifier? (syntax->list (syntax (fields ...))))) - (let* ([mutable? (syntax-e (syntax mutable?))] - [add-suffix - (λ (suffix) - (datum->syntax-object (syntax name) - (string->symbol - (string-append (symbol->string (syntax-e (syntax name))) - suffix)) - stx))] - [struct-names (build-struct-names (syntax name) - (syntax->list (syntax (fields ...))) - #f - #t - stx)] - [struct:-name/val (list-ref struct-names 0)] - [struct-maker/val (list-ref struct-names 1)] - [predicate/val (list-ref struct-names 2)] - [selectors/val (cdddr struct-names)] - [struct/c-name/val (add-suffix "/c")] - [struct/dc-name/val (add-suffix "/dc")] - [field-count/val (length selectors/val)] - [f-x/vals (generate-temporaries (syntax (fields ...)))] - [f-xs/vals (generate-arglists f-x/vals)]) - - (with-syntax ([struct/c struct/c-name/val] - [struct/dc struct/dc-name/val] - [field-count field-count/val] - [(selectors ...) selectors/val] - [struct:-name struct:-name/val] - [struct-maker struct-maker/val] - [predicate predicate/val] - [contract-name (add-suffix "-contract")] - [(selector-indicies ...) (nums-up-to field-count/val)] - [(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))] - [(ctc-x ...) (generate-temporaries (syntax (fields ...)))] - [(f-x ...) f-x/vals] - [((f-xs ...) ...) f-xs/vals] - [wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))] - [opt-wrap-name (string->symbol (format "~a/lazy-opt-contract" (syntax-e (syntax name))))]) - #` - (begin - - ;; `declare' future bindings for the top-level (so that everyone picks them up) - #,@(if (eq? (syntax-local-context) 'top-level) - (list - (syntax - (define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set - already-there? burrow-in rewrite-fields wrap-get) - (values)))) - (list)) - - (define-syntax name (list #'struct:-name - #'struct-maker - #'predicate - (reverse (list #'selectors ...)) - (list #,@(map (λ (x) #f) (syntax->list #'(selectors ...)))) - #t)) - - (define (evaluate-attrs stct contract/info) - (when (wrap-parent-get stct 0) ;; test to make sure this even has attributes - (let* ([any-unknown? #f] - [any-became-known? #f] - [synth-info (wrap-parent-get stct 0)] - [ht (synth-info-vals synth-info)]) - (hash-table-for-each - ht - (lambda (k v) - (when (unknown? v) - (let ([proc (unknown-proc v)]) - (let ([new (proc (wrap-get stct selector-indicies+1) ...)]) - (cond - [(unknown? new) - (set! any-unknown? #t)] - [else - (set! any-became-known? #t) - (hash-table-put! ht k new)])))))) - (unless any-unknown? - (check-synth-info-test stct synth-info contract/info)) - (when any-became-known? - (for-each - (lambda (x) ((evaluate-attr-prop-accessor x) x contract/info)) - (synth-info-parents synth-info))) - (unless any-unknown? - (set-synth-info-parents! synth-info '()))))) - - (define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set) - (make-struct-type 'wrap-name - wrap-parent-type ;; super struct - 2 ;; field count - (max 0 (- field-count 1)) ;; auto-field-k - #f ;; auto-field-v - (list (cons evaluate-attr-prop evaluate-attrs)) - inspector)) - - (define-values (opt-wrap-type opt-wrap-maker opt-wrap-predicate opt-wrap-get opt-wrap-set) - (make-struct-type 'opt-wrap-name - #f ;; super struct - 2 ;; field count - (+ 1 field-count) ;; auto-field-k - #f ;; auto-field-v - '() ;; prop-value-list - inspector)) - - (define-values (type struct-maker raw-predicate get set) - (make-struct-type 'name - #f ;; super struct - field-count - 0 ;; auto-field-k - '() ;; auto-field-v - '() ;; prop-value-list - inspector)) - - (define (predicate x) (or (raw-predicate x) (opt-wrap-predicate x) (wrap-predicate x))) - - (define-syntax (struct/dc stx) - (syntax-case stx () - [(_ clause (... ...)) - (with-syntax ([((maker-args (... ...)) - (names (... ...))) - (build-clauses 'struct/dc - (syntax coerce-contract) - stx - (syntax (clause (... ...))))]) - (syntax - (let ([names 'names] (... ...)) - (contract-maker maker-args (... ...)))))])) - - (define (do-selection stct i+1) - (let-values ([(stct fields ...) - (let loop ([stct stct]) - (cond - [(raw-predicate stct) - ;; found the original value - (values #f (get stct selector-indicies) ...)] - - [(opt-wrap-predicate stct) - (let ((inner (opt-wrap-get stct 0))) - (if inner - (let* ((info (opt-wrap-get stct 1)) - (enforcer (opt-contract/info-enforcer info))) - (let-values ([(inner-stct fields ...) (loop inner)]) - (let-values ([(fields ...) (enforcer stct fields ...)]) - (opt-wrap-set stct 0 #f) - (opt-wrap-set stct selector-indicies+1 fields) ... - (values stct fields ...)))) - - ;; found a cached version - (values #f (opt-wrap-get stct selector-indicies+1) ...)))] - [(wrap-predicate stct) - (let ([inner (wrap-get stct 0)]) - (if inner - ;; we have a contract to update - (let ([contract/info (wrap-get stct 1)]) - (let-values ([(_1 fields ...) (loop inner)]) - (let-values ([(fields ...) - (rewrite-fields stct contract/info fields ...)]) - (wrap-set stct 0 #f) - (wrap-set stct selector-indicies+1 fields) ... - (evaluate-attrs stct contract/info) - (values stct fields ...)))) - - ;; found a cached version of the value - (values #f (wrap-get stct selector-indicies+1) ...)))]))]) - (cond - [(opt-wrap-predicate stct) (opt-wrap-get stct i+1)] - [(wrap-predicate stct) (wrap-get stct i+1)]))) - - (define (rewrite-fields parent contract/info ctc-x ...) - (let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info) - selector-indicies)] - [ctc (if (procedure? ctc-field) - (ctc-field f-xs ...) - ctc-field)] +(provide define-contract-struct + + make-opt-contract/info + ;set-opt-contract/info-enforcer! + opt-contract/info-contract + opt-contract/info-id + opt-contract/info-enforcer + lazy-depth-to-look + + unknown? + synthesized-value) - [ctc-field-val - ((((proj-get ctc) ctc) (contract/info-pos contract/info) - (contract/info-neg contract/info) - (contract/info-src-info contract/info) - (contract/info-orig-str contract/info)) - ctc-x)]) - (update-parent-links parent ctc-field-val) - ctc-field-val)] ...) - (values f-x ...))) - - (define (stronger-lazy-contract? a b) - (and (contract-predicate b) - (check-sub-contract? - (contract-get a selector-indicies) - (contract-get b selector-indicies)) ...)) - - (define (lazy-contract-proj ctc) - (λ (pos-blame neg-blame src-info orig-str) - (let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str)]) - (λ (val) - (unless (or (wrap-predicate val) - (opt-wrap-predicate val) - (raw-predicate val)) - (raise-contract-error - val - src-info - pos-blame - orig-str - "expected <~a>, got ~e" 'name val)) - (cond - [(already-there? contract/info val lazy-depth-to-look) - val] - [else - (let ([wrapper (wrap-maker val contract/info)]) - (let ([synth-setup-stuff (contract-get ctc field-count)]) - (when synth-setup-stuff - (let ([ht (make-hash-table)]) - (for-each (λ (pr) (hash-table-put! ht (car pr) (make-unknown (cdr pr)))) - (cdr synth-setup-stuff)) - (wrap-parent-set wrapper 0 (make-synth-info '() ht (car synth-setup-stuff)))))) - wrapper)]))))) - - (define (already-there? new-contract/info val depth) - (cond - [(raw-predicate val) #f] - [(zero? depth) #f] - [(wrap-predicate val) - (and (wrap-get val 0) - (let ([old-contract/info (wrap-get val 1)]) - (if (and (eq? (contract/info-pos new-contract/info) - (contract/info-pos old-contract/info)) - (eq? (contract/info-neg new-contract/info) - (contract/info-neg old-contract/info)) - (contract-stronger? (contract/info-contract old-contract/info) - (contract/info-contract new-contract/info))) - #t - (already-there? new-contract/info (wrap-get val 0) (- depth 1)))))] - [else - ;; when the zeroth field is cleared out, we don't - ;; have a contract to compare to anymore. - #f])) - - (define (struct/c ctc-x ...) - (let ([ctc-x (coerce-contract 'struct/c ctc-x)] ...) - (contract-maker ctc-x ... #f))) - - (define (selectors x) - (burrow-in x 'selectors selector-indicies)) ... - - (define (burrow-in struct selector-name i) - (cond - [(raw-predicate struct) - (get struct i)] - [(opt-wrap-predicate struct) - (if (opt-wrap-get struct 0) - (do-selection struct (+ i 1)) - (opt-wrap-get struct (+ i 1)))] - [(wrap-predicate struct) - (if (wrap-get struct 0) - (do-selection struct (+ i 1)) - (wrap-get struct (+ i 1)))] - [else - (error selector-name "expected <~a>, got ~e" 'name struct)])) - - (define (lazy-contract-name ctc) - (do-contract-name 'struct/c - 'struct/dc - (list (contract-get ctc selector-indicies) ...) - '(fields ...) - (contract-get ctc field-count))) - - (define-values (contract-type contract-maker contract-predicate contract-get contract-set) - (make-struct-type 'contract-name - #f - (+ field-count 1) ;; extra field is for synthesized attribute ctcs - ;; it is a list whose first element is - ;; a procedure (called once teh attrs are known) that - ;; indicates if the test passes. the rest of the elements are - ;; procedures that build the attrs - ;; this field is #f when there is no synthesized attrs - 0 ;; auto-field-k - '() ;; auto-field-v - (list (cons proj-prop lazy-contract-proj) - (cons name-prop lazy-contract-name) - (cons first-order-prop (λ (ctc) predicate)) - (cons stronger-prop stronger-lazy-contract?)))) - - (define-for-syntax (build-enforcer opt/i opt/info name stx clauses - helper-id-var helper-info helper-freev - enforcer-id-var) - (define (make-free-vars free-vars freev) - (let loop ([i 0] - [stx null] - [free-vars free-vars]) +(define-syntax (define-contract-struct stx) + (syntax-case stx () + [(_ name (fields ...)) + (syntax (define-contract-struct name (fields ...) (current-inspector)))] + [(_ name (fields ...) inspector) + (and (identifier? (syntax name)) + (andmap identifier? (syntax->list (syntax (fields ...))))) + (let* ([mutable? (syntax-e (syntax mutable?))] + [add-suffix + (λ (suffix) + (datum->syntax (syntax name) + (string->symbol + (string-append (symbol->string (syntax-e (syntax name))) + suffix)) + stx))] + [struct-names (build-struct-names (syntax name) + (syntax->list (syntax (fields ...))) + #f + #t + stx)] + [struct:-name/val (list-ref struct-names 0)] + [struct-maker/val (list-ref struct-names 1)] + [predicate/val (list-ref struct-names 2)] + [selectors/val (cdddr struct-names)] + [struct/c-name/val (add-suffix "/c")] + [struct/dc-name/val (add-suffix "/dc")] + [field-count/val (length selectors/val)] + [f-x/vals (generate-temporaries (syntax (fields ...)))] + [f-xs/vals (generate-arglists f-x/vals)]) + + (with-syntax ([struct/c struct/c-name/val] + [struct/dc struct/dc-name/val] + [field-count field-count/val] + [(selectors ...) selectors/val] + [struct:-name struct:-name/val] + [struct-maker struct-maker/val] + [predicate predicate/val] + [contract-name (add-suffix "-contract")] + [(selector-indicies ...) (nums-up-to field-count/val)] + [(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))] + [(ctc-x ...) (generate-temporaries (syntax (fields ...)))] + [(f-x ...) f-x/vals] + [((f-xs ...) ...) f-xs/vals] + [wrap-name (string->symbol (format "~a/lazy-contract" (syntax-e (syntax name))))] + [opt-wrap-name (string->symbol (format "~a/lazy-opt-contract" (syntax-e (syntax name))))]) + #` + (begin + + ;; `declare' future bindings for the top-level (so that everyone picks them up) + #,@(if (eq? (syntax-local-context) 'top-level) + (list + (syntax + (define-syntaxes (contract-type contract-maker contract-predicate contract-get contract-set + already-there? burrow-in rewrite-fields wrap-get) + (values)))) + (list)) + + (define-syntax name (list #'struct:-name + #'struct-maker + #'predicate + (reverse (list #'selectors ...)) + (list #,@(map (λ (x) #f) (syntax->list #'(selectors ...)))) + #t)) + + (define (evaluate-attrs stct contract/info) + (when (wrap-parent-get stct 0) ;; test to make sure this even has attributes + (let* ([any-unknown? #f] + [any-became-known? #f] + [synth-info (wrap-parent-get stct 0)] + [ht (synth-info-vals synth-info)]) + (hash-table-for-each + ht + (lambda (k v) + (when (unknown? v) + (let ([proc (unknown-proc v)]) + (let ([new (proc (wrap-get stct selector-indicies+1) ...)]) + (cond + [(unknown? new) + (set! any-unknown? #t)] + [else + (set! any-became-known? #t) + (hash-table-put! ht k new)])))))) + (unless any-unknown? + (check-synth-info-test stct synth-info contract/info)) + (when any-became-known? + (for-each + (lambda (x) ((evaluate-attr-prop-accessor x) x contract/info)) + (synth-info-parents synth-info))) + (unless any-unknown? + (set-synth-info-parents! synth-info '()))))) + + (define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set) + (make-struct-type 'wrap-name + wrap-parent-type ;; super struct + 2 ;; field count + (max 0 (- field-count 1)) ;; auto-field-k + #f ;; auto-field-v + (list (cons evaluate-attr-prop evaluate-attrs)) + inspector)) + + (define-values (opt-wrap-type opt-wrap-maker opt-wrap-predicate opt-wrap-get opt-wrap-set) + (make-struct-type 'opt-wrap-name + #f ;; super struct + 2 ;; field count + (+ 1 field-count) ;; auto-field-k + #f ;; auto-field-v + '() ;; prop-value-list + inspector)) + + (define-values (type struct-maker raw-predicate get set) + (make-struct-type 'name + #f ;; super struct + field-count + 0 ;; auto-field-k + '() ;; auto-field-v + '() ;; prop-value-list + inspector)) + + (define (predicate x) (or (raw-predicate x) (opt-wrap-predicate x) (wrap-predicate x))) + + (define-syntax (struct/dc stx) + (syntax-case stx () + [(_ clause (... ...)) + (with-syntax ([((maker-args (... ...)) + (names (... ...))) + (build-clauses 'struct/dc + (syntax coerce-contract) + stx + (syntax (clause (... ...))))]) + (syntax + (let ([names 'names] (... ...)) + (contract-maker maker-args (... ...)))))])) + + (define (do-selection stct i+1) + (let-values ([(stct fields ...) + (let loop ([stct stct]) + (cond + [(raw-predicate stct) + ;; found the original value + (values #f (get stct selector-indicies) ...)] + + [(opt-wrap-predicate stct) + (let ((inner (opt-wrap-get stct 0))) + (if inner + (let* ((info (opt-wrap-get stct 1)) + (enforcer (opt-contract/info-enforcer info))) + (let-values ([(inner-stct fields ...) (loop inner)]) + (let-values ([(fields ...) (enforcer stct fields ...)]) + (opt-wrap-set stct 0 #f) + (opt-wrap-set stct selector-indicies+1 fields) ... + (values stct fields ...)))) + + ;; found a cached version + (values #f (opt-wrap-get stct selector-indicies+1) ...)))] + [(wrap-predicate stct) + (let ([inner (wrap-get stct 0)]) + (if inner + ;; we have a contract to update + (let ([contract/info (wrap-get stct 1)]) + (let-values ([(_1 fields ...) (loop inner)]) + (let-values ([(fields ...) + (rewrite-fields stct contract/info fields ...)]) + (wrap-set stct 0 #f) + (wrap-set stct selector-indicies+1 fields) ... + (evaluate-attrs stct contract/info) + (values stct fields ...)))) + + ;; found a cached version of the value + (values #f (wrap-get stct selector-indicies+1) ...)))]))]) + (cond + [(opt-wrap-predicate stct) (opt-wrap-get stct i+1)] + [(wrap-predicate stct) (wrap-get stct i+1)]))) + + (define (rewrite-fields parent contract/info ctc-x ...) + (let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info) + selector-indicies)] + [ctc (if (procedure? ctc-field) + (ctc-field f-xs ...) + ctc-field)] + + [ctc-field-val + ((((proj-get ctc) ctc) (contract/info-pos contract/info) + (contract/info-neg contract/info) + (contract/info-src-info contract/info) + (contract/info-orig-str contract/info)) + ctc-x)]) + (update-parent-links parent ctc-field-val) + ctc-field-val)] ...) + (values f-x ...))) + + (define (stronger-lazy-contract? a b) + (and (contract-predicate b) + (check-sub-contract? + (contract-get a selector-indicies) + (contract-get b selector-indicies)) ...)) + + (define (lazy-contract-proj ctc) + (λ (pos-blame neg-blame src-info orig-str) + (let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str)]) + (λ (val) + (unless (or (wrap-predicate val) + (opt-wrap-predicate val) + (raw-predicate val)) + (raise-contract-error + val + src-info + pos-blame + orig-str + "expected <~a>, got ~e" 'name val)) (cond - [(null? free-vars) (reverse stx)] - [else (loop (+ i 1) - (cons (with-syntax ((var (car free-vars)) - (freev freev) - (j (+ i 2))) - (syntax (var (opt-wrap-get stct j)))) stx) - (cdr free-vars))]))) - - (let*-values ([(inner-val) #'val] - [(clauses lifts superlifts stronger-ribs) - (build-enforcer-clauses opt/i - (opt/info-change-val inner-val opt/info) - name - stx - clauses - (list (syntax f-x) ...) - (list (list (syntax f-xs) ...) ...) - helper-id-var - helper-info - helper-freev)]) - (with-syntax ([(clause (... ...)) clauses] - [enforcer-id enforcer-id-var] - [helper-id helper-id-var] - [((free-var free-var-val) (... ...)) - (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)] - [(saved-lifts (... ...)) (lifts-to-save lifts)]) - (values - #`(λ (stct f-x ...) - (let ((free-var free-var-val) (... ...)) - #,(bind-lifts - lifts - #'(let* (clause (... ...)) - (values f-x ...))))) - lifts - superlifts - stronger-ribs)))) - - ;; - ;; struct/dc opter - ;; - (define/opter (struct/dc opt/i opt/info stx) - (syntax-case stx () - [(_ clause (... ...)) - (let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer))))) - (helper-id-var (car (generate-temporaries (syntax (helper))))) - (contract/info-var (car (generate-temporaries (syntax (contract/info))))) - (id-var (car (generate-temporaries (syntax (id)))))) - (let-values ([(enforcer lifts superlifts stronger-ribs) - (build-enforcer opt/i - opt/info - 'struct/dc - stx - (syntax (clause (... ...))) - helper-id-var - #'info - #'freev - enforcer-id-var)]) - (let ([to-save (append (opt/info-free-vars opt/info) - (lifts-to-save lifts))]) - (with-syntax ((val (opt/info-val opt/info)) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (ctc (opt/info-contract opt/info)) - (enforcer-id enforcer-id-var) - (helper-id helper-id-var) - (contract/info contract/info-var) - (id id-var) - ((j (... ...)) (let loop ([i 2] - [lst to-save]) - (cond - [(null? lst) null] - [else (cons i (loop (+ i 1) (cdr lst)))]))) - ((free-var (... ...)) to-save)) - (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)] - [(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)] - [(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)] - [(stronger-indexes (... ...)) (build-list (length stronger-ribs) - (λ (x) (+ x 2)))] - [(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)]) - - (let ([partials - (list (cons id-var #'(begin-lifted (box 'identity))) - (cons enforcer-id-var enforcer) - (cons contract/info-var - (syntax - (make-opt-contract/info ctc enforcer-id id))))]) - (values - (syntax - (cond - [(opt-wrap-predicate val) - (if (and (opt-wrap-get val 0) - (let ([stronger-this-var stronger-var] - (... ...) - - ;; this computation is bogus - ;; it only works if the stronger vars and the things - ;; saved in the wrapper are the same - [stronger-that-var (opt-wrap-get val stronger-indexes)] - (... ...)) - (and - ;; make sure this is the same contract -- if not, - ;; the rest of this test is bogus and may fail at runtime - (eq? id (opt-contract/info-id (opt-wrap-get val 1))) - stronger-exps (... ...)))) - val - (let ([w (opt-wrap-maker val contract/info)]) - (opt-wrap-set w j free-var) (... ...) - w))] - [(or (raw-predicate val) - (wrap-predicate val)) - (let ([w (opt-wrap-maker val contract/info)]) - (opt-wrap-set w j free-var) (... ...) - w)] - [else - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, got ~e" - ((name-get ctc) ctc) - val)])) - lifts - superlifts - partials - #f - #f - stronger-ribs)))))))])) - )))])) - - (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) - (cond - [(and (andmap contract? list-of-subcontracts) (not attrs)) - (apply build-compound-type-name name/c list-of-subcontracts)] - [else - (let ([fields - (map (λ (field ctc) - (if (contract? ctc) - (build-compound-type-name field ctc) - (build-compound-type-name field '...))) - fields - list-of-subcontracts)]) - (cond - [attrs - (apply build-compound-type-name - name/dc - (append fields - (list 'where) - (map (λ (x) `(,(car x) ...)) - (reverse (cdr attrs))) - (list 'and '...)))] - [else (apply build-compound-type-name name/dc fields)]))])) - - (define-struct contract/info (contract pos neg src-info orig-str)) - (define-struct opt-contract/info (contract enforcer id)) + [(already-there? contract/info val lazy-depth-to-look) + val] + [else + (let ([wrapper (wrap-maker val contract/info)]) + (let ([synth-setup-stuff (contract-get ctc field-count)]) + (when synth-setup-stuff + (let ([ht (make-hash-table)]) + (for-each (λ (pr) (hash-table-put! ht (car pr) (make-unknown (cdr pr)))) + (cdr synth-setup-stuff)) + (wrap-parent-set wrapper 0 (make-synth-info '() ht (car synth-setup-stuff)))))) + wrapper)]))))) + + (define (already-there? new-contract/info val depth) + (cond + [(raw-predicate val) #f] + [(zero? depth) #f] + [(wrap-predicate val) + (and (wrap-get val 0) + (let ([old-contract/info (wrap-get val 1)]) + (if (and (eq? (contract/info-pos new-contract/info) + (contract/info-pos old-contract/info)) + (eq? (contract/info-neg new-contract/info) + (contract/info-neg old-contract/info)) + (contract-stronger? (contract/info-contract old-contract/info) + (contract/info-contract new-contract/info))) + #t + (already-there? new-contract/info (wrap-get val 0) (- depth 1)))))] + [else + ;; when the zeroth field is cleared out, we don't + ;; have a contract to compare to anymore. + #f])) + + (define (struct/c ctc-x ...) + (let ([ctc-x (coerce-contract 'struct/c ctc-x)] ...) + (contract-maker ctc-x ... #f))) + + (define (selectors x) + (burrow-in x 'selectors selector-indicies)) ... + + (define (burrow-in struct selector-name i) + (cond + [(raw-predicate struct) + (get struct i)] + [(opt-wrap-predicate struct) + (if (opt-wrap-get struct 0) + (do-selection struct (+ i 1)) + (opt-wrap-get struct (+ i 1)))] + [(wrap-predicate struct) + (if (wrap-get struct 0) + (do-selection struct (+ i 1)) + (wrap-get struct (+ i 1)))] + [else + (error selector-name "expected <~a>, got ~e" 'name struct)])) + + (define (lazy-contract-name ctc) + (do-contract-name 'struct/c + 'struct/dc + (list (contract-get ctc selector-indicies) ...) + '(fields ...) + (contract-get ctc field-count))) + + (define-values (contract-type contract-maker contract-predicate contract-get contract-set) + (make-struct-type 'contract-name + #f + (+ field-count 1) ;; extra field is for synthesized attribute ctcs + ;; it is a list whose first element is + ;; a procedure (called once teh attrs are known) that + ;; indicates if the test passes. the rest of the elements are + ;; procedures that build the attrs + ;; this field is #f when there is no synthesized attrs + 0 ;; auto-field-k + '() ;; auto-field-v + (list (cons proj-prop lazy-contract-proj) + (cons name-prop lazy-contract-name) + (cons first-order-prop (λ (ctc) predicate)) + (cons stronger-prop stronger-lazy-contract?)))) + + (define-for-syntax (build-enforcer opt/i opt/info name stx clauses + helper-id-var helper-info helper-freev + enforcer-id-var) + (define (make-free-vars free-vars freev) + (let loop ([i 0] + [stx null] + [free-vars free-vars]) + (cond + [(null? free-vars) (reverse stx)] + [else (loop (+ i 1) + (cons (with-syntax ((var (car free-vars)) + (freev freev) + (j (+ i 2))) + (syntax (var (opt-wrap-get stct j)))) stx) + (cdr free-vars))]))) + + (let*-values ([(inner-val) #'val] + [(clauses lifts superlifts stronger-ribs) + (build-enforcer-clauses opt/i + (opt/info-change-val inner-val opt/info) + name + stx + clauses + (list (syntax f-x) ...) + (list (list (syntax f-xs) ...) ...) + helper-id-var + helper-info + helper-freev)]) + (with-syntax ([(clause (... ...)) clauses] + [enforcer-id enforcer-id-var] + [helper-id helper-id-var] + [((free-var free-var-val) (... ...)) + (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)] + [(saved-lifts (... ...)) (lifts-to-save lifts)]) + (values + #`(λ (stct f-x ...) + (let ((free-var free-var-val) (... ...)) + #,(bind-lifts + lifts + #'(let* (clause (... ...)) + (values f-x ...))))) + lifts + superlifts + stronger-ribs)))) + + ;; + ;; struct/dc opter + ;; + (define/opter (struct/dc opt/i opt/info stx) + (syntax-case stx () + [(_ clause (... ...)) + (let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer))))) + (helper-id-var (car (generate-temporaries (syntax (helper))))) + (contract/info-var (car (generate-temporaries (syntax (contract/info))))) + (id-var (car (generate-temporaries (syntax (id)))))) + (let-values ([(enforcer lifts superlifts stronger-ribs) + (build-enforcer opt/i + opt/info + 'struct/dc + stx + (syntax (clause (... ...))) + helper-id-var + #'info + #'freev + enforcer-id-var)]) + (let ([to-save (append (opt/info-free-vars opt/info) + (lifts-to-save lifts))]) + (with-syntax ((val (opt/info-val opt/info)) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + (ctc (opt/info-contract opt/info)) + (enforcer-id enforcer-id-var) + (helper-id helper-id-var) + (contract/info contract/info-var) + (id id-var) + ((j (... ...)) (let loop ([i 2] + [lst to-save]) + (cond + [(null? lst) null] + [else (cons i (loop (+ i 1) (cdr lst)))]))) + ((free-var (... ...)) to-save)) + (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)] + [(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)] + [(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)] + [(stronger-indexes (... ...)) (build-list (length stronger-ribs) + (λ (x) (+ x 2)))] + [(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)]) + + (let ([partials + (list (cons id-var #'(begin-lifted (box 'identity))) + (cons enforcer-id-var enforcer) + (cons contract/info-var + (syntax + (make-opt-contract/info ctc enforcer-id id))))]) + (values + (syntax + (cond + [(opt-wrap-predicate val) + (if (and (opt-wrap-get val 0) + (let ([stronger-this-var stronger-var] + (... ...) + + ;; this computation is bogus + ;; it only works if the stronger vars and the things + ;; saved in the wrapper are the same + [stronger-that-var (opt-wrap-get val stronger-indexes)] + (... ...)) + (and + ;; make sure this is the same contract -- if not, + ;; the rest of this test is bogus and may fail at runtime + (eq? id (opt-contract/info-id (opt-wrap-get val 1))) + stronger-exps (... ...)))) + val + (let ([w (opt-wrap-maker val contract/info)]) + (opt-wrap-set w j free-var) (... ...) + w))] + [(or (raw-predicate val) + (wrap-predicate val)) + (let ([w (opt-wrap-maker val contract/info)]) + (opt-wrap-set w j free-var) (... ...) + w)] + [else + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, got ~e" + ((name-get ctc) ctc) + val)])) + lifts + superlifts + partials + #f + #f + stronger-ribs)))))))])) + )))])) - ;; parents : (listof wrap-parent) - ;; vals : hash-table[symbol -o> (union (make-unknown proc[field-vals -> any]) any) - ;; test : proc[vals-hash-table -> boolean] - (define-struct synth-info (parents vals test)) - - (define-struct unknown (proc)) - - (define secret (gensym)) - (define (synthesized-value wrap key) - (unless (wrap-parent-predicate wrap) - (error 'synthesized-value "expected struct value with contract as first argument, got ~e" wrap)) - (let ([ans (hash-table-get (synth-info-vals (wrap-parent-get wrap 0)) - key - secret)]) - (when (eq? ans secret) - (error 'synthesized-value "the key ~e is not mapped in ~e" key wrap)) - ans)) - - (define (check-synth-info-test stct synth-info contract/info) - (unless ((synth-info-test synth-info) (synth-info-vals synth-info)) - (raise-contract-error - stct - (contract/info-src-info contract/info) - (contract/info-pos contract/info) - (contract/info-orig-str contract/info) - "failed `and' clause, got ~e" stct))) +(define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) + (cond + [(and (andmap contract? list-of-subcontracts) (not attrs)) + (apply build-compound-type-name name/c list-of-subcontracts)] + [else + (let ([fields + (map (λ (field ctc) + (if (contract? ctc) + (build-compound-type-name field ctc) + (build-compound-type-name field '...))) + fields + list-of-subcontracts)]) + (cond + [attrs + (apply build-compound-type-name + name/dc + (append fields + (list 'where) + (map (λ (x) `(,(car x) ...)) + (reverse (cdr attrs))) + (list 'and '...)))] + [else (apply build-compound-type-name name/dc fields)]))])) - (define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor) - (make-struct-type-property 'evaluate-attr-prop)) - - (define-values (wrap-parent-type wrap-parent-maker wrap-parent-predicate wrap-parent-get wrap-parent-set) - (make-struct-type 'wrap-parent - #f ;; parent - 0 ;; fields - 1 ;; auto fields - )) - - (define (update-parent-links parent ctc-field-val) - (when (wrap-parent-predicate ctc-field-val) - (let ([old (wrap-parent-get ctc-field-val 0)]) - (when old - ;; add in new parent - (wrap-parent-set ctc-field-val 0 - (make-synth-info - (cons parent (synth-info-parents old)) - (synth-info-vals old) - (synth-info-test old))))))) - - (define max-cache-size 5) - (define lazy-depth-to-look 5) - - (define (check-sub-contract? x y) - (cond - [(and (stronger-pred? x) (stronger-pred? y)) - (contract-stronger? x y)] - [(and (procedure? x) (procedure? y)) - (procedure-closure-contents-eq? x y)] - [else #f])) - - #| +(define-struct contract/info (contract pos neg src-info orig-str)) +(define-struct opt-contract/info (contract enforcer id)) + +;; parents : (listof wrap-parent) +;; vals : hash-table[symbol -o> (union (make-unknown proc[field-vals -> any]) any) +;; test : proc[vals-hash-table -> boolean] +(define-struct synth-info (parents vals test) #:mutable) + +(define-struct unknown (proc)) + +(define secret (gensym)) +(define (synthesized-value wrap key) + (unless (wrap-parent-predicate wrap) + (error 'synthesized-value "expected struct value with contract as first argument, got ~e" wrap)) + (let ([ans (hash-table-get (synth-info-vals (wrap-parent-get wrap 0)) + key + secret)]) + (when (eq? ans secret) + (error 'synthesized-value "the key ~e is not mapped in ~e" key wrap)) + ans)) + +(define (check-synth-info-test stct synth-info contract/info) + (unless ((synth-info-test synth-info) (synth-info-vals synth-info)) + (raise-contract-error + stct + (contract/info-src-info contract/info) + (contract/info-pos contract/info) + (contract/info-orig-str contract/info) + "failed `and' clause, got ~e" stct))) + +(define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor) + (make-struct-type-property 'evaluate-attr-prop)) + +(define-values (wrap-parent-type wrap-parent-maker wrap-parent-predicate wrap-parent-get wrap-parent-set) + (make-struct-type 'wrap-parent + #f ;; parent + 0 ;; fields + 1 ;; auto fields + )) + +(define (update-parent-links parent ctc-field-val) + (when (wrap-parent-predicate ctc-field-val) + (let ([old (wrap-parent-get ctc-field-val 0)]) + (when old + ;; add in new parent + (wrap-parent-set ctc-field-val 0 + (make-synth-info + (cons parent (synth-info-parents old)) + (synth-info-vals old) + (synth-info-test old))))))) + +(define max-cache-size 5) +(define lazy-depth-to-look 5) + +(define (check-sub-contract? x y) + (cond + [(and (stronger-pred? x) (stronger-pred? y)) + (contract-stronger? x y)] + [(and (procedure? x) (procedure? y)) + (procedure-closure-contents-eq? x y)] + [else #f])) + +#| test case: (define-contract-struct s (a b)) @@ -571,14 +572,12 @@ but this one: should |# - - #| + +#| test-case: (define-contract-struct s (a b)) (s/dc [x 1]) => wrong field count exn |# - - - ) + diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index 62dc738c43..939cb05cc6 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -1,463 +1,465 @@ -(module contract-guts mzscheme - (require "contract-helpers.ss" - (lib "pretty.ss")) +#lang scheme/base - (require-for-syntax "contract-helpers.ss") - - (provide raise-contract-error - guilty-party - contract-violation->string - coerce-contract - - flat-contract/predicate? - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract +(require "contract-helpers.ss" + scheme/pretty) - build-compound-type-name - - and/c - any/c - none/c - make-none/c - - contract? - contract-name - contract-proc - make-proj-contract - build-flat-contract - - define-struct/prop - - contract-stronger? +(require (for-syntax scheme/base + "contract-helpers.ss")) - contract-first-order-passes? - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - flat-proj - first-order-prop - first-order-get - - ;; for opters - check-flat-contract - check-flat-named-contract - any) - - (define-syntax (any stx) - (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx)) +(provide raise-contract-error + guilty-party + contract-violation->string + coerce-contract + + flat-contract/predicate? + flat-contract? + flat-contract + flat-contract-predicate + flat-named-contract + + build-compound-type-name + + and/c + any/c + none/c + make-none/c + + contract? + contract-name + contract-proc + make-proj-contract + build-flat-contract + + define-struct/prop + + contract-stronger? + + contract-first-order-passes? + + proj-prop proj-pred? proj-get + name-prop name-pred? name-get + stronger-prop stronger-pred? stronger-get + flat-prop flat-pred? flat-get + flat-proj + first-order-prop + first-order-get + + ;; for opters + check-flat-contract + check-flat-named-contract + any) - ;; define-struct/prop is a define-struct-like macro that - ;; also allows properties to be defined - ;; it contains copied code (build-struct-names) in order to avoid - ;; a module cycle - (define-syntax (define-struct/prop stx) - (let () - - (syntax-case stx () - [(_ name (field ...) ((property value) ...)) - (andmap identifier? (syntax->list (syntax (field ...)))) - (let ([struct-names (build-struct-names (syntax name) - (syntax->list (syntax (field ...))) - #f - #t - stx)] - [struct-names/bangers (build-struct-names (syntax name) - (syntax->list (syntax (field ...))) - #t - #f - stx)] - [field-count/val (length (syntax->list (syntax (field ...))))]) - (with-syntax ([struct:-name (list-ref struct-names 0)] - [struct-maker (list-ref struct-names 1)] - [predicate (list-ref struct-names 2)] - [(count ...) (nums-up-to field-count/val)] - [(selectors ...) (cdddr struct-names)] - [(bangers ...) (cdddr struct-names/bangers)] - [field-count field-count/val] - [(field-indicies ...) (nums-up-to (length (syntax->list (syntax (field ...)))))]) - (syntax - (begin - (define-values (struct:-name struct-maker predicate get set) - (make-struct-type 'name - #f ;; super - field-count - 0 ;; auto-field-k - '() - (list (cons property value) ...))) - (define selectors (make-struct-field-accessor get count 'field)) - ... - (define bangers (make-struct-field-mutator set count 'field)) - ...))))]))) - - (define-values (proj-prop proj-pred? raw-proj-get) - (make-struct-type-property 'contract-projection)) - (define-values (name-prop name-pred? name-get) - (make-struct-type-property 'contract-name)) - (define-values (stronger-prop stronger-pred? stronger-get) - (make-struct-type-property 'contract-stronger-than)) - (define-values (flat-prop flat-pred? flat-get) - (make-struct-type-property 'contract-flat)) +(define-syntax (any stx) + (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx)) - (define-values (first-order-prop first-order-pred? first-order-get) - (make-struct-type-property 'contract-first-order)) - - (define (contract-first-order-passes? c v) - (cond - [(first-order-pred? c) (((first-order-get c) c) v)] - [(and (procedure? c) - (procedure-arity-includes? c 1)) - ;; flat contract as a predicate - (c v)] - [(flat-pred? c) (((flat-get c) c) v)] - [else (error 'contract-first-order-passes? - "expected a contract as first argument, got ~e, other arg ~e" c v)])) - - (define (proj-get ctc) - (cond - [(proj-pred? ctc) - (raw-proj-get ctc)] - [else (error 'proj-get "unknown ~e" ctc)])) - - ;; contract-stronger? : contract contract -> boolean - ;; indicates if one contract is stronger (ie, likes fewer values) than another - ;; this is not a total order. - (define (contract-stronger? a b) - (let ([a-ctc (coerce-contract 'contract-stronger? a)] - [b-ctc (coerce-contract 'contract-stronger? b)]) - ((stronger-get a-ctc) a-ctc b-ctc))) - - - ;; coerce-contract : id (union contract? procedure-arity-1) -> contract - ;; contract-proc = sym sym stx -> alpha -> alpha - ;; returns the procedure for the contract after extracting it from the - ;; struct. Coerces the argument to a flat contract if it is procedure, but first. - (define (coerce-contract name x) - (cond - [(contract? x) x] - [(and (procedure? x) (procedure-arity-includes? x 1)) - (flat-contract x)] - [else - (error name - "expected contract or procedure of arity 1, got ~e" - x)])) - - (define-values (make-exn:fail:contract2 - exn:fail:contract2? - exn:fail:contract2-srclocs - guilty-party) - (let-values ([(exn:fail:contract2 - make-exn:fail:contract2 - exn:fail:contract2? - get - set) - (parameterize ([current-inspector (make-inspector)]) - (make-struct-type 'exn:fail:contract2 - struct:exn:fail:contract - 2 - 0 - #f - (list (cons prop:exn:srclocs - (lambda (x) - (exn:fail:contract2-srclocs x))))))]) - (values - make-exn:fail:contract2 - exn:fail:contract2? - (lambda (x) (get x 0)) - (lambda (x) (get x 1))))) - - (define (default-contract-violation->string val src-info to-blame contract-sexp msg) - (let ([blame-src (src-info-as-string src-info)] - [formatted-contract-sexp - (let ([one-line (format "~s" contract-sexp)]) - (if (< (string-length one-line) 30) - (string-append one-line " ") - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (get-output-string sp))))] - [specific-blame - (let ([datum (syntax-object->datum src-info)]) - (if (symbol? datum) - (format "on ~a" datum) - ""))]) - (string-append (format "~a~a broke the contract ~a~a; " - blame-src - to-blame - formatted-contract-sexp - specific-blame) - msg))) - - (define contract-violation->string (make-parameter default-contract-violation->string)) - - (define (raise-contract-error val src-info blame contract-sexp fmt . args) - (raise - (make-exn:fail:contract2 - (string->immutable-string - ((contract-violation->string) val - src-info - blame - contract-sexp - (apply format fmt args))) - (current-continuation-marks) - (if src-info - (list (make-srcloc - (syntax-source src-info) - (syntax-line src-info) - (syntax-column src-info) - (syntax-position src-info) - (syntax-span src-info))) - '()) - blame))) - - (define print-contract-liner - (let ([default (pretty-print-print-line)]) - (λ (line port ol cols) - (+ (default line port ol cols) - (if line - (begin (display " " port) - 2) - 0))))) - - ;; src-info-as-string : (union syntax #f) -> string - (define (src-info-as-string src-info) - (if (syntax? src-info) - (let ([src-loc-str (build-src-loc-string src-info)]) - (if src-loc-str - (string-append src-loc-str ": ") - "")) - "")) - - ; - ; - ; - ; - ; - ; ; ; - ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; - ; ; ; ; ; ;; ; ; ;; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ;;;; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; - ; ; ; ; ; ; ; ; ; ; ; ; ; ; - ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; - ; - ; - ; - - ;; contract = (make-contract sexp - ;; (sym - ;; sym - ;; (union syntax #f) - ;; string - ;; -> - ;; (alpha -> alpha))) - ;; the first arg to make-contract builds the name of the contract. The - ;; path records how the violation occurs - ;; - ;; generic contract container; - ;; the first arg to proc is a symbol representing the name of the positive blame - ;; the second arg to proc is the symbol representing the name of the negative blame - ;; the third argument to proc is the src-info. - ;; the fourth argumet is a textual representation of the original contract - ;; - ;; the argument to the result function is the value to test. - ;; (the result function is the projection) - ;; - - (define (flat-proj ctc) - (let ([pred? ((flat-get ctc) ctc)]) - (λ (pos neg src-info orig-str) - (λ (val) - (if (pred? val) - val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val)))))) - - (define (double-any-curried-proj ctc) double-any-curred-proj2) - (define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values) - - - (define-values (make-flat-contract - make-proj-contract) - (let () - (define-struct/prop proj-contract (the-name proj first-order-proc) - ((proj-prop (λ (ctc) (proj-contract-proj ctc))) - (name-prop (λ (ctc) (proj-contract-the-name ctc))) - (first-order-prop (λ (ctc) (or (proj-contract-first-order-proc ctc) - (λ (x) #t)))) - (stronger-prop (λ (this that) - (and (proj-contract? that) - (procedure-closure-contents-eq? - (proj-contract-proj this) - (proj-contract-proj that))))))) - - (define-struct/prop flat-contract (the-name predicate) - ((proj-prop flat-proj) - (stronger-prop (λ (this that) - (and (flat-contract? that) - (procedure-closure-contents-eq? (flat-contract-predicate this) - (flat-contract-predicate that))))) - (name-prop (λ (ctc) (flat-contract-the-name ctc))) - (flat-prop (λ (ctc) (flat-contract-predicate ctc))))) - (values make-flat-contract - make-proj-contract))) - - (define (flat-contract-predicate x) - (unless (flat-contract? x) - (error 'flat-contract-predicate "expected a flat contract, got ~e" x)) - ((flat-get x) x)) - (define (flat-contract? x) (flat-pred? x)) - (define (contract-name ctc) - (if (and (procedure? ctc) - (procedure-arity-includes? ctc 1)) - (or (object-name ctc) - 'unknown) - ((name-get ctc) ctc))) - (define (contract? x) (proj-pred? x)) - (define (contract-proc ctc) ((proj-get ctc) ctc)) - - (define (check-flat-contract predicate) - (unless (and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (error 'flat-contract - "expected procedure of arity 1 as argument, given ~e" - predicate))) - (define (flat-contract predicate) - (check-flat-contract predicate) - (let ([pname (object-name predicate)]) - (if pname - (flat-named-contract pname predicate) - (flat-named-contract '??? predicate)))) - (define (check-flat-named-contract predicate) - (unless (and (procedure? predicate) - (procedure-arity-includes? predicate 1)) - (error 'flat-named-contract - "expected procedure of arity 1 as second argument, given ~e" - predicate))) - (define (flat-named-contract name predicate) - (check-flat-named-contract predicate) - (build-flat-contract name predicate)) - - (define (build-flat-contract name predicate) (make-flat-contract name predicate)) - - ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) - (define (build-compound-type-name . fs) - (let loop ([subs fs]) - (cond - [(null? subs) - '()] - [else (let ([sub (car subs)]) - (cond - [(contract? sub) - (let ([mk-sub-name (contract-name sub)]) - `(,mk-sub-name ,@(loop (cdr subs))))] - [else `(,sub ,@(loop (cdr subs)))]))]))) - - (define (and-proj ctc) - (let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))]) - (lambda (pos neg src-info orig-str) - (let ([projs (map (λ (c) (c pos neg src-info orig-str)) mk-pos-projs)]) - (let loop ([projs (cdr projs)] - [proj (car projs)]) - (cond - [(null? projs) proj] - [else (loop (cdr projs) - (let ([f (car projs)]) - (λ (v) (proj (f v)))))])))))) - - - (define-struct/prop and/c (ctcs) - ((proj-prop and-proj) - (name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))) - (first-order-prop (λ (ctc) - (let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))]) - (λ (x) - (andmap (λ (f) (f x)) tests))))) - (stronger-prop - (λ (this that) - (and (and/c? that) - (let ([this-ctcs (and/c-ctcs this)] - [that-ctcs (and/c-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))))))) +;; define-struct/prop is a define-struct-like macro that +;; also allows properties to be defined +;; it contains copied code (build-struct-names) in order to avoid +;; a module cycle +(define-syntax (define-struct/prop stx) + (let () - (define (and/c . fs) - (for-each - (lambda (x) - (unless (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1))) - (error 'and/c "expected procedures of arity 1 or s, given: ~e" x))) - fs) - (cond - [(null? fs) any/c] - [(andmap flat-contract/predicate? fs) - (let* ([to-predicate - (lambda (x) - (if (flat-contract? x) - (flat-contract-predicate x) - x))] - [contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)] - [pred - (let loop ([pred (to-predicate (car fs))] - [preds (cdr fs)]) - (cond - [(null? preds) pred] - [else - (let* ([fst (to-predicate (car preds))]) - (loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))]) - and/c-contract?) - (cdr preds)))]))]) - (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))] - [else - (let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]) - (make-and/c contracts))])) - - (define-struct/prop any/c () - ((proj-prop double-any-curried-proj) - (stronger-prop (λ (this that) (any/c? that))) - (name-prop (λ (ctc) 'any/c)) - (first-order-prop (λ (ctc) (λ (val) #t))) - (flat-prop (λ (ctc) (λ (x) #t))))) - - (define any/c (make-any/c)) - - (define (none-curried-proj ctc) - (λ (pos-blame neg-blame src-info orig-str) - (λ (val) - (raise-contract-error - val - src-info - pos-blame - orig-str - "~s accepts no values, given: ~e" - (none/c-name ctc) - val)))) + (syntax-case stx () + [(_ name (field ...) ((property value) ...)) + (andmap identifier? (syntax->list (syntax (field ...)))) + (let ([struct-names (build-struct-names (syntax name) + (syntax->list (syntax (field ...))) + #f + #t + stx)] + [struct-names/bangers (build-struct-names (syntax name) + (syntax->list (syntax (field ...))) + #t + #f + stx)] + [field-count/val (length (syntax->list (syntax (field ...))))]) + (with-syntax ([struct:-name (list-ref struct-names 0)] + [struct-maker (list-ref struct-names 1)] + [predicate (list-ref struct-names 2)] + [(count ...) (nums-up-to field-count/val)] + [(selectors ...) (cdddr struct-names)] + [(bangers ...) (cdddr struct-names/bangers)] + [field-count field-count/val] + [(field-indicies ...) (nums-up-to (length (syntax->list (syntax (field ...)))))]) + (syntax + (begin + (define-values (struct:-name struct-maker predicate get set) + (make-struct-type 'name + #f ;; super + field-count + 0 ;; auto-field-k + '() + (list (cons property value) ...))) + (define selectors (make-struct-field-accessor get count 'field)) + ... + (define bangers (make-struct-field-mutator set count 'field)) + ...))))]))) - (define-struct/prop none/c (name) - ((proj-prop none-curried-proj) - (stronger-prop (λ (this that) #t)) - (name-prop (λ (ctc) (none/c-name ctc))) - (first-order-prop (λ (ctc) (λ (val) #f))) - (flat-prop (λ (ctc) (λ (x) #f))))) - - (define none/c (make-none/c 'none/c)) - - (define (flat-contract/predicate? pred) - (or (flat-contract? pred) - (and (procedure? pred) - (procedure-arity-includes? pred 1))))) \ No newline at end of file +(define-values (proj-prop proj-pred? raw-proj-get) + (make-struct-type-property 'contract-projection)) +(define-values (name-prop name-pred? name-get) + (make-struct-type-property 'contract-name)) +(define-values (stronger-prop stronger-pred? stronger-get) + (make-struct-type-property 'contract-stronger-than)) +(define-values (flat-prop flat-pred? flat-get) + (make-struct-type-property 'contract-flat)) + +(define-values (first-order-prop first-order-pred? first-order-get) + (make-struct-type-property 'contract-first-order)) + +(define (contract-first-order-passes? c v) + (cond + [(first-order-pred? c) (((first-order-get c) c) v)] + [(and (procedure? c) + (procedure-arity-includes? c 1)) + ;; flat contract as a predicate + (c v)] + [(flat-pred? c) (((flat-get c) c) v)] + [else (error 'contract-first-order-passes? + "expected a contract as first argument, got ~e, other arg ~e" c v)])) + +(define (proj-get ctc) + (cond + [(proj-pred? ctc) + (raw-proj-get ctc)] + [else (error 'proj-get "unknown ~e" ctc)])) + +;; contract-stronger? : contract contract -> boolean +;; indicates if one contract is stronger (ie, likes fewer values) than another +;; this is not a total order. +(define (contract-stronger? a b) + (let ([a-ctc (coerce-contract 'contract-stronger? a)] + [b-ctc (coerce-contract 'contract-stronger? b)]) + ((stronger-get a-ctc) a-ctc b-ctc))) + + +;; coerce-contract : id (union contract? procedure-arity-1) -> contract +;; contract-proc = sym sym stx -> alpha -> alpha +;; returns the procedure for the contract after extracting it from the +;; struct. Coerces the argument to a flat contract if it is procedure, but first. +(define (coerce-contract name x) + (cond + [(contract? x) x] + [(and (procedure? x) (procedure-arity-includes? x 1)) + (flat-contract x)] + [else + (error name + "expected contract or procedure of arity 1, got ~e" + x)])) + +(define-values (make-exn:fail:contract2 + exn:fail:contract2? + exn:fail:contract2-srclocs + guilty-party) + (let-values ([(exn:fail:contract2 + make-exn:fail:contract2 + exn:fail:contract2? + get + set) + (parameterize ([current-inspector (make-inspector)]) + (make-struct-type 'exn:fail:contract2 + struct:exn:fail:contract + 2 + 0 + #f + (list (cons prop:exn:srclocs + (lambda (x) + (exn:fail:contract2-srclocs x))))))]) + (values + make-exn:fail:contract2 + exn:fail:contract2? + (lambda (x) (get x 0)) + (lambda (x) (get x 1))))) + +(define (default-contract-violation->string val src-info to-blame contract-sexp msg) + (let ([blame-src (src-info-as-string src-info)] + [formatted-contract-sexp + (let ([one-line (format "~s" contract-sexp)]) + (if (< (string-length one-line) 30) + (string-append one-line " ") + (let ([sp (open-output-string)]) + (newline sp) + (parameterize ([pretty-print-print-line print-contract-liner] + [pretty-print-columns 50]) + (pretty-print contract-sexp sp)) + (get-output-string sp))))] + [specific-blame + (let ([datum (syntax->datum src-info)]) + (if (symbol? datum) + (format "on ~a" datum) + ""))]) + (string-append (format "~a~a broke the contract ~a~a; " + blame-src + to-blame + formatted-contract-sexp + specific-blame) + msg))) + +(define contract-violation->string (make-parameter default-contract-violation->string)) + +(define (raise-contract-error val src-info blame contract-sexp fmt . args) + (raise + (make-exn:fail:contract2 + (string->immutable-string + ((contract-violation->string) val + src-info + blame + contract-sexp + (apply format fmt args))) + (current-continuation-marks) + (if src-info + (list (make-srcloc + (syntax-source src-info) + (syntax-line src-info) + (syntax-column src-info) + (syntax-position src-info) + (syntax-span src-info))) + '()) + blame))) + +(define print-contract-liner + (let ([default (pretty-print-print-line)]) + (λ (line port ol cols) + (+ (default line port ol cols) + (if line + (begin (display " " port) + 2) + 0))))) + +;; src-info-as-string : (union syntax #f) -> string +(define (src-info-as-string src-info) + (if (syntax? src-info) + (let ([src-loc-str (build-src-loc-string src-info)]) + (if src-loc-str + (string-append src-loc-str ": ") + "")) + "")) + +; +; +; +; +; +; ; ; +; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;; +; ; ; ; ; ;; ; ; ;; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ;;;; ; ; +; ; ; ; ; ; ; ; ; ; ; ; +; ; ; ; ; ; ; ; ; ; ; ; ; ; +; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;; +; +; +; + +;; contract = (make-contract sexp +;; (sym +;; sym +;; (union syntax #f) +;; string +;; -> +;; (alpha -> alpha))) +;; the first arg to make-contract builds the name of the contract. The +;; path records how the violation occurs +;; +;; generic contract container; +;; the first arg to proc is a symbol representing the name of the positive blame +;; the second arg to proc is the symbol representing the name of the negative blame +;; the third argument to proc is the src-info. +;; the fourth argumet is a textual representation of the original contract +;; +;; the argument to the result function is the value to test. +;; (the result function is the projection) +;; + +(define (flat-proj ctc) + (let ([pred? ((flat-get ctc) ctc)]) + (λ (pos neg src-info orig-str) + (λ (val) + (if (pred? val) + val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val)))))) + +(define (double-any-curried-proj ctc) double-any-curred-proj2) +(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values) + + +(define-values (make-flat-contract + make-proj-contract) + (let () + (define-struct/prop proj-contract (the-name proj first-order-proc) + ((proj-prop (λ (ctc) (proj-contract-proj ctc))) + (name-prop (λ (ctc) (proj-contract-the-name ctc))) + (first-order-prop (λ (ctc) (or (proj-contract-first-order-proc ctc) + (λ (x) #t)))) + (stronger-prop (λ (this that) + (and (proj-contract? that) + (procedure-closure-contents-eq? + (proj-contract-proj this) + (proj-contract-proj that))))))) + + (define-struct/prop flat-contract (the-name predicate) + ((proj-prop flat-proj) + (stronger-prop (λ (this that) + (and (flat-contract? that) + (procedure-closure-contents-eq? (flat-contract-predicate this) + (flat-contract-predicate that))))) + (name-prop (λ (ctc) (flat-contract-the-name ctc))) + (flat-prop (λ (ctc) (flat-contract-predicate ctc))))) + (values make-flat-contract + make-proj-contract))) + +(define (flat-contract-predicate x) + (unless (flat-contract? x) + (error 'flat-contract-predicate "expected a flat contract, got ~e" x)) + ((flat-get x) x)) +(define (flat-contract? x) (flat-pred? x)) +(define (contract-name ctc) + (if (and (procedure? ctc) + (procedure-arity-includes? ctc 1)) + (or (object-name ctc) + 'unknown) + ((name-get ctc) ctc))) +(define (contract? x) (proj-pred? x)) +(define (contract-proc ctc) ((proj-get ctc) ctc)) + +(define (check-flat-contract predicate) + (unless (and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (error 'flat-contract + "expected procedure of arity 1 as argument, given ~e" + predicate))) +(define (flat-contract predicate) + (check-flat-contract predicate) + (let ([pname (object-name predicate)]) + (if pname + (flat-named-contract pname predicate) + (flat-named-contract '??? predicate)))) +(define (check-flat-named-contract predicate) + (unless (and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (error 'flat-named-contract + "expected procedure of arity 1 as second argument, given ~e" + predicate))) +(define (flat-named-contract name predicate) + (check-flat-named-contract predicate) + (build-flat-contract name predicate)) + +(define (build-flat-contract name predicate) (make-flat-contract name predicate)) + +;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) +(define (build-compound-type-name . fs) + (let loop ([subs fs]) + (cond + [(null? subs) + '()] + [else (let ([sub (car subs)]) + (cond + [(contract? sub) + (let ([mk-sub-name (contract-name sub)]) + `(,mk-sub-name ,@(loop (cdr subs))))] + [else `(,sub ,@(loop (cdr subs)))]))]))) + +(define (and-proj ctc) + (let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))]) + (lambda (pos neg src-info orig-str) + (let ([projs (map (λ (c) (c pos neg src-info orig-str)) mk-pos-projs)]) + (let loop ([projs (cdr projs)] + [proj (car projs)]) + (cond + [(null? projs) proj] + [else (loop (cdr projs) + (let ([f (car projs)]) + (λ (v) (proj (f v)))))])))))) + + +(define-struct/prop and/c (ctcs) + ((proj-prop and-proj) + (name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))) + (first-order-prop (λ (ctc) + (let ([tests (map (λ (x) ((first-order-get x) x)) (and/c-ctcs ctc))]) + (λ (x) + (andmap (λ (f) (f x)) tests))))) + (stronger-prop + (λ (this that) + (and (and/c? that) + (let ([this-ctcs (and/c-ctcs this)] + [that-ctcs (and/c-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs)))))))) + +(define (and/c . fs) + (for-each + (lambda (x) + (unless (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1))) + (error 'and/c "expected procedures of arity 1 or s, given: ~e" x))) + fs) + (cond + [(null? fs) any/c] + [(andmap flat-contract/predicate? fs) + (let* ([to-predicate + (lambda (x) + (if (flat-contract? x) + (flat-contract-predicate x) + x))] + [contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)] + [pred + (let loop ([pred (to-predicate (car fs))] + [preds (cdr fs)]) + (cond + [(null? preds) pred] + [else + (let* ([fst (to-predicate (car preds))]) + (loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))]) + and/c-contract?) + (cdr preds)))]))]) + (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))] + [else + (let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]) + (make-and/c contracts))])) + +(define-struct/prop any/c () + ((proj-prop double-any-curried-proj) + (stronger-prop (λ (this that) (any/c? that))) + (name-prop (λ (ctc) 'any/c)) + (first-order-prop (λ (ctc) (λ (val) #t))) + (flat-prop (λ (ctc) (λ (x) #t))))) + +(define any/c (make-any/c)) + +(define (none-curried-proj ctc) + (λ (pos-blame neg-blame src-info orig-str) + (λ (val) + (raise-contract-error + val + src-info + pos-blame + orig-str + "~s accepts no values, given: ~e" + (none/c-name ctc) + val)))) + +(define-struct/prop none/c (name) + ((proj-prop none-curried-proj) + (stronger-prop (λ (this that) #t)) + (name-prop (λ (ctc) (none/c-name ctc))) + (first-order-prop (λ (ctc) (λ (val) #f))) + (flat-prop (λ (ctc) (λ (x) #f))))) + +(define none/c (make-none/c 'none/c)) + +(define (flat-contract/predicate? pred) + (or (flat-contract? pred) + (and (procedure? pred) + (procedure-arity-includes? pred 1)))) \ No newline at end of file diff --git a/collects/scheme/private/contract-helpers.ss b/collects/scheme/private/contract-helpers.ss index e88a1e96a7..7cf43bea82 100644 --- a/collects/scheme/private/contract-helpers.ss +++ b/collects/scheme/private/contract-helpers.ss @@ -1,286 +1,286 @@ -(module contract-helpers mzscheme - - (provide module-source-as-symbol build-src-loc-string - mangle-id mangle-id-for-maker - build-struct-names - nums-up-to - add-name-prop - all-but-last - known-good-contract?) - - (require (lib "main-collects.ss" "setup")) - (require-for-template mzscheme) - - (define (add-name-prop name stx) - (cond - [(identifier? name) - (syntax-property stx 'inferred-name (syntax-e name))] - [(symbol? name) - (syntax-property stx 'inferred-name name)] - [else stx])) - - ;; mangle-id : syntax string syntax ... -> syntax - ;; constructs a mangled name of an identifier from an identifier - ;; the name isn't fresh, so `id' combined with `ids' must already be unique. - (define (mangle-id main-stx prefix id . ids) - (datum->syntax-object +#lang scheme/base + +(provide module-source-as-symbol build-src-loc-string + mangle-id mangle-id-for-maker + build-struct-names + nums-up-to + add-name-prop + all-but-last + known-good-contract?) + +(require setup/main-collects + (for-template scheme/base)) + +(define (add-name-prop name stx) + (cond + [(identifier? name) + (syntax-property stx 'inferred-name (syntax-e name))] + [(symbol? name) + (syntax-property stx 'inferred-name name)] + [else stx])) + +;; mangle-id : syntax string syntax ... -> syntax +;; constructs a mangled name of an identifier from an identifier +;; the name isn't fresh, so `id' combined with `ids' must already be unique. +(define (mangle-id main-stx prefix id . ids) + (datum->syntax + #f + (string->symbol + (string-append + prefix + (format + "-~a~a" + (syntax->datum id) + (apply + string-append + (map + (lambda (id) + (format "-~a" (syntax->datum id))) + ids))))))) + +(define (mangle-id-for-maker main-stx prefix id . ids) + (let ([id-w/out-make (regexp-replace #rx"^make-" (format "~a" (syntax->datum id)) "")]) + (datum->syntax #f (string->symbol (string-append + "make-" prefix (format "-~a~a" - (syntax-object->datum id) + id-w/out-make (apply string-append (map (lambda (id) - (format "-~a" (syntax-object->datum id))) - ids))))))) - - (define (mangle-id-for-maker main-stx prefix id . ids) - (let ([id-w/out-make (regexp-replace #rx"^make-" (format "~a" (syntax-object->datum id)) "")]) - (datum->syntax-object - #f - (string->symbol - (string-append - "make-" - prefix - (format - "-~a~a" - id-w/out-make - (apply - string-append - (map - (lambda (id) - (format "-~a" (syntax-object->datum id))) - ids)))))))) - - ;; (cons X (listof X)) -> (listof X) - ;; returns the elements of `l', minus the last element - ;; special case: if l is an improper list, it leaves off - ;; the contents of the last cdr (ie, making a proper list - ;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2) - (define (all-but-last l) + (format "-~a" (syntax->datum id))) + ids)))))))) + +;; (cons X (listof X)) -> (listof X) +;; returns the elements of `l', minus the last element +;; special case: if l is an improper list, it leaves off +;; the contents of the last cdr (ie, making a proper list +;; out of the input), so (all-but-last '(1 2 . 3)) = '(1 2) +(define (all-but-last l) + (cond + [(null? l) (error 'all-but-last "bad input")] + [(not (pair? l)) '()] + [(null? (cdr l)) null] + [(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))] + [else (list (car l))])) + +;; helper for build-src-loc-string +(define (source->name src) + (let* ([bs (cond [(bytes? src) src] + [(path? src) (path->bytes src)] + [(string? src) (string->bytes/locale src)] + [else #f])] + [r (and bs (path->main-collects-relative bs))]) + (and bs + (bytes->string/locale (if (and (pair? r) (eq? 'collects (car r))) + (bytes-append #"/" (cdr r)) + bs))))) + +;; build-src-loc-string : syntax -> (union #f string) +(define (build-src-loc-string stx) + (let* ([source (source->name (syntax-source stx))] + [line (syntax-line stx)] + [col (syntax-column stx)] + [pos (syntax-position stx)] + [location (cond [(and line col) (format "~a:~a" line col)] + [pos (format "~a" pos)] + [else #f])]) + (if (and source location) + (string-append source ":" location) + (or location source)))) + +(define o (current-output-port)) + +;; module-source-as-symbol : syntax -> symbol +;; constructs a symbol for use in the blame error messages +;; when blaming the module where stx's occurs. +(define (module-source-as-symbol stx) + (let ([src-module (syntax-source-module stx)]) (cond - [(null? l) (error 'all-but-last "bad input")] - [(not (pair? l)) '()] - [(null? (cdr l)) null] - [(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))] - [else (list (car l))])) - - ;; helper for build-src-loc-string - (define (source->name src) - (let* ([bs (cond [(bytes? src) src] - [(path? src) (path->bytes src)] - [(string? src) (string->bytes/locale src)] - [else #f])] - [r (and bs (path->main-collects-relative bs))]) - (and bs - (bytes->string/locale (if (and (pair? r) (eq? 'collects (car r))) - (bytes-append #"/" (cdr r)) - bs))))) - - ;; build-src-loc-string : syntax -> (union #f string) - (define (build-src-loc-string stx) - (let* ([source (source->name (syntax-source stx))] - [line (syntax-line stx)] - [col (syntax-column stx)] - [pos (syntax-position stx)] - [location (cond [(and line col) (format "~a:~a" line col)] - [pos (format "~a" pos)] - [else #f])]) - (if (and source location) - (string-append source ":" location) - (or location source)))) - - (define o (current-output-port)) - - ;; module-source-as-symbol : syntax -> symbol - ;; constructs a symbol for use in the blame error messages - ;; when blaming the module where stx's occurs. - (define (module-source-as-symbol stx) - (let ([src-module (syntax-source-module stx)]) - (cond - [(symbol? src-module) src-module] - [(module-path-index? src-module) - (let-values ([(path base) (module-path-index-split src-module)]) - ;; we dont' normalize here, because we don't - ;; want to assume that the collection paths - ;; are set or the file system can be accessed. - (if path - (string->symbol - (if (and (pair? path) - (eq? (car path) 'quote) - (pair? (cdr path)) - (null? (cddr path))) - (format "'~s" (cadr path)) - (format "~s" path))) - 'top-level))] - [else 'top-level]))) - - - (define build-struct-names - (lambda (name-stx fields omit-sel? omit-set? srcloc-stx) - (let ([name (symbol->string (syntax-e name-stx))] - [fields (map symbol->string (map syntax-e fields))] - [+ string-append]) - (map (lambda (s) - (datum->syntax-object name-stx (string->symbol s) srcloc-stx)) - (append - (list - (+ "struct:" name) - (+ "make-" name) - (+ name "?")) - (let loop ([l fields]) - (if (null? l) - null - (append - (if omit-sel? - null - (list (+ name "-" (car l)))) - (if omit-set? - null - (list (+ "set-" name "-" (car l) "!"))) - (loop (cdr l)))))))))) - - (define (nums-up-to n) - (let loop ([i 0]) - (cond - [(= i n) '()] - [else (cons i (loop (+ i 1)))]))) - - (define known-good-ids - (list #'absolute-path? - #'bound-identifier=? - #'box? - #'byte-pregexp? - #'byte-regexp? - #'byte? - #'bytes-converter? - #'bytes=? - #'bytes? - #'channel? - #'char-alphabetic? - #'char-blank? - #'char-graphic? - #'char-iso-control? - #'char-lower-case? - #'char-numeric? - #'char-punctuation? - #'char-symbolic? - #'char-title-case? - #'char-upper-case? - #'char-whitespace? - #'compiled-expression? - #'compiled-module-expression? - #'complete-path? - #'continuation-mark-set? - #'continuation-prompt-available? - #'custodian-box? - #'custodian-memory-accounting-available? - #'custodian? - #'directory-exists? - #'ephemeron? - #'evt? - #'exn:break? - #'exn:fail:contract:arity? - #'exn:fail:contract:continuation? - #'exn:fail:contract:divide-by-zero? - #'exn:fail:contract:variable? - #'exn:fail:contract? - #'exn:fail:filesystem:exists? - #'exn:fail:filesystem:version? - #'exn:fail:filesystem? - #'exn:fail:network? - #'exn:fail:out-of-memory? - #'exn:fail:read:eof? - #'exn:fail:read:non-char? - #'exn:fail:read? - #'exn:fail:syntax? - #'exn:fail:unsupported? - #'exn:fail:user? - #'exn:fail? - #'exn? - #'file-exists? - #'file-stream-port? - #'free-identifier=? - #'handle-evt? - #'hash-table? - #'identifier? - #'immutable? - #'inspector? - #'keyword? - #'link-exists? - #'module-identifier=? - #'module-path-index? - #'module-provide-protected? - #'module-template-identifier=? - #'module-transformer-identifier=? - #'namespace? - #'parameter-procedure=? - #'parameter? - #'parameterization? - #'path-for-some-system? - #'path-string? - #'path? - #'port-closed? - #'port-provides-progress-evts? - #'port-writes-atomic? - #'port-writes-special? - #'port? - #'pregexp? - #'primitive-closure? - #'primitive? - #'procedure-arity-includes? - #'procedure-closure-contents-eq? - #'procedure-struct-type? - #'promise? - #'pseudo-random-generator? - #'regexp-match? - #'regexp? - #'relative-path? - #'rename-transformer? - #'security-guard? - #'semaphore-try-wait? - #'semaphore? - #'set!-transformer? - #'special-comment? - #'string-locale-ci=? - #'string-locale=? - #'struct-accessor-procedure? - #'struct-constructor-procedure? - #'struct-mutator-procedure? - #'struct-predicate-procedure? - #'struct-type-property? - #'struct-type? - #'struct? - #'subprocess? - #'syntax-graph? - #'syntax-original? - #'syntax-transforming? - #'syntax? - #'system-big-endian? - #'tcp-accept-ready? - #'tcp-listener? - #'tcp-port? - #'terminal-port? - #'thread-cell? - #'thread-dead? - #'thread-group? - #'thread-running? - #'thread? - #'udp-bound? - #'udp-connected? - #'udp? - #'void? - #'weak-box? - #'will-executor? - #'arity-at-least? - #'exn:srclocs? - #'srcloc?)) - - (define (known-good-contract? id) - (and (identifier? id) - (ormap (λ (x) (module-identifier=? x id)) - known-good-ids)))) + [(symbol? src-module) src-module] + [(module-path-index? src-module) + (let-values ([(path base) (module-path-index-split src-module)]) + ;; we dont' normalize here, because we don't + ;; want to assume that the collection paths + ;; are set or the file system can be accessed. + (if path + (string->symbol + (if (and (pair? path) + (eq? (car path) 'quote) + (pair? (cdr path)) + (null? (cddr path))) + (format "'~s" (cadr path)) + (format "~s" path))) + 'top-level))] + [else 'top-level]))) + + +(define build-struct-names + (lambda (name-stx fields omit-sel? omit-set? srcloc-stx) + (let ([name (symbol->string (syntax-e name-stx))] + [fields (map symbol->string (map syntax-e fields))] + [+ string-append]) + (map (lambda (s) + (datum->syntax name-stx (string->symbol s) srcloc-stx)) + (append + (list + (+ "struct:" name) + (+ "make-" name) + (+ name "?")) + (let loop ([l fields]) + (if (null? l) + null + (append + (if omit-sel? + null + (list (+ name "-" (car l)))) + (if omit-set? + null + (list (+ "set-" name "-" (car l) "!"))) + (loop (cdr l)))))))))) + +(define (nums-up-to n) + (let loop ([i 0]) + (cond + [(= i n) '()] + [else (cons i (loop (+ i 1)))]))) + +(define known-good-ids + (list #'absolute-path? + #'bound-identifier=? + #'box? + #'byte-pregexp? + #'byte-regexp? + #'byte? + #'bytes-converter? + #'bytes=? + #'bytes? + #'channel? + #'char-alphabetic? + #'char-blank? + #'char-graphic? + #'char-iso-control? + #'char-lower-case? + #'char-numeric? + #'char-punctuation? + #'char-symbolic? + #'char-title-case? + #'char-upper-case? + #'char-whitespace? + #'compiled-expression? + #'compiled-module-expression? + #'complete-path? + #'continuation-mark-set? + #'continuation-prompt-available? + #'custodian-box? + #'custodian-memory-accounting-available? + #'custodian? + #'directory-exists? + #'ephemeron? + #'evt? + #'exn:break? + #'exn:fail:contract:arity? + #'exn:fail:contract:continuation? + #'exn:fail:contract:divide-by-zero? + #'exn:fail:contract:variable? + #'exn:fail:contract? + #'exn:fail:filesystem:exists? + #'exn:fail:filesystem:version? + #'exn:fail:filesystem? + #'exn:fail:network? + #'exn:fail:out-of-memory? + #'exn:fail:read:eof? + #'exn:fail:read:non-char? + #'exn:fail:read? + #'exn:fail:syntax? + #'exn:fail:unsupported? + #'exn:fail:user? + #'exn:fail? + #'exn? + #'file-exists? + #'file-stream-port? + #'free-identifier=? + #'handle-evt? + #'hash-table? + #'identifier? + #'immutable? + #'inspector? + #'keyword? + #'link-exists? + #'module-identifier=? + #'module-path-index? + #'module-provide-protected? + #'module-template-identifier=? + #'module-transformer-identifier=? + #'namespace? + #'parameter-procedure=? + #'parameter? + #'parameterization? + #'path-for-some-system? + #'path-string? + #'path? + #'port-closed? + #'port-provides-progress-evts? + #'port-writes-atomic? + #'port-writes-special? + #'port? + #'pregexp? + #'primitive-closure? + #'primitive? + #'procedure-arity-includes? + #'procedure-closure-contents-eq? + #'procedure-struct-type? + #'promise? + #'pseudo-random-generator? + #'regexp-match? + #'regexp? + #'relative-path? + #'rename-transformer? + #'security-guard? + #'semaphore-try-wait? + #'semaphore? + #'set!-transformer? + #'special-comment? + #'string-locale-ci=? + #'string-locale=? + #'struct-accessor-procedure? + #'struct-constructor-procedure? + #'struct-mutator-procedure? + #'struct-predicate-procedure? + #'struct-type-property? + #'struct-type? + #'struct? + #'subprocess? + #'syntax-graph? + #'syntax-original? + #'syntax-transforming? + #'syntax? + #'system-big-endian? + #'tcp-accept-ready? + #'tcp-listener? + #'tcp-port? + #'terminal-port? + #'thread-cell? + #'thread-dead? + #'thread-group? + #'thread-running? + #'thread? + #'udp-bound? + #'udp-connected? + #'udp? + #'void? + #'weak-box? + #'will-executor? + #'arity-at-least? + #'exn:srclocs? + #'srcloc?)) + +(define (known-good-contract? id) + (and (identifier? id) + (ormap (λ (x) (free-identifier=? x id)) + known-good-ids))) diff --git a/collects/scheme/private/contract-object.ss b/collects/scheme/private/contract-object.ss index 4d670d7691..a8aa0760ae 100644 --- a/collects/scheme/private/contract-object.ss +++ b/collects/scheme/private/contract-object.ss @@ -1,23 +1,22 @@ -(module contract-object mzscheme - (require (lib "etc.ss") - "contract-arrow.ss" - "contract-guts.ss" - "class-internal.ss" - "contract-arr-checks.ss") - - (require-for-syntax "contract-helpers.ss" - "contract-arr-obj-helpers.ss" - (lib "list.ss")) - - (provide mixin-contract - make-mixin-contract - is-a?/c - subclass?/c - implementation?/c - object-contract) - - (define-syntax-set (object-contract) - +#lang scheme/base +(require "contract-arrow.ss" + "contract-guts.ss" + "class-internal.ss" + "contract-arr-checks.ss") + +(require (for-syntax scheme/base + "contract-helpers.ss" + "contract-arr-obj-helpers.ss")) + +(provide mixin-contract + make-mixin-contract + is-a?/c + subclass?/c + 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)) @@ -41,11 +40,11 @@ [(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-> #'->)) - (define (object-contract/proc stx) + (λ (stx) ;; name : syntax ;; ctc-stx : syntax[evals to a contract] @@ -161,7 +160,7 @@ (syntax (->d any/c doms ... (let ([f rng-proc]) - (check->* f arity-count) + (check->* f arity-count) (lambda (_this-var arg-vars ...) (f arg-vars ...)))))) (with-syntax ([(args-vars ...) (generate-temporaries doms-val)]) @@ -174,7 +173,7 @@ [arity-count (length doms-val)]) (syntax (->d* (any/c doms ...) (let ([f rng-proc]) - (check->* f arity-count) + (check->* f arity-count) (lambda (_this-var arg-vars ...) (f arg-vars ...))))))) (with-syntax ([(args-vars ...) (generate-temporaries (syntax (doms ...)))] @@ -190,7 +189,7 @@ (syntax (->d* (any/c doms ...) rst-ctc (let ([f rng-proc]) - (check->*/more f arity-count) + (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 ...)))] @@ -204,7 +203,7 @@ (andmap identifier? (syntax->list (syntax (x ...)))) (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) + [this (datum->syntax mtd-stx 'this)]) (values obj->r/proc (syntax (->r ([this any/c] [x dom] ...) rng)) @@ -214,7 +213,7 @@ (andmap identifier? (syntax->list (syntax (x ...)))) (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) + [this (datum->syntax mtd-stx 'this)]) (values obj->r/proc (syntax (->r ([this any/c] [x dom] ...) rest-x rest-dom rng)) @@ -226,7 +225,7 @@ (andmap identifier? (syntax->list (syntax (x ...)))) (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) + [this (datum->syntax mtd-stx 'this)]) (values obj->pp/proc (syntax (->pp ([this any/c] [x dom] ...) . other-stuff)) @@ -238,7 +237,7 @@ (andmap identifier? (syntax->list (syntax (x ...))))) (with-syntax ([(arg-vars ...) (generate-temporaries (syntax (x ...)))] [(this-var) (generate-temporaries (syntax (this-var)))] - [this (datum->syntax-object mtd-stx 'this)]) + [this (datum->syntax mtd-stx 'this)]) (values obj->pp-rest/proc (syntax (->pp ([this any/c] [x dom] ...) rest-id . other-stuff)) @@ -249,6 +248,12 @@ ;; 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]) @@ -279,7 +284,7 @@ rest-ids ... last-var)))))]))) (syntax->list arg-spec-stxs))] - [name (string->symbol (format "~a method" (syntax-object->datum (car names))))]) + [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) @@ -307,8 +312,8 @@ (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)]) + [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)] @@ -334,105 +339,105 @@ '(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) + (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)] ...) - - (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)))))))]))) + (let ([field-names-list '(field-name ...)]) + (lambda (val) + (check-object val src-info pos-blame orig-str) + (let ([val-mtd-names + (interface->method-names + (object-interface + val))]) + (void) + (check-method val 'method-name val-mtd-names src-info pos-blame orig-str) + ...) + + (unless (field-bound? field-name val) + (field-error val 'field-name src-info pos-blame orig-str)) ... + + (let ([vtable (extract-vtable val)] + [method-ht (extract-method-ht val)]) + (make-object cls + val + (method/app-var (vector-ref vtable (hash-table-get method-ht 'method-name))) ... + (field/app-var (get-field field-name val)) ... + )))))) + #f)))))))])))) - - (define (check-object val src-info blame orig-str) - (unless (object? val) - (raise-contract-error val - src-info - blame - orig-str - "expected an object, got ~e" - val))) - - (define (check-method val method-name val-mtd-names src-info blame orig-str) - (unless (memq method-name val-mtd-names) - (raise-contract-error val - src-info - blame - orig-str - "expected an object with method ~s" - method-name))) - - (define (field-error val field-name src-info blame orig-str) + +(define (check-object val src-info blame orig-str) + (unless (object? val) (raise-contract-error val src-info blame orig-str - "expected an object with field ~s" - field-name)) - - (define (make-mixin-contract . %/<%>s) - ((and/c (flat-contract class?) - (apply and/c (map sub/impl?/c %/<%>s))) - . ->d . - subclass?/c)) - - (define (subclass?/c %) - (unless (class? %) - (error 'subclass?/c "expected , given: ~e" %)) - (let ([name (object-name %)]) - (flat-named-contract - `(subclass?/c ,(or name 'unknown%)) - (lambda (x) (subclass? x %))))) - - (define (implementation?/c <%>) - (unless (interface? <%>) - (error 'implementation?/c "expected , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - `(implementation?/c ,(or name 'unknown<%>)) - (lambda (x) (implementation? x <%>))))) - - (define (sub/impl?/c %/<%>) - (cond - [(interface? %/<%>) (implementation?/c %/<%>)] - [(class? %/<%>) (subclass?/c %/<%>)] - [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) + "expected an object, got ~e" + val))) - (define (is-a?/c <%>) - (unless (or (interface? <%>) - (class? <%>)) - (error 'is-a?/c "expected or , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - (cond - [name - `(is-a?/c ,name)] - [(class? <%>) - `(is-a?/c unknown%)] - [else `(is-a?/c unknown<%>)]) - (lambda (x) (is-a? x <%>))))) - - (define mixin-contract (class? . ->d . subclass?/c))) +(define (check-method val method-name val-mtd-names src-info blame orig-str) + (unless (memq method-name val-mtd-names) + (raise-contract-error val + src-info + blame + orig-str + "expected an object with method ~s" + method-name))) + +(define (field-error val field-name src-info blame orig-str) + (raise-contract-error val + src-info + blame + orig-str + "expected an object with field ~s" + field-name)) + +(define (make-mixin-contract . %/<%>s) + ((and/c (flat-contract class?) + (apply and/c (map sub/impl?/c %/<%>s))) + . ->d . + subclass?/c)) + +(define (subclass?/c %) + (unless (class? %) + (error 'subclass?/c "expected , given: ~e" %)) + (let ([name (object-name %)]) + (flat-named-contract + `(subclass?/c ,(or name 'unknown%)) + (lambda (x) (subclass? x %))))) + +(define (implementation?/c <%>) + (unless (interface? <%>) + (error 'implementation?/c "expected , given: ~e" <%>)) + (let ([name (object-name <%>)]) + (flat-named-contract + `(implementation?/c ,(or name 'unknown<%>)) + (lambda (x) (implementation? x <%>))))) + +(define (sub/impl?/c %/<%>) + (cond + [(interface? %/<%>) (implementation?/c %/<%>)] + [(class? %/<%>) (subclass?/c %/<%>)] + [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) + +(define (is-a?/c <%>) + (unless (or (interface? <%>) + (class? <%>)) + (error 'is-a?/c "expected or , given: ~e" <%>)) + (let ([name (object-name <%>)]) + (flat-named-contract + (cond + [name + `(is-a?/c ,name)] + [(class? <%>) + `(is-a?/c unknown%)] + [else `(is-a?/c unknown<%>)]) + (lambda (x) (is-a? x <%>))))) + +(define mixin-contract (class? . ->d . subclass?/c)) diff --git a/collects/scheme/private/contract-opt-guts.ss b/collects/scheme/private/contract-opt-guts.ss index dd3548593f..679d1ae5a0 100644 --- a/collects/scheme/private/contract-opt-guts.ss +++ b/collects/scheme/private/contract-opt-guts.ss @@ -1,162 +1,161 @@ -(module contract-opt-guts mzscheme - (require (lib "private/boundmap.ss" "syntax") - (lib "list.ss")) - (require-for-template mzscheme) - - (provide get-opter reg-opter! opter - interleave-lifts - - make-opt/info - opt/info-contract - opt/info-val - opt/info-pos - opt/info-neg - opt/info-src-info - opt/info-orig-str - opt/info-free-vars - opt/info-recf - opt/info-base-pred - opt/info-this - opt/info-that - - opt/info-swap-blame - opt/info-change-val) - - ;; a hash table of opters - (define opters-table - (make-module-identifier-mapping)) - - ;; get-opter : syntax -> opter - (define (get-opter ctc) - (module-identifier-mapping-get opters-table ctc (λ () #f))) - - ;; opter : (union symbol identifier) -> opter - (define (opter ctc) - (if (identifier? ctc) - (get-opter ctc) - (error 'opter "the argument must be a bound identifier, got ~e" ctc))) - - ;; reg-opter! : symbol opter -> - (define (reg-opter! ctc opter) - (module-identifier-mapping-put! opters-table ctc opter)) - - ;; interleave-lifts : list list -> list - ;; interleaves a list of variables names and a list of sexps into a list of - ;; (var sexp) pairs. - (define (interleave-lifts vars sexps) - (if (= (length vars) (length sexps)) - (if (null? vars) null - (cons (cons (car vars) (car sexps)) - (interleave-lifts (cdr vars) (cdr sexps)))) - (error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps))) +#lang scheme/base +(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts + (for-template scheme/base) + (for-syntax scheme/base)) + +(provide get-opter reg-opter! opter + interleave-lifts + + make-opt/info + opt/info-contract + opt/info-val + opt/info-pos + opt/info-neg + opt/info-src-info + opt/info-orig-str + opt/info-free-vars + opt/info-recf + opt/info-base-pred + opt/info-this + opt/info-that + + opt/info-swap-blame + opt/info-change-val) + +;; a hash table of opters +(define opters-table + (make-module-identifier-mapping)) + +;; get-opter : syntax -> opter +(define (get-opter ctc) + (module-identifier-mapping-get opters-table ctc (λ () #f))) + +;; opter : (union symbol identifier) -> opter +(define (opter ctc) + (if (identifier? ctc) + (get-opter ctc) + (error 'opter "the argument must be a bound identifier, got ~e" ctc))) + +;; reg-opter! : symbol opter -> +(define (reg-opter! ctc opter) + (module-identifier-mapping-put! opters-table ctc opter)) + +;; interleave-lifts : list list -> list +;; interleaves a list of variables names and a list of sexps into a list of +;; (var sexp) pairs. +(define (interleave-lifts vars sexps) + (if (= (length vars) (length sexps)) + (if (null? vars) null + (cons (cons (car vars) (car sexps)) + (interleave-lifts (cdr vars) (cdr sexps)))) + (error 'interleave-lifts "expected lists of equal length, got ~e and ~e" vars sexps))) - ;; struct for color-keeping across opters - (define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that)) - - ;; opt/info-swap-blame : opt/info -> opt/info - ;; swaps pos and neg - (define (opt/info-swap-blame info) - (let ((ctc (opt/info-contract info)) - (val (opt/info-val info)) - (pos (opt/info-neg info)) - (neg (opt/info-pos info)) - (src-info (opt/info-src-info info)) - (orig-str (opt/info-orig-str info)) - (free-vars (opt/info-free-vars info)) - (recf (opt/info-recf info)) - (base-pred (opt/info-base-pred info)) - (this (opt/info-this info)) - (that (opt/info-that info))) - (make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that))) - - ;; opt/info-change-val : identifier opt/info -> opt/info - ;; changes the name of the variable that the value-to-be-contracted is bound to - (define (opt/info-change-val val info) - (let ((ctc (opt/info-contract info)) - (pos (opt/info-neg info)) - (neg (opt/info-pos info)) - (src-info (opt/info-src-info info)) - (orig-str (opt/info-orig-str info)) - (free-vars (opt/info-free-vars info)) - (recf (opt/info-recf info)) - (base-pred (opt/info-base-pred info)) - (this (opt/info-this info)) - (that (opt/info-that info))) - (make-opt/info ctc val neg pos src-info orig-str free-vars recf base-pred this that))) - - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; stronger helper functions - ;; +;; struct for color-keeping across opters +(define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that)) - ;; new-stronger-var : identifier (identifier identifier -> exp) -> stronger-rib - ;; the second identifier should be bound (in a lift) to an expression whose value has to be saved. - ;; The ids passed to cogen are expected to be bound to two contracts' values of that expression, when - ;; those contracts are being compared for strongerness - (define (new-stronger-var id cogen) - (with-syntax ([(var-this var-that) (generate-temporaries (list id id))]) - (make-stronger-rib (syntax var-this) - (syntax var-that) - id - (cogen (syntax var-this) - (syntax var-that))))) +;; opt/info-swap-blame : opt/info -> opt/info +;; swaps pos and neg +(define (opt/info-swap-blame info) + (let ((ctc (opt/info-contract info)) + (val (opt/info-val info)) + (pos (opt/info-neg info)) + (neg (opt/info-pos info)) + (src-info (opt/info-src-info info)) + (orig-str (opt/info-orig-str info)) + (free-vars (opt/info-free-vars info)) + (recf (opt/info-recf info)) + (base-pred (opt/info-base-pred info)) + (this (opt/info-this info)) + (that (opt/info-that info))) + (make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that))) + +;; opt/info-change-val : identifier opt/info -> opt/info +;; changes the name of the variable that the value-to-be-contracted is bound to +(define (opt/info-change-val val info) + (let ((ctc (opt/info-contract info)) + (pos (opt/info-neg info)) + (neg (opt/info-pos info)) + (src-info (opt/info-src-info info)) + (orig-str (opt/info-orig-str info)) + (free-vars (opt/info-free-vars info)) + (recf (opt/info-recf info)) + (base-pred (opt/info-base-pred info)) + (this (opt/info-this info)) + (that (opt/info-that info))) + (make-opt/info ctc val neg pos src-info orig-str free-vars recf base-pred this that))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; stronger helper functions +;; + +;; new-stronger-var : identifier (identifier identifier -> exp) -> stronger-rib +;; the second identifier should be bound (in a lift) to an expression whose value has to be saved. +;; The ids passed to cogen are expected to be bound to two contracts' values of that expression, when +;; those contracts are being compared for strongerness +(define (new-stronger-var id cogen) + (with-syntax ([(var-this var-that) (generate-temporaries (list id id))]) + (make-stronger-rib (syntax var-this) + (syntax var-that) + id + (cogen (syntax var-this) + (syntax var-that))))) + +(define empty-stronger '()) + +(define-struct stronger-rib (this-var that-var save-id stronger-exp)) + +(provide new-stronger-var + (struct-out stronger-rib)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; lifting helper functions +;; +(provide lift/binding lift/effect empty-lifts bind-lifts bind-superlifts lifts-to-save) + +;; lift/binding : syntax[expression] identifier lifts -> (values syntax lifts) +;; adds a new id to `lifts' that is bound to `e'. Returns the +;; variable that was bound +;; values that are lifted are also saved in the wrapper to make sure that the rhs's are evaluated at the right time. +(define (lift/binding e id-hint lifts) + (syntax-case e () + [x + (or (identifier? e) + (number? (syntax-e e)) + (boolean? (syntax-e e))) + (values e lifts)] + [else + (let ([x (car (generate-temporaries (list id-hint)))]) + (values x + (snoc (cons x e) lifts)))])) + +;; lift/effect : syntax[expression] lifts -> lifts +;; adds a new lift to `lifts' that is evaluated for effect. no variable returned +(define (lift/effect e lifts) + (let ([x (car (generate-temporaries '(lift/effect)))]) + (snoc (cons #f e) lifts))) + +(define (snoc x l) (append l (list x))) + +;; empty-lifts : lifts +;; the initial lifts +(define empty-lifts '()) + +(define (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*)) +(define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec)) + +(define (do-bind-lifts lifts stx binding-form) + (if (null? lifts) + stx + (with-syntax ([((lifts-x . lift-e) ...) lifts]) + (with-syntax ([(lifts-x ...) (map (λ (x) (if (identifier? x) x (car (generate-temporaries '(junk))))) + (syntax->list (syntax (lifts-x ...))))] + [binding-form binding-form]) + #`(binding-form ([lifts-x lift-e] ...) + #,stx))))) + +(define (lifts-to-save lifts) (filter values (map car lifts))) - (define empty-stronger '()) - - (define-struct stronger-rib (this-var that-var save-id stronger-exp)) - - (provide new-stronger-var - (struct stronger-rib (this-var that-var save-id stronger-exp))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; lifting helper functions - ;; - (provide lift/binding lift/effect empty-lifts bind-lifts bind-superlifts lifts-to-save) - - ;; lift/binding : syntax[expression] identifier lifts -> (values syntax lifts) - ;; adds a new id to `lifts' that is bound to `e'. Returns the - ;; variable that was bound - ;; values that are lifted are also saved in the wrapper to make sure that the rhs's are evaluated at the right time. - (define (lift/binding e id-hint lifts) - (syntax-case e () - [x - (or (identifier? e) - (number? (syntax-e e)) - (boolean? (syntax-e e))) - (values e lifts)] - [else - (let ([x (car (generate-temporaries (list id-hint)))]) - (values x - (snoc (cons x e) lifts)))])) - - ;; lift/effect : syntax[expression] lifts -> lifts - ;; adds a new lift to `lifts' that is evaluated for effect. no variable returned - (define (lift/effect e lifts) - (let ([x (car (generate-temporaries '(lift/effect)))]) - (snoc (cons #f e) lifts))) - - (define (snoc x l) (append l (list x))) - - ;; empty-lifts : lifts - ;; the initial lifts - (define empty-lifts '()) - - (define (bind-lifts lifts stx) (do-bind-lifts lifts stx #'let*)) - (define (bind-superlifts lifts stx) (do-bind-lifts lifts stx #'letrec)) - - (define (do-bind-lifts lifts stx binding-form) - (if (null? lifts) - stx - (with-syntax ([((lifts-x . lift-e) ...) lifts]) - (with-syntax ([(lifts-x ...) (map (λ (x) (if (identifier? x) x (car (generate-temporaries '(junk))))) - (syntax->list (syntax (lifts-x ...))))] - [binding-form binding-form]) - #`(binding-form ([lifts-x lift-e] ...) - #,stx))))) - - (define (lifts-to-save lifts) (filter values (map car lifts))) - - ) \ No newline at end of file diff --git a/collects/scheme/private/contract-opt.ss b/collects/scheme/private/contract-opt.ss index 32c99a4d33..f7a38e2684 100644 --- a/collects/scheme/private/contract-opt.ss +++ b/collects/scheme/private/contract-opt.ss @@ -1,232 +1,232 @@ -(module contract-opt mzscheme - (require "contract-guts.ss" - (lib "stxparam.ss") - (lib "etc.ss")) - (require-for-syntax "contract-opt-guts.ss" - (lib "etc.ss") - (lib "stxparam.ss") - (lib "list.ss")) - - (provide opt/c define-opt/c define/opter opt-stronger-vars-ref) - - ;; define/opter : id -> syntax - ;; - ;; Takes an expression which is to be expected of the following signature: - ;; - ;; opter : id id syntax list-of-ids -> - ;; syntax syntax-list syntax-list syntax-list (union syntax #f) (union syntax #f) syntax - ;; - ;; - ;; It takes in an identifier for pos, neg, and the original syntax. An identifier - ;; that can be used to call the opt/i function is also implicitly passed into - ;; every opter. A list of free-variables is implicitly passed if the calling context - ;; was define/osc otherwise it is null. - ;; - ;; Every opter needs to return: - ;; - the optimized syntax - ;; - lifted variables: a list of (id, sexp) pairs - ;; - super-lifted variables: functions or the such defined at the toplevel of the - ;; calling context of the opt routine. - ;; Currently this is only used for struct contracts. - ;; - partially applied contracts: a list of (id, sexp) pairs - ;; - if the contract being optimized is flat, - ;; then an sexp that evals to bool, - ;; else #f - ;; This is used in conjunction with optimizing flat contracts into one boolean - ;; expression when optimizing or/c. - ;; - if the contract can be optimized, - ;; then #f (that is, it is not unknown) - ;; else the symbol of the lifted variable - ;; This is used for contracts with subcontracts (like cons) doing checks. - ;; - a list of stronger-ribs - (define-syntax (define/opter stx) - (syntax-case stx () - [(_ (for opt/i opt/info stx) expr ...) - (if (identifier? #'for) - #'(begin - (begin-for-syntax - (reg-opter! - #'for - (λ (opt/i opt/info stx) - expr ...))) - #t) - (error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))])) - - ;; - ;; opt/unknown : opt/i id id syntax - ;; - (define-for-syntax (opt/unknown opt/i opt/info uctc) - (let* ((lift-var (car (generate-temporaries (syntax (lift))))) - (partial-var (car (generate-temporaries (syntax (partial))))) - (partial-flat-var (car (generate-temporaries (syntax (partial-flat)))))) - (values - (with-syntax ((partial-var partial-var) - (lift-var lift-var) - (uctc uctc) - (val (opt/info-val opt/info))) - (syntax (partial-var val))) - (list (cons lift-var - ;; FIXME needs to get the contract name somehow - (with-syntax ((uctc uctc)) - (syntax (coerce-contract 'opt/c uctc))))) - null - (list (cons - partial-var - (with-syntax ((lift-var lift-var) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info))) - (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))) - (cons - partial-flat-var - (with-syntax ((lift-var lift-var)) - (syntax (if (flat-pred? lift-var) - ((flat-get lift-var) lift-var) - (lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s" - lift-var - x))))))) - (with-syntax ([val (opt/info-val opt/info)] - [partial-flat-var partial-flat-var]) - #'(partial-flat-var val)) - lift-var - null))) - - ;; - ;; opt/recursive-call - ;; - ;; BUG: currently does not try to optimize the arguments, this requires changing - ;; every opter to keep track of bound variables. - ;; - (define-for-syntax (opt/recursive-call opt/info stx) +#lang scheme/base +(require "contract-guts.ss" + scheme/stxparam + (lib "etc.ss")) +(require (for-syntax scheme/base) + (for-syntax "contract-opt-guts.ss") + (for-syntax (lib "etc.ss")) + (for-syntax scheme/stxparam)) + +(provide opt/c define-opt/c define/opter opt-stronger-vars-ref) + +;; define/opter : id -> syntax +;; +;; Takes an expression which is to be expected of the following signature: +;; +;; opter : id id syntax list-of-ids -> +;; syntax syntax-list syntax-list syntax-list (union syntax #f) (union syntax #f) syntax +;; +;; +;; It takes in an identifier for pos, neg, and the original syntax. An identifier +;; that can be used to call the opt/i function is also implicitly passed into +;; every opter. A list of free-variables is implicitly passed if the calling context +;; was define/osc otherwise it is null. +;; +;; Every opter needs to return: +;; - the optimized syntax +;; - lifted variables: a list of (id, sexp) pairs +;; - super-lifted variables: functions or the such defined at the toplevel of the +;; calling context of the opt routine. +;; Currently this is only used for struct contracts. +;; - partially applied contracts: a list of (id, sexp) pairs +;; - if the contract being optimized is flat, +;; then an sexp that evals to bool, +;; else #f +;; This is used in conjunction with optimizing flat contracts into one boolean +;; expression when optimizing or/c. +;; - if the contract can be optimized, +;; then #f (that is, it is not unknown) +;; else the symbol of the lifted variable +;; This is used for contracts with subcontracts (like cons) doing checks. +;; - a list of stronger-ribs +(define-syntax (define/opter stx) + (syntax-case stx () + [(_ (for opt/i opt/info stx) expr ...) + (if (identifier? #'for) + #'(begin + (begin-for-syntax + (reg-opter! + #'for + (λ (opt/i opt/info stx) + expr ...))) + (void)) + (error 'define/opter "expected opter name to be an identifier, got ~e" (syntax-e #'for)))])) + +;; +;; opt/unknown : opt/i id id syntax +;; +(define-for-syntax (opt/unknown opt/i opt/info uctc) + (let* ((lift-var (car (generate-temporaries (syntax (lift))))) + (partial-var (car (generate-temporaries (syntax (partial))))) + (partial-flat-var (car (generate-temporaries (syntax (partial-flat)))))) (values - (with-syntax ((stx stx) - (val (opt/info-val opt/info)) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info))) - (syntax (let ((ctc stx)) - ((((proj-get ctc) ctc) pos neg src-info orig-str) val)))) + (with-syntax ((partial-var partial-var) + (lift-var lift-var) + (uctc uctc) + (val (opt/info-val opt/info))) + (syntax (partial-var val))) + (list (cons lift-var + ;; FIXME needs to get the contract name somehow + (with-syntax ((uctc uctc)) + (syntax (coerce-contract 'opt/c uctc))))) null - null - null - #f - #f - null - null)) - - ;; make-stronger : list-of-(union syntax #f) -> syntax - (define-for-syntax (make-stronger strongers) - (let ((filtered (filter (λ (x) (not (eq? x #f))) strongers))) - (if (null? filtered) - #t - (with-syntax (((stronger ...) strongers)) - (syntax (and stronger ...)))))) + (list (cons + partial-var + (with-syntax ((lift-var lift-var) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str)))) + (cons + partial-flat-var + (with-syntax ((lift-var lift-var)) + (syntax (if (flat-pred? lift-var) + ((flat-get lift-var) lift-var) + (lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s" + lift-var + x))))))) + (with-syntax ([val (opt/info-val opt/info)] + [partial-flat-var partial-flat-var]) + #'(partial-flat-var val)) + lift-var + null))) - ;; opt/c : syntax -> syntax - ;; opt/c is an optimization routine that takes in an sexp containing - ;; contract combinators and attempts to "unroll" those combinators to save - ;; on things such as closure allocation time. - (define-syntax (opt/c stx) - - ;; opt/i : id opt/info syntax -> - ;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) - (define (opt/i opt/info stx) - (syntax-case stx (if) - [(ctc arg ...) - (and (identifier? #'ctc) (opter #'ctc)) - ((opter #'ctc) opt/i opt/info stx)] - [argless-ctc - (and (identifier? #'argless-ctc) (opter #'argless-ctc)) - ((opter #'argless-ctc) opt/i opt/info stx)] - [(f arg ...) - (and (identifier? #'f) - (syntax-parameter-value #'define/opt-recursive-fn) - (module-identifier=? (syntax-parameter-value #'define/opt-recursive-fn) - #'f)) - (values - #`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...) - null - null - null - #f - #f - null)] - [else - (opt/unknown opt/i opt/info stx)])) - - (syntax-case stx () - [(_ e) #'(opt/c e ())] - [(_ e (opt-recursive-args ...)) - (let*-values ([(info) (make-opt/info #'ctc - #'val - #'pos - #'neg - #'src-info - #'orig-str - (syntax->list #'(opt-recursive-args ...)) - #f - #f - #'this - #'that)] - [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) - (with-syntax ([next next]) - (bind-superlifts - superlifts - (bind-lifts - lifts - #`(make-opt-contract - (λ (ctc) - (λ (pos neg src-info orig-str) - #,(if (syntax-parameter-value #'define/opt-recursive-fn) - (with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)]) - (bind-superlifts - (cons - (cons (syntax-parameter-value #'define/opt-recursive-fn) - #'(λ (val opt-recursive-args ...) next)) - partials) - #'(λ (val) - (f val opt-recursive-args ...)))) +;; +;; opt/recursive-call +;; +;; BUG: currently does not try to optimize the arguments, this requires changing +;; every opter to keep track of bound variables. +;; +(define-for-syntax (opt/recursive-call opt/info stx) + (values + (with-syntax ((stx stx) + (val (opt/info-val opt/info)) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (let ((ctc stx)) + ((((proj-get ctc) ctc) pos neg src-info orig-str) val)))) + null + null + null + #f + #f + null + null)) + +;; make-stronger : list-of-(union syntax #f) -> syntax +(define-for-syntax (make-stronger strongers) + (let ((filtered (filter (λ (x) (not (eq? x #f))) strongers))) + (if (null? filtered) + #t + (with-syntax (((stronger ...) strongers)) + (syntax (and stronger ...)))))) + +;; opt/c : syntax -> syntax +;; opt/c is an optimization routine that takes in an sexp containing +;; contract combinators and attempts to "unroll" those combinators to save +;; on things such as closure allocation time. +(define-syntax (opt/c stx) + + ;; opt/i : id opt/info syntax -> + ;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f) + (define (opt/i opt/info stx) + (syntax-case stx (if) + [(ctc arg ...) + (and (identifier? #'ctc) (opter #'ctc)) + ((opter #'ctc) opt/i opt/info stx)] + [argless-ctc + (and (identifier? #'argless-ctc) (opter #'argless-ctc)) + ((opter #'argless-ctc) opt/i opt/info stx)] + [(f arg ...) + (and (identifier? #'f) + (syntax-parameter-value #'define/opt-recursive-fn) + (free-identifier=? (syntax-parameter-value #'define/opt-recursive-fn) + #'f)) + (values + #`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...) + null + null + null + #f + #f + null)] + [else + (opt/unknown opt/i opt/info stx)])) + + (syntax-case stx () + [(_ e) #'(opt/c e ())] + [(_ e (opt-recursive-args ...)) + (let*-values ([(info) (make-opt/info #'ctc + #'val + #'pos + #'neg + #'src-info + #'orig-str + (syntax->list #'(opt-recursive-args ...)) + #f + #f + #'this + #'that)] + [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) + (with-syntax ([next next]) + (bind-superlifts + superlifts + (bind-lifts + lifts + #`(make-opt-contract + (λ (ctc) + (λ (pos neg src-info orig-str) + #,(if (syntax-parameter-value #'define/opt-recursive-fn) + (with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)]) (bind-superlifts - partials - #`(λ (val) next))))) - (λ () e) - (λ (this that) #f) - (vector) - (begin-lifted (box #f)))))))])) + (cons + (cons (syntax-parameter-value #'define/opt-recursive-fn) + #'(λ (val opt-recursive-args ...) next)) + partials) + #'(λ (val) + (f val opt-recursive-args ...)))) + (bind-superlifts + partials + #`(λ (val) next))))) + (λ () e) + (λ (this that) #f) + (vector) + (begin-lifted (box #f)))))))])) - (define-syntax-parameter define/opt-recursive-fn #f) - - (define-syntax (define-opt/c stx) - (syntax-case stx () - [(_ (id args ...) body) - #'(define (id args ...) - (syntax-parameterize ([define/opt-recursive-fn #'id]) - (opt/c body (args ...))))])) - - ;; optimized contracts - ;; - ;; getting the name of an optimized contract is slow, but it is only - ;; called when blame is raised (thankfully). - ;; - ;; note that lifts, partials, flat, and unknown are all built into the - ;; projection itself and should not be exposed to the outside anyhow. - (define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) - (make-struct-type-property 'original-contract)) - - (define-struct/prop opt-contract (proj orig-ctc stronger stronger-vars stamp) - ((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))) - ;; I think provide/contract and contract calls this, so we are in effect allocating - ;; the original once - (name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))) - (orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))) - (stronger-prop (λ (this that) - (and (opt-contract? that) - (eq? (opt-contract-stamp this) (opt-contract-stamp that)) - ((opt-contract-stronger this) this that)))))) - - ;; opt-stronger-vars-ref : int opt-contract -> any - (define (opt-stronger-vars-ref i ctc) - (let ((v (opt-contract-stronger-vars ctc))) - (vector-ref v i)))) +(define-syntax-parameter define/opt-recursive-fn #f) + +(define-syntax (define-opt/c stx) + (syntax-case stx () + [(_ (id args ...) body) + #'(define (id args ...) + (syntax-parameterize ([define/opt-recursive-fn #'id]) + (opt/c body (args ...))))])) + +;; optimized contracts +;; +;; getting the name of an optimized contract is slow, but it is only +;; called when blame is raised (thankfully). +;; +;; note that lifts, partials, flat, and unknown are all built into the +;; projection itself and should not be exposed to the outside anyhow. +(define-values (orig-ctc-prop orig-ctc-pred? orig-ctc-get) + (make-struct-type-property 'original-contract)) + +(define-struct/prop opt-contract (proj orig-ctc stronger stronger-vars stamp) + ((proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))) + ;; I think provide/contract and contract calls this, so we are in effect allocating + ;; the original once + (name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))) + (orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))) + (stronger-prop (λ (this that) + (and (opt-contract? that) + (eq? (opt-contract-stamp this) (opt-contract-stamp that)) + ((opt-contract-stronger this) this that)))))) + +;; opt-stronger-vars-ref : int opt-contract -> any +(define (opt-stronger-vars-ref i ctc) + (let ((v (opt-contract-stronger-vars ctc))) + (vector-ref v i))) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 44eb7e155d..4bf346b5c1 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -1,3 +1,5 @@ +#lang scheme/base + #| improve method arity mismatch contract violation error messages? @@ -5,30 +7,27 @@ improve method arity mismatch contract violation error messages? |# -(module contract mzscheme - - (provide (rename -contract contract) - recursive-contract - provide/contract - define/contract) - (require-for-syntax mzscheme - "contract-opt-guts.ss" - (lib "list.ss") - (lib "stx.ss" "syntax") - (lib "etc.ss") - (lib "name.ss" "syntax") - (lib "struct-info.ss" "scheme")) - - (require "contract-arrow.ss" - "contract-guts.ss" - "contract-opt.ss") - - (require "contract-helpers.ss") - (require-for-syntax (prefix a: "contract-helpers.ss")) - - +(provide (rename-out [-contract contract]) + recursive-contract + provide/contract + define/contract) + +(require (for-syntax scheme/base) + (for-syntax "contract-opt-guts.ss") + (for-syntax scheme/struct-info) + (for-syntax scheme/list)) + +(require "contract-arrow.ss" + "contract-guts.ss" + "contract-opt.ss") + +(require "contract-helpers.ss" + (for-syntax (prefix-in a: "contract-helpers.ss"))) + + + ; ; ; @@ -46,114 +45,114 @@ improve method arity mismatch contract violation error messages? ; ; ; - ;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) - (define-for-syntax (lookup-struct-info stx provide-stx) - (let ([id (syntax-case stx () - [(a b) (syntax a)] - [_ stx])]) - (let ([v (syntax-local-value id (λ () #f))]) - (if (struct-info? v) - (extract-struct-info v) - (raise-syntax-error 'provide/contract - "expected a struct name" - provide-stx - id))))) - - (define-for-syntax (make-define/contract-transformer contract-id id) - (make-set!-transformer +;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...)) +(define-for-syntax (lookup-struct-info stx provide-stx) + (let ([id (syntax-case stx () + [(a b) (syntax a)] + [_ stx])]) + (let ([v (syntax-local-value id (λ () #f))]) + (if (struct-info? v) + (extract-struct-info v) + (raise-syntax-error 'provide/contract + "expected a struct name" + provide-stx + id))))) + +(define-for-syntax (make-define/contract-transformer contract-id id) + (make-set!-transformer + (λ (stx) + (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")] + [contract-id contract-id] + [id id]) + (syntax-case stx (set!) + [(set! id arg) + (raise-syntax-error 'define/contract + "cannot set! a define/contract variable" + stx + (syntax id))] + [(f arg ...) + (syntax/loc stx + ((-contract contract-id + id + (syntax->datum (quote-syntax f)) + (string->symbol neg-blame-str) + (quote-syntax f)) + arg + ...))] + [ident + (identifier? (syntax ident)) + (syntax/loc stx + (-contract contract-id + id + (syntax->datum (quote-syntax ident)) + (string->symbol neg-blame-str) + (quote-syntax ident)))]))))) + +(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) + (make-set!-transformer + (let ([saved-id-table (make-hash-table)]) (λ (stx) - (with-syntax ([neg-blame-str (or (a:build-src-loc-string stx) "")] - [contract-id contract-id] - [id id]) - (syntax-case stx (set!) - [(set! _ arg) - (raise-syntax-error 'define/contract - "cannot set! a define/contract variable" - stx - (syntax _))] - [(_ arg ...) - (syntax/loc stx - ((-contract contract-id - id - (syntax-object->datum (quote-syntax _)) - (string->symbol neg-blame-str) - (quote-syntax _)) - arg - ...))] - [_ - (identifier? (syntax _)) - (syntax/loc stx - (-contract contract-id - id - (syntax-object->datum (quote-syntax _)) - (string->symbol neg-blame-str) - (quote-syntax _)))]))))) - - (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) - (make-set!-transformer - (let ([saved-id-table (make-hash-table)]) - (λ (stx) - (if (eq? 'expression (syntax-local-context)) - ;; In an expression context: - (let ([key (syntax-local-lift-context)]) - ;; Already lifted in this lifting context? - (unless (hash-table-get saved-id-table key #f) - ;; No: lift the contract creation: - (with-syntax ([contract-id contract-id] - [id id] - [name (datum->syntax-object #f (syntax-object->datum id) id)] - [pos-module-source pos-module-source]) - (hash-table-put! - saved-id-table - key - (syntax-local-introduce - (syntax-local-lift-expression - #'(-contract contract-id - id - pos-module-source - (module-source-as-symbol #'name) - (quote-syntax name))))))) - ;; Expand to a use of the lifted expression: - (with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))]) - (syntax-case stx (set!) - [name - (identifier? (syntax name)) - (syntax saved-id)] - [(name . more) - (with-syntax ([app (datum->syntax-object stx '#%app)]) - (syntax/loc stx (app saved-id . more)))]))) - ;; In case of partial expansion for module-level and internal-defn contexts, - ;; delay expansion until it's a good time to lift expressions: - (quasisyntax/loc stx (#%expression #,stx))))))) - - ;; (define/contract id contract expr) - ;; defines `id' with `contract'; initially binding - ;; it to the result of `expr'. These variables may not be set!'d. - (define-syntax (define/contract define-stx) - (syntax-case define-stx () - [(_ name contract-expr expr) - (identifier? (syntax name)) - (with-syntax ([contract-id - (a:mangle-id define-stx - "define/contract-contract-id" - (syntax name))] - [id (a:mangle-id define-stx - "define/contract-id" - (syntax name))]) - (syntax/loc define-stx - (begin - (define contract-id contract-expr) - (define-syntax name - (make-define/contract-transformer (quote-syntax contract-id) - (quote-syntax id))) - (define id (let ([name expr]) name)) ;; let for procedure naming - )))] - [(_ name contract-expr expr) - (raise-syntax-error 'define/contract "expected identifier in first position" - define-stx - (syntax name))])) - - + (if (eq? 'expression (syntax-local-context)) + ;; In an expression context: + (let ([key (syntax-local-lift-context)]) + ;; Already lifted in this lifting context? + (unless (hash-table-get saved-id-table key #f) + ;; No: lift the contract creation: + (with-syntax ([contract-id contract-id] + [id id] + [name (datum->syntax #f (syntax->datum id) id)] + [pos-module-source pos-module-source]) + (hash-table-put! + saved-id-table + key + (syntax-local-introduce + (syntax-local-lift-expression + #'(-contract contract-id + id + pos-module-source + (module-source-as-symbol #'name) + (quote-syntax name))))))) + ;; Expand to a use of the lifted expression: + (with-syntax ([saved-id (syntax-local-introduce (hash-table-get saved-id-table key))]) + (syntax-case stx (set!) + [name + (identifier? (syntax name)) + (syntax saved-id)] + [(name . more) + (with-syntax ([app (datum->syntax stx '#%app)]) + (syntax/loc stx (app saved-id . more)))]))) + ;; In case of partial expansion for module-level and internal-defn contexts, + ;; delay expansion until it's a good time to lift expressions: + (quasisyntax/loc stx (#%expression #,stx))))))) + +;; (define/contract id contract expr) +;; defines `id' with `contract'; initially binding +;; it to the result of `expr'. These variables may not be set!'d. +(define-syntax (define/contract define-stx) + (syntax-case define-stx () + [(_ name contract-expr expr) + (identifier? (syntax name)) + (with-syntax ([contract-id + (a:mangle-id define-stx + "define/contract-contract-id" + (syntax name))] + [id (a:mangle-id define-stx + "define/contract-id" + (syntax name))]) + (syntax/loc define-stx + (begin + (define contract-id contract-expr) + (define-syntax name + (make-define/contract-transformer (quote-syntax contract-id) + (quote-syntax id))) + (define id (let ([name expr]) name)) ;; let for procedure naming + )))] + [(_ name contract-expr expr) + (raise-syntax-error 'define/contract "expected identifier in first position" + define-stx + (syntax name))])) + + ; ; ; @@ -171,634 +170,634 @@ improve method arity mismatch contract violation error messages? ; ; ; ; ; - - ;; (provide/contract p/c-ele ...) - ;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...) - ;; provides each `id' with the contract `expr'. - (define-syntax (provide/contract provide-stx) - (syntax-case provide-stx (struct) - [(_ p/c-ele ...) - (let () - - ;; code-for-each-clause : (listof syntax) -> (listof syntax) - ;; constructs code for each clause of a provide/contract - (define (code-for-each-clause clauses) - (cond - [(null? clauses) null] - [else - (let ([clause (car clauses)]) - ;; compare raw identifiers for `struct' and `rename' just like provide does - (syntax-case* clause (struct rename) (λ (x y) (eq? (syntax-e x) (syntax-e y))) - [(rename this-name new-name contract) - (and (identifier? (syntax this-name)) - (identifier? (syntax new-name))) - (cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name)) - (code-for-each-clause (cdr clauses)))] - [(rename this-name new-name contract) - (identifier? (syntax this-name)) - (raise-syntax-error 'provide/contract - "malformed rename clause, expected an identifier" - provide-stx - (syntax new-name))] - [(rename this-name new-name contract) - (identifier? (syntax new-name)) - (raise-syntax-error 'provide/contract - "malformed rename clause, expected an identifier" - provide-stx - (syntax this-name))] - [(rename . _) - (raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)] - [(struct struct-name ((field-name contract) ...)) - (and (well-formed-struct-name? (syntax struct-name)) - (andmap identifier? (syntax->list (syntax (field-name ...))))) - (let ([sc (build-struct-code provide-stx - (syntax struct-name) - (syntax->list (syntax (field-name ...))) - (syntax->list (syntax (contract ...))))]) - (cons sc (code-for-each-clause (cdr clauses))))] - [(struct name) - (identifier? (syntax name)) - (raise-syntax-error 'provide/contract - "missing fields" - provide-stx - clause)] - [(struct name . rest) - (not (well-formed-struct-name? (syntax name))) - (raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them" - provide-stx - (syntax name))] - [(struct name (fields ...)) - (for-each (λ (field) - (syntax-case field () - [(x y) - (identifier? (syntax x)) - (void)] - [(x y) - (raise-syntax-error 'provide/contract - "malformed struct field, expected identifier" - provide-stx - (syntax x))] - [else - (raise-syntax-error 'provide/contract - "malformed struct field" - provide-stx - field)])) - (syntax->list (syntax (fields ...)))) - - ;; if we didn't find a bad field something is wrong! - (raise-syntax-error 'provide/contract "internal error" provide-stx clause)] - [(struct name . fields) - (raise-syntax-error 'provide/contract - "malformed struct fields" - provide-stx - clause)] - [(name contract) - (identifier? (syntax name)) - (cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f) - (code-for-each-clause (cdr clauses)))] - [(name contract) - (raise-syntax-error 'provide/contract - "expected identifier" - provide-stx - (syntax name))] - [unk - (raise-syntax-error 'provide/contract - "malformed clause" - provide-stx - (syntax unk))]))])) - - ;; well-formed-struct-name? : syntax -> bool - (define (well-formed-struct-name? stx) - (or (identifier? stx) - (syntax-case stx () - [(name super) - (and (identifier? (syntax name)) - (identifier? (syntax super))) - #t] - [else #f]))) - - ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax - ;; constructs the code for a struct clause - ;; first arg is the original syntax object, for source locations - (define (build-struct-code stx struct-name-position field-names field-contracts) - (let* ([struct-name (syntax-case struct-name-position () - [(a b) (syntax a)] - [else struct-name-position])] - [super-id (syntax-case struct-name-position () - [(a b) (syntax b)] - [else #t])] - - - [all-parent-struct-count/names (get-field-counts/struct-names struct-name provide-stx)] - [parent-struct-count (if (null? all-parent-struct-count/names) - #f - (let ([pp (cdr all-parent-struct-count/names)]) - (if (null? pp) - #f - (car (car pp)))))] - - [struct-info (lookup-struct-info struct-name-position provide-stx)] - [constructor-id (list-ref struct-info 1)] - [predicate-id (list-ref struct-info 2)] - [selector-ids (reverse (list-ref struct-info 3))] - [is-id-ok? - (λ (id i) - (if (or (not parent-struct-count) - (parent-struct-count . <= . i)) - id - #t))] - [mutator-ids (let ([candidate-mutator-ids (reverse (list-ref struct-info 4))]) - (if (andmap/count is-id-ok? candidate-mutator-ids) - candidate-mutator-ids - #f))] - [field-contract-ids (map (λ (field-name field-contract) - (if (a:known-good-contract? field-contract) - field-contract - (a:mangle-id provide-stx - "provide/contract-field-contract" - field-name - struct-name))) - field-names - field-contracts)] - [struct:struct-name - (datum->syntax-object - struct-name - (string->symbol - (string-append - "struct:" - (symbol->string (syntax-e struct-name)))))] - - [-struct:struct-name - (datum->syntax-object - struct-name - (string->symbol - (string-append - "-struct:" - (symbol->string (syntax-e struct-name)))))] - - [is-new-id? - (λ (index) - (or (not parent-struct-count) - (parent-struct-count . <= . index)))]) - - (let ([unknown-info - (λ (what names) - (raise-syntax-error - 'provide/contract - (format "cannot determine ~a, found ~s" what names) - provide-stx - struct-name))]) - - (unless constructor-id (unknown-info "constructor" constructor-id)) - (unless predicate-id (unknown-info "predicate" predicate-id)) - (unless (andmap/count is-id-ok? selector-ids) - (unknown-info "selectors" - (map (λ (x) (if (syntax? x) - (syntax-object->datum x) - x)) - selector-ids)))) - - (unless (equal? (length selector-ids) - (length field-contract-ids)) - (raise-syntax-error 'provide/contract - (format "found ~a field~a in struct, but ~a contract~a" - (length selector-ids) - (if (= 1 (length selector-ids)) "" "s") - (length field-contract-ids) - (if (= 1 (length field-contract-ids)) "" "s")) - provide-stx - struct-name)) - (unless (or (not mutator-ids) - (equal? (length mutator-ids) - (length field-contract-ids))) - (raise-syntax-error 'provide/contract - (format "found ~a fields in struct, but ~a contracts" - (length mutator-ids) - (length field-contract-ids)) - provide-stx - struct-name)) - - ;; make sure the field names are right. - (let* ([relative-counts (let loop ([c (map car all-parent-struct-count/names)]) - (cond - [(null? c) null] - [(null? (cdr c)) c] - [else (cons (- (car c) (cadr c)) - (loop (cdr c)))]))] - [names (map cdr all-parent-struct-count/names)] - [maker-name (format "~a" (syntax-e constructor-id))] - [struct-name (substring maker-name 5 (string-length maker-name))]) - (let loop ([count (car relative-counts)] - [name (car names)] - [counts (cdr relative-counts)] - [names (cdr names)] - [selector-strs (reverse (map (λ (x) (format "~a" (syntax-e x))) selector-ids))] - [field-names (reverse field-names)]) - (cond - [(or (null? selector-strs) (null? field-names)) - (void)] - [(zero? count) - (loop (car counts) (car names) (cdr counts) (cdr names) - selector-strs - field-names)] - [else - (let* ([selector-str (car selector-strs)] - [field-name (car field-names)] - [field-name-should-be - (substring selector-str - (+ (string-length name) 1) - (string-length selector-str))] - [field-name-is (format "~a" (syntax-e field-name))]) - (unless (equal? field-name-should-be field-name-is) - (raise-syntax-error 'provide/contract - (format "expected field name to be ~a, but found ~a" - field-name-should-be - field-name-is) - provide-stx - field-name)) - (loop (- count 1) - name - counts - names - (cdr selector-strs) - (cdr field-names)))]))) - - (with-syntax ([((selector-codes selector-new-names) ...) - (filter - (λ (x) x) - (map/count (λ (selector-id field-contract-id index) - (if (is-new-id? index) - (code-for-one-id/new-name - stx - selector-id - (build-selector-contract struct-name - predicate-id - field-contract-id) - #f) - #f)) - selector-ids - field-contract-ids))] - [(rev-selector-old-names ...) - (reverse - (filter - (λ (x) x) - (map/count (λ (selector-id index) - (if (not (is-new-id? index)) - selector-id - #f)) - selector-ids)))] - [((mutator-codes mutator-new-names) ...) - (if mutator-ids - (filter - (λ (x) x) - (map/count (λ (mutator-id field-contract-id index) - (if (is-new-id? index) - (code-for-one-id/new-name stx - mutator-id - (build-mutator-contract struct-name - predicate-id - field-contract-id) - #f) - #f)) - mutator-ids - field-contract-ids)) - (list))] - [(rev-mutator-old-names ...) - (if mutator-ids - (reverse - (filter - (λ (x) x) - (map/count (λ (mutator-id index) - (if (not (is-new-id? index)) - mutator-id - #f)) - mutator-ids))) - '())] - [(predicate-code predicate-new-name) - (code-for-one-id/new-name stx predicate-id (syntax (-> any/c boolean?)) #f)] - [(constructor-code constructor-new-name) - (code-for-one-id/new-name - stx - constructor-id - (build-constructor-contract stx - field-contract-ids - predicate-id) - #f - #t)] - - [(field-contract-id-definitions ...) - (filter values (map (λ (field-contract-id field-contract) - (if (a:known-good-contract? field-contract) - #f - (with-syntax ([field-contract-id field-contract-id] - [field-contract field-contract]) - #'(define field-contract-id (verify-contract field-contract))))) - field-contract-ids - field-contracts))] - [(field-contracts ...) field-contracts] - [(field-contract-ids ...) field-contract-ids]) - - (with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))] - [(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))]) - (with-syntax ([struct-code - (with-syntax ([id-rename (a:mangle-id provide-stx - "provide/contract-struct-expandsion-info-id" - struct-name)] - [struct-name struct-name] - [-struct:struct-name -struct:struct-name] - [super-id (if (boolean? super-id) - super-id - (with-syntax ([super-id super-id]) - (syntax ((syntax-local-certifier) #'super-id))))] - [mutator-id-info - (if mutator-ids - #'(list (slc #'rev-mutator-new-names) ... - (slc #'rev-mutator-old-names) ...) - #''(#f))]) - (syntax (begin - (provide (rename id-rename struct-name)) - (define-syntax id-rename - (let ([slc (syntax-local-certifier)]) - (list (slc #'-struct:struct-name) - (slc #'constructor-new-name) - (slc #'predicate-new-name) - (list (slc #'rev-selector-new-names) ... - (slc #'rev-selector-old-names) ...) - mutator-id-info - super-id))))))] - [struct:struct-name struct:struct-name] - [-struct:struct-name -struct:struct-name] - [struct-name struct-name] - [(selector-ids ...) selector-ids]) - (syntax/loc stx - (begin - struct-code - field-contract-id-definitions ... - selector-codes ... - mutator-codes ... - predicate-code - constructor-code - - ;; expanding out the body of the `make-pc-struct-type' function - ;; directly here in the expansion makes this very expensive at compile time - ;; when there are a lot of provide/contract clause using structs - (define -struct:struct-name - (make-pc-struct-type 'struct-name struct:struct-name field-contract-ids ...)) - (provide (rename -struct:struct-name struct:struct-name))))))))) - - (define (map/count f . ls) - (let loop ([ls ls] - [i 0]) - (cond - [(andmap null? ls) '()] - [(ormap null? ls) (error 'map/count "mismatched lists")] - [else (cons (apply f (append (map car ls) (list i))) - (loop (map cdr ls) - (+ i 1)))]))) - ;; andmap/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z) - (define (andmap/count f l1) - (let loop ([l1 l1] - [i 0]) - (cond - [(null? l1) #t] - [else (and (f (car l1) i) - (loop (cdr l1) - (+ i 1)))]))) - - ;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number)) - ;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs - (define (get-field-counts/struct-names struct-name provide-stx) - (let loop ([parent-info-id struct-name]) - (let ([parent-info - (and (identifier? parent-info-id) - (lookup-struct-info parent-info-id provide-stx))]) - (cond - [(boolean? parent-info) null] - [else - (let ([fields (list-ref parent-info 3)] - [constructor (list-ref parent-info 1)]) - (cond - [(and (not (null? fields)) - (not (car (last-pair fields)))) - (raise-syntax-error - 'provide/contract - "cannot determine the number of fields in super struct" - provide-stx - struct-name)] - [else - (cons (cons (length fields) (constructor->struct-name provide-stx constructor)) - (loop (list-ref parent-info 5)))]))])))) - - (define (constructor->struct-name orig-stx stx) - (and stx - (let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))]) - (cond - [m (cadr m)] - [else (raise-syntax-error 'contract.ss - "unable to cope with a struct maker whose name doesn't begin with `make-'" - orig-stx)])))) - - ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax - (define (build-constructor-contract stx field-contract-ids predicate-id) - (with-syntax ([(field-contract-ids ...) field-contract-ids] - [predicate-id predicate-id]) - (syntax/loc stx - (-> field-contract-ids ... - predicate-id)))) - - ;; build-selector-contract : syntax syntax -> syntax - ;; constructs the contract for a selector - (define (build-selector-contract struct-name predicate-id field-contract-id) - (with-syntax ([field-contract-id field-contract-id] - [predicate-id predicate-id]) - (syntax (-> predicate-id field-contract-id)))) - - ;; build-mutator-contract : syntax syntax -> syntax - ;; constructs the contract for a selector - (define (build-mutator-contract struct-name predicate-id field-contract-id) - (with-syntax ([field-contract-id field-contract-id] - [predicate-id predicate-id]) - (syntax (-> predicate-id - field-contract-id - void?)))) - - ;; code-for-one-id : syntax syntax syntax (union syntax #f) -> syntax - ;; given the syntax for an identifier and a contract, - ;; builds a begin expression for the entire contract and provide - ;; the first syntax object is used for source locations - (define (code-for-one-id stx id ctrct user-rename-id) - (with-syntax ([(code id) (code-for-one-id/new-name stx id ctrct user-rename-id)]) - (syntax code))) - - ;; code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax) - ;; given the syntax for an identifier and a contract, - ;; builds a begin expression for the entire contract and provide - ;; the first syntax object is used for source locations - (define code-for-one-id/new-name - (case-lambda - [(stx id ctrct user-rename-id) - (code-for-one-id/new-name stx id ctrct user-rename-id #f)] - [(stx id ctrct user-rename-id mangle-for-maker?) - (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]) - (with-syntax ([id-rename ((if mangle-for-maker? - a:mangle-id-for-maker - a:mangle-id) - provide-stx - "provide/contract-id" - (or user-rename-id id))] - [contract-id (if no-need-to-check-ctrct? - ctrct +;; (provide/contract p/c-ele ...) +;; p/c-ele = (id expr) | (rename id id expr) | (struct id (id expr) ...) +;; provides each `id' with the contract `expr'. +(define-syntax (provide/contract provide-stx) + (syntax-case provide-stx (struct) + [(_ p/c-ele ...) + (let () + + ;; code-for-each-clause : (listof syntax) -> (listof syntax) + ;; constructs code for each clause of a provide/contract + (define (code-for-each-clause clauses) + (cond + [(null? clauses) null] + [else + (let ([clause (car clauses)]) + ;; compare raw identifiers for `struct' and `rename' just like provide does + (syntax-case* clause (struct rename) (λ (x y) (eq? (syntax-e x) (syntax-e y))) + [(rename this-name new-name contract) + (and (identifier? (syntax this-name)) + (identifier? (syntax new-name))) + (cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name)) + (code-for-each-clause (cdr clauses)))] + [(rename this-name new-name contract) + (identifier? (syntax this-name)) + (raise-syntax-error 'provide/contract + "malformed rename clause, expected an identifier" + provide-stx + (syntax new-name))] + [(rename this-name new-name contract) + (identifier? (syntax new-name)) + (raise-syntax-error 'provide/contract + "malformed rename clause, expected an identifier" + provide-stx + (syntax this-name))] + [(rename . _) + (raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)] + [(struct struct-name ((field-name contract) ...)) + (and (well-formed-struct-name? (syntax struct-name)) + (andmap identifier? (syntax->list (syntax (field-name ...))))) + (let ([sc (build-struct-code provide-stx + (syntax struct-name) + (syntax->list (syntax (field-name ...))) + (syntax->list (syntax (contract ...))))]) + (cons sc (code-for-each-clause (cdr clauses))))] + [(struct name) + (identifier? (syntax name)) + (raise-syntax-error 'provide/contract + "missing fields" + provide-stx + clause)] + [(struct name . rest) + (not (well-formed-struct-name? (syntax name))) + (raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them" + provide-stx + (syntax name))] + [(struct name (fields ...)) + (for-each (λ (field) + (syntax-case field () + [(x y) + (identifier? (syntax x)) + (void)] + [(x y) + (raise-syntax-error 'provide/contract + "malformed struct field, expected identifier" + provide-stx + (syntax x))] + [else + (raise-syntax-error 'provide/contract + "malformed struct field" + provide-stx + field)])) + (syntax->list (syntax (fields ...)))) + + ;; if we didn't find a bad field something is wrong! + (raise-syntax-error 'provide/contract "internal error" provide-stx clause)] + [(struct name . fields) + (raise-syntax-error 'provide/contract + "malformed struct fields" + provide-stx + clause)] + [(name contract) + (identifier? (syntax name)) + (cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f) + (code-for-each-clause (cdr clauses)))] + [(name contract) + (raise-syntax-error 'provide/contract + "expected identifier" + provide-stx + (syntax name))] + [unk + (raise-syntax-error 'provide/contract + "malformed clause" + provide-stx + (syntax unk))]))])) + + ;; well-formed-struct-name? : syntax -> bool + (define (well-formed-struct-name? stx) + (or (identifier? stx) + (syntax-case stx () + [(name super) + (and (identifier? (syntax name)) + (identifier? (syntax super))) + #t] + [else #f]))) + + ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax + ;; constructs the code for a struct clause + ;; first arg is the original syntax object, for source locations + (define (build-struct-code stx struct-name-position field-names field-contracts) + (let* ([struct-name (syntax-case struct-name-position () + [(a b) (syntax a)] + [else struct-name-position])] + [super-id (syntax-case struct-name-position () + [(a b) (syntax b)] + [else #t])] + + + [all-parent-struct-count/names (get-field-counts/struct-names struct-name provide-stx)] + [parent-struct-count (if (null? all-parent-struct-count/names) + #f + (let ([pp (cdr all-parent-struct-count/names)]) + (if (null? pp) + #f + (car (car pp)))))] + + [struct-info (lookup-struct-info struct-name-position provide-stx)] + [constructor-id (list-ref struct-info 1)] + [predicate-id (list-ref struct-info 2)] + [selector-ids (reverse (list-ref struct-info 3))] + [is-id-ok? + (λ (id i) + (if (or (not parent-struct-count) + (parent-struct-count . <= . i)) + id + #t))] + [mutator-ids (let ([candidate-mutator-ids (reverse (list-ref struct-info 4))]) + (if (andmap/count is-id-ok? candidate-mutator-ids) + candidate-mutator-ids + #f))] + [field-contract-ids (map (λ (field-name field-contract) + (if (a:known-good-contract? field-contract) + field-contract (a:mangle-id provide-stx - "provide/contract-contract-id" - (or user-rename-id id)))] - [pos-module-source (a:mangle-id provide-stx - "provide/contract-pos-module-source" - (or user-rename-id id))] - [pos-stx (datum->syntax-object id 'here)] - [id id] - [ctrct (syntax-property ctrct 'inferred-name id)] - [external-name (or user-rename-id id)] - [where-stx stx]) - (with-syntax ([code - (quasisyntax/loc stx - (begin - (define pos-module-source (module-source-as-symbol #'pos-stx)) - - #,@(if no-need-to-check-ctrct? - (list) - (list #'(define contract-id (verify-contract ctrct)))) - (define-syntax id-rename - (make-provide/contract-transformer (quote-syntax contract-id) - (quote-syntax id) - (quote-syntax pos-module-source))) - - (provide (rename id-rename external-name))))]) - - (syntax-local-lift-module-end-declaration - #'(begin - (-contract contract-id id pos-module-source 'ignored #'id) - (void))) - - (syntax (code id-rename)))))])) - - (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) - (syntax - (begin - bodies ...))))])) - - (define-syntax (verify-contract stx) - (syntax-case stx () - [(_ x) (a:known-good-contract? #'x) #'x] - [(_ x) #'(verify-contract/proc x)])) - - (define (verify-contract/proc x) - (unless (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1))) - (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x)) - x) - - - (define (make-pc-struct-type struct-name struct:struct-name . ctcs) - (let-values ([(struct:struct-name _make _pred _get _set) - (make-struct-type struct-name - struct:struct-name - 0 ;; init - 0 ;; auto - #f ;; auto-v - '() ;; props - #f ;; inspector - #f ;; proc-spec - '() ;; immutable-k-list - (λ args - (let ([vals (let loop ([args args]) - (cond - [(null? args) null] - [(null? (cdr args)) null] - [else (cons (car args) (loop (cdr args)))]))]) - (apply values - (map (λ (ctc val) - (-contract ctc - val - 'not-enough-info-for-blame - 'not-enough-info-for-blame)) - ctcs - vals)))))]) - struct:struct-name)) - - (define (test-proc/flat-contract f x) - (if (flat-contract? f) - ((flat-contract-predicate f) x) - (f x))) - - (define (proc/ctc->ctc f) - (if (contract? f) - f - (flat-named-contract - (or (object-name f) - (string->symbol (format "contract:~e" f))) - f))) - - (define-syntax (-contract stx) - (syntax-case stx () - [(_ a-contract to-check pos-blame-e neg-blame-e) - (with-syntax ([src-loc (syntax/loc stx here)]) - (syntax/loc stx - (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] - [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) - (syntax/loc stx - (begin - (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))])) - - (define (contract/proc a-contract-raw name pos-blame neg-blame src-info) - (unless (or (contract? a-contract-raw) - (and (procedure? a-contract-raw) - (procedure-arity-includes? a-contract-raw 1))) - (error 'contract "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e ~e" - a-contract-raw - name - pos-blame - neg-blame - src-info)) - (let ([a-contract (if (contract? a-contract-raw) - a-contract-raw - (flat-contract a-contract-raw))]) - (unless (and (symbol? neg-blame) - (symbol? pos-blame)) - (error 'contract - "expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e" - neg-blame pos-blame - a-contract-raw - name - src-info)) - (unless (syntax? src-info) - (error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e" - src-info - neg-blame - pos-blame - a-contract-raw - name)) - (((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract)) - name))) - - (define-syntax (recursive-contract stx) - (syntax-case stx () - [(_ arg) - (syntax (make-proj-contract - '(recursive-contract arg) - (λ (pos-blame neg-blame src str) - (let ([proc (contract-proc arg)]) - (λ (val) - ((proc pos-blame neg-blame src str) val)))) - #f))])) - - (define (check-contract ctc) - (unless (contract? ctc) - (error 'recursive-contract "expected a contract, got ~e" ctc)) - ctc) + "provide/contract-field-contract" + field-name + struct-name))) + field-names + field-contracts)] + [struct:struct-name + (datum->syntax + struct-name + (string->symbol + (string-append + "struct:" + (symbol->string (syntax-e struct-name)))))] + + [-struct:struct-name + (datum->syntax + struct-name + (string->symbol + (string-append + "-struct:" + (symbol->string (syntax-e struct-name)))))] + + [is-new-id? + (λ (index) + (or (not parent-struct-count) + (parent-struct-count . <= . index)))]) + + (let ([unknown-info + (λ (what names) + (raise-syntax-error + 'provide/contract + (format "cannot determine ~a, found ~s" what names) + provide-stx + struct-name))]) + + (unless constructor-id (unknown-info "constructor" constructor-id)) + (unless predicate-id (unknown-info "predicate" predicate-id)) + (unless (andmap/count is-id-ok? selector-ids) + (unknown-info "selectors" + (map (λ (x) (if (syntax? x) + (syntax->datum x) + x)) + selector-ids)))) + + (unless (equal? (length selector-ids) + (length field-contract-ids)) + (raise-syntax-error 'provide/contract + (format "found ~a field~a in struct, but ~a contract~a" + (length selector-ids) + (if (= 1 (length selector-ids)) "" "s") + (length field-contract-ids) + (if (= 1 (length field-contract-ids)) "" "s")) + provide-stx + struct-name)) + (unless (or (not mutator-ids) + (equal? (length mutator-ids) + (length field-contract-ids))) + (raise-syntax-error 'provide/contract + (format "found ~a fields in struct, but ~a contracts" + (length mutator-ids) + (length field-contract-ids)) + provide-stx + struct-name)) + + ;; make sure the field names are right. + (let* ([relative-counts (let loop ([c (map car all-parent-struct-count/names)]) + (cond + [(null? c) null] + [(null? (cdr c)) c] + [else (cons (- (car c) (cadr c)) + (loop (cdr c)))]))] + [names (map cdr all-parent-struct-count/names)] + [maker-name (format "~a" (syntax-e constructor-id))] + [struct-name (substring maker-name 5 (string-length maker-name))]) + (let loop ([count (car relative-counts)] + [name (car names)] + [counts (cdr relative-counts)] + [names (cdr names)] + [selector-strs (reverse (map (λ (x) (format "~a" (syntax-e x))) selector-ids))] + [field-names (reverse field-names)]) + (cond + [(or (null? selector-strs) (null? field-names)) + (void)] + [(zero? count) + (loop (car counts) (car names) (cdr counts) (cdr names) + selector-strs + field-names)] + [else + (let* ([selector-str (car selector-strs)] + [field-name (car field-names)] + [field-name-should-be + (substring selector-str + (+ (string-length name) 1) + (string-length selector-str))] + [field-name-is (format "~a" (syntax-e field-name))]) + (unless (equal? field-name-should-be field-name-is) + (raise-syntax-error 'provide/contract + (format "expected field name to be ~a, but found ~a" + field-name-should-be + field-name-is) + provide-stx + field-name)) + (loop (- count 1) + name + counts + names + (cdr selector-strs) + (cdr field-names)))]))) + + (with-syntax ([((selector-codes selector-new-names) ...) + (filter + (λ (x) x) + (map/count (λ (selector-id field-contract-id index) + (if (is-new-id? index) + (code-for-one-id/new-name + stx + selector-id + (build-selector-contract struct-name + predicate-id + field-contract-id) + #f) + #f)) + selector-ids + field-contract-ids))] + [(rev-selector-old-names ...) + (reverse + (filter + (λ (x) x) + (map/count (λ (selector-id index) + (if (not (is-new-id? index)) + selector-id + #f)) + selector-ids)))] + [((mutator-codes mutator-new-names) ...) + (if mutator-ids + (filter + (λ (x) x) + (map/count (λ (mutator-id field-contract-id index) + (if (is-new-id? index) + (code-for-one-id/new-name stx + mutator-id + (build-mutator-contract struct-name + predicate-id + field-contract-id) + #f) + #f)) + mutator-ids + field-contract-ids)) + (list))] + [(rev-mutator-old-names ...) + (if mutator-ids + (reverse + (filter + (λ (x) x) + (map/count (λ (mutator-id index) + (if (not (is-new-id? index)) + mutator-id + #f)) + mutator-ids))) + '())] + [(predicate-code predicate-new-name) + (code-for-one-id/new-name stx predicate-id (syntax (-> any/c boolean?)) #f)] + [(constructor-code constructor-new-name) + (code-for-one-id/new-name + stx + constructor-id + (build-constructor-contract stx + field-contract-ids + predicate-id) + #f + #t)] + + [(field-contract-id-definitions ...) + (filter values (map (λ (field-contract-id field-contract) + (if (a:known-good-contract? field-contract) + #f + (with-syntax ([field-contract-id field-contract-id] + [field-contract field-contract]) + #'(define field-contract-id (verify-contract field-contract))))) + field-contract-ids + field-contracts))] + [(field-contracts ...) field-contracts] + [(field-contract-ids ...) field-contract-ids]) + + (with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))] + [(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))]) + (with-syntax ([struct-code + (with-syntax ([id-rename (a:mangle-id provide-stx + "provide/contract-struct-expandsion-info-id" + struct-name)] + [struct-name struct-name] + [-struct:struct-name -struct:struct-name] + [super-id (if (boolean? super-id) + super-id + (with-syntax ([super-id super-id]) + (syntax ((syntax-local-certifier) #'super-id))))] + [mutator-id-info + (if mutator-ids + #'(list (slc #'rev-mutator-new-names) ... + (slc #'rev-mutator-old-names) ...) + #''(#f))]) + (syntax (begin + (provide (rename-out [id-rename struct-name])) + (define-syntax id-rename + (let ([slc (syntax-local-certifier)]) + (list (slc #'-struct:struct-name) + (slc #'constructor-new-name) + (slc #'predicate-new-name) + (list (slc #'rev-selector-new-names) ... + (slc #'rev-selector-old-names) ...) + mutator-id-info + super-id))))))] + [struct:struct-name struct:struct-name] + [-struct:struct-name -struct:struct-name] + [struct-name struct-name] + [(selector-ids ...) selector-ids]) + (syntax/loc stx + (begin + struct-code + field-contract-id-definitions ... + selector-codes ... + mutator-codes ... + predicate-code + constructor-code + + ;; expanding out the body of the `make-pc-struct-type' function + ;; directly here in the expansion makes this very expensive at compile time + ;; when there are a lot of provide/contract clause using structs + (define -struct:struct-name + (make-pc-struct-type 'struct-name struct:struct-name field-contract-ids ...)) + (provide (rename-out [-struct:struct-name struct:struct-name]))))))))) + + (define (map/count f . ls) + (let loop ([ls ls] + [i 0]) + (cond + [(andmap null? ls) '()] + [(ormap null? ls) (error 'map/count "mismatched lists")] + [else (cons (apply f (append (map car ls) (list i))) + (loop (map cdr ls) + (+ i 1)))]))) + + ;; andmap/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z) + (define (andmap/count f l1) + (let loop ([l1 l1] + [i 0]) + (cond + [(null? l1) #t] + [else (and (f (car l1) i) + (loop (cdr l1) + (+ i 1)))]))) + + ;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number)) + ;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs + (define (get-field-counts/struct-names struct-name provide-stx) + (let loop ([parent-info-id struct-name]) + (let ([parent-info + (and (identifier? parent-info-id) + (lookup-struct-info parent-info-id provide-stx))]) + (cond + [(boolean? parent-info) null] + [else + (let ([fields (list-ref parent-info 3)] + [constructor (list-ref parent-info 1)]) + (cond + [(and (not (null? fields)) + (not (last fields))) + (raise-syntax-error + 'provide/contract + "cannot determine the number of fields in super struct" + provide-stx + struct-name)] + [else + (cons (cons (length fields) (constructor->struct-name provide-stx constructor)) + (loop (list-ref parent-info 5)))]))])))) + + (define (constructor->struct-name orig-stx stx) + (and stx + (let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))]) + (cond + [m (cadr m)] + [else (raise-syntax-error 'contract.ss + "unable to cope with a struct maker whose name doesn't begin with `make-'" + orig-stx)])))) + + ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax + (define (build-constructor-contract stx field-contract-ids predicate-id) + (with-syntax ([(field-contract-ids ...) field-contract-ids] + [predicate-id predicate-id]) + (syntax/loc stx + (-> field-contract-ids ... + predicate-id)))) + + ;; build-selector-contract : syntax syntax -> syntax + ;; constructs the contract for a selector + (define (build-selector-contract struct-name predicate-id field-contract-id) + (with-syntax ([field-contract-id field-contract-id] + [predicate-id predicate-id]) + (syntax (-> predicate-id field-contract-id)))) + + ;; build-mutator-contract : syntax syntax -> syntax + ;; constructs the contract for a selector + (define (build-mutator-contract struct-name predicate-id field-contract-id) + (with-syntax ([field-contract-id field-contract-id] + [predicate-id predicate-id]) + (syntax (-> predicate-id + field-contract-id + void?)))) + + ;; code-for-one-id : syntax syntax syntax (union syntax #f) -> syntax + ;; given the syntax for an identifier and a contract, + ;; builds a begin expression for the entire contract and provide + ;; the first syntax object is used for source locations + (define (code-for-one-id stx id ctrct user-rename-id) + (with-syntax ([(code id) (code-for-one-id/new-name stx id ctrct user-rename-id)]) + (syntax code))) + + ;; code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax) + ;; given the syntax for an identifier and a contract, + ;; builds a begin expression for the entire contract and provide + ;; the first syntax object is used for source locations + (define code-for-one-id/new-name + (case-lambda + [(stx id ctrct user-rename-id) + (code-for-one-id/new-name stx id ctrct user-rename-id #f)] + [(stx id ctrct user-rename-id mangle-for-maker?) + (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)]) + (with-syntax ([id-rename ((if mangle-for-maker? + a:mangle-id-for-maker + a:mangle-id) + provide-stx + "provide/contract-id" + (or user-rename-id id))] + [contract-id (if no-need-to-check-ctrct? + ctrct + (a:mangle-id provide-stx + "provide/contract-contract-id" + (or user-rename-id id)))] + [pos-module-source (a:mangle-id provide-stx + "provide/contract-pos-module-source" + (or user-rename-id id))] + [pos-stx (datum->syntax id 'here)] + [id id] + [ctrct (syntax-property ctrct 'inferred-name id)] + [external-name (or user-rename-id id)] + [where-stx stx]) + (with-syntax ([code + (quasisyntax/loc stx + (begin + (define pos-module-source (module-source-as-symbol #'pos-stx)) + + #,@(if no-need-to-check-ctrct? + (list) + (list #'(define contract-id (verify-contract ctrct)))) + (define-syntax id-rename + (make-provide/contract-transformer (quote-syntax contract-id) + (quote-syntax id) + (quote-syntax pos-module-source))) + + (provide (rename-out [id-rename external-name]))))]) + + (syntax-local-lift-module-end-declaration + #'(begin + (-contract contract-id id pos-module-source 'ignored #'id) + (void))) + + (syntax (code id-rename)))))])) + + (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) + (syntax + (begin + bodies ...))))])) + +(define-syntax (verify-contract stx) + (syntax-case stx () + [(_ x) (a:known-good-contract? #'x) #'x] + [(_ x) #'(verify-contract/proc x)])) + +(define (verify-contract/proc x) + (unless (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1))) + (error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x)) + x) + + +(define (make-pc-struct-type struct-name struct:struct-name . ctcs) + (let-values ([(struct:struct-name _make _pred _get _set) + (make-struct-type struct-name + struct:struct-name + 0 ;; init + 0 ;; auto + #f ;; auto-v + '() ;; props + #f ;; inspector + #f ;; proc-spec + '() ;; immutable-k-list + (λ args + (let ([vals (let loop ([args args]) + (cond + [(null? args) null] + [(null? (cdr args)) null] + [else (cons (car args) (loop (cdr args)))]))]) + (apply values + (map (λ (ctc val) + (-contract ctc + val + 'not-enough-info-for-blame + 'not-enough-info-for-blame)) + ctcs + vals)))))]) + struct:struct-name)) + +(define (test-proc/flat-contract f x) + (if (flat-contract? f) + ((flat-contract-predicate f) x) + (f x))) + +(define (proc/ctc->ctc f) + (if (contract? f) + f + (flat-named-contract + (or (object-name f) + (string->symbol (format "contract:~e" f))) + f))) + +(define-syntax (-contract stx) + (syntax-case stx () + [(_ a-contract to-check pos-blame-e neg-blame-e) + (with-syntax ([src-loc (syntax/loc stx here)]) + (syntax/loc stx + (contract/proc a-contract to-check pos-blame-e neg-blame-e (quote-syntax src-loc))))] + [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) + (syntax/loc stx + (begin + (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))])) + +(define (contract/proc a-contract-raw name pos-blame neg-blame src-info) + (unless (or (contract? a-contract-raw) + (and (procedure? a-contract-raw) + (procedure-arity-includes? a-contract-raw 1))) + (error 'contract "expected a contract or a procedure of arity 1 as first argument, given: ~e, other args ~e ~e ~e ~e" + a-contract-raw + name + pos-blame + neg-blame + src-info)) + (let ([a-contract (if (contract? a-contract-raw) + a-contract-raw + (flat-contract a-contract-raw))]) + (unless (and (symbol? neg-blame) + (symbol? pos-blame)) + (error 'contract + "expected symbols as names for assigning blame, given: ~e and ~e, other args ~e ~e ~e" + neg-blame pos-blame + a-contract-raw + name + src-info)) + (unless (syntax? src-info) + (error 'contract "expected syntax as last argument, given: ~e, other args ~e ~e ~e ~e" + src-info + neg-blame + pos-blame + a-contract-raw + name)) + (((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract)) + name))) + +(define-syntax (recursive-contract stx) + (syntax-case stx () + [(_ arg) + (syntax (make-proj-contract + '(recursive-contract arg) + (λ (pos-blame neg-blame src str) + (let ([proc (contract-proc arg)]) + (λ (val) + ((proc pos-blame neg-blame src str) val)))) + #f))])) + +(define (check-contract ctc) + (unless (contract? ctc) + (error 'recursive-contract "expected a contract, got ~e" ctc)) + ctc) + - ; ; ; @@ -816,1167 +815,1166 @@ improve method arity mismatch contract violation error messages? ; ; - - - (provide flat-rec-contract - flat-murec-contract - or/c union - not/c - =/c >=/c <=/c /c between/c - integer-in - real-in - natural-number/c - string/len - false/c - printable/c - symbols one-of/c - listof cons/c list/c - vectorof vector-immutableof vector/c vector-immutable/c - box-immutable/c box/c - promise/c - struct/c - syntax/c - - check-between/c - check-unary-between/c - parameter/c) - - (define-syntax (flat-rec-contract stx) - (syntax-case stx () - [(_ name ctc ...) - (identifier? (syntax name)) - (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))] - [(pred-id ...) (generate-temporaries (syntax (ctc ...)))]) - (syntax - (let* ([pred (λ (x) (error 'flat-rec-contract "applied too soon"))] - [name (flat-contract (let ([name (λ (x) (pred x))]) name))]) - (let ([ctc-id (coerce-contract 'flat-rec-contract ctc)] ...) + + +(provide flat-rec-contract + flat-murec-contract + or/c union + not/c + =/c >=/c <=/c /c between/c + integer-in + real-in + natural-number/c + string/len + false/c + printable/c + symbols one-of/c + listof cons/c list/c + vectorof vector-immutableof vector/c vector-immutable/c + box-immutable/c box/c + promise/c + struct/c + syntax/c + + check-between/c + check-unary-between/c + parameter/c) + +(define-syntax (flat-rec-contract stx) + (syntax-case stx () + [(_ name ctc ...) + (identifier? (syntax name)) + (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))] + [(pred-id ...) (generate-temporaries (syntax (ctc ...)))]) + (syntax + (let* ([pred (λ (x) (error 'flat-rec-contract "applied too soon"))] + [name (flat-contract (let ([name (λ (x) (pred x))]) name))]) + (let ([ctc-id (coerce-contract 'flat-rec-contract ctc)] ...) + (unless (flat-contract? ctc-id) + (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) + ... + (set! pred + (let ([pred-id (flat-contract-predicate ctc-id)] ...) + (λ (x) + (or (pred-id x) ...)))) + name))))] + [(_ name ctc ...) + (raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))])) + +(define-syntax (flat-murec-contract stx) + (syntax-case stx () + [(_ ([name ctc ...] ...) body1 body ...) + (andmap identifier? (syntax->list (syntax (name ...)))) + (with-syntax ([((ctc-id ...) ...) (map generate-temporaries + (syntax->list (syntax ((ctc ...) ...))))] + [(pred-id ...) (generate-temporaries (syntax (name ...)))] + [((pred-arm-id ...) ...) (map generate-temporaries + (syntax->list (syntax ((ctc ...) ...))))]) + (syntax + (let* ([pred-id (λ (x) (error 'flat-murec-contract "applied too soon"))] ... + [name (flat-contract (let ([name (λ (x) (pred-id x))]) name))] ...) + (let-values ([(ctc-id ...) (values (coerce-contract 'flat-rec-contract ctc) ...)] ...) + (begin + (void) (unless (flat-contract? ctc-id) (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) - ... - (set! pred - (let ([pred-id (flat-contract-predicate ctc-id)] ...) - (λ (x) - (or (pred-id x) ...)))) - name))))] - [(_ name ctc ...) - (raise-syntax-error 'flat-rec-contract "expected first argument to be an identifier" stx (syntax name))])) + ...) ... + (set! pred-id + (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...) + (λ (x) + (or (pred-arm-id x) ...)))) ... + body1 + body ...))))] + [(_ ([name ctc ...] ...) body1 body ...) + (for-each (λ (name) + (unless (identifier? name) + (raise-syntax-error 'flat-rec-contract + "expected an identifier" stx name))) + (syntax->list (syntax (name ...))))] + [(_ ([name ctc ...] ...)) + (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)])) - (define-syntax (flat-murec-contract stx) - (syntax-case stx () - [(_ ([name ctc ...] ...) body1 body ...) - (andmap identifier? (syntax->list (syntax (name ...)))) - (with-syntax ([((ctc-id ...) ...) (map generate-temporaries - (syntax->list (syntax ((ctc ...) ...))))] - [(pred-id ...) (generate-temporaries (syntax (name ...)))] - [((pred-arm-id ...) ...) (map generate-temporaries - (syntax->list (syntax ((ctc ...) ...))))]) - (syntax - (let* ([pred-id (λ (x) (error 'flat-murec-contract "applied too soon"))] ... - [name (flat-contract (let ([name (λ (x) (pred-id x))]) name))] ...) - (let-values ([(ctc-id ...) (values (coerce-contract 'flat-rec-contract ctc) ...)] ...) - (begin - (void) - (unless (flat-contract? ctc-id) - (error 'flat-rec-contract "expected flat contracts as arguments, got ~e" ctc-id)) - ...) ... - (set! pred-id - (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...) - (λ (x) - (or (pred-arm-id x) ...)))) ... - body1 - body ...))))] - [(_ ([name ctc ...] ...) body1 body ...) - (for-each (λ (name) - (unless (identifier? name) - (raise-syntax-error 'flat-rec-contract - "expected an identifier" stx name))) - (syntax->list (syntax (name ...))))] - [(_ ([name ctc ...] ...)) - (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)])) - - (define-syntax (union stx) - (begin -#; - (fprintf (current-error-port) - "WARNING: union is deprecated, use or/c (file ~a~a)\n" - (let ([file (syntax-source stx)]) - (if (path? file) - (path->string file) - (format "~s" file))) - (let ([line (syntax-line stx)]) - (if (number? line) - (format ", line ~a" line) - ""))) - (syntax-case stx () - [(_ args ...) (syntax (or/c args ...))] - [id (syntax or/c)]))) - - (define or/c - (case-lambda - [() (make-none/c '(or/c))] - [args - (for-each - (λ (x) - (unless (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1))) - (error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x))) - args) - (let-values ([(ho-contracts fc/predicates) - (let loop ([ho-contracts '()] - [fc/predicates null] - [args args]) - (cond - [(null? args) (values ho-contracts (reverse fc/predicates))] - [else - (let ([arg (car args)]) - (cond - [(and (contract? arg) - (not (flat-contract? arg))) - (loop (cons arg ho-contracts) fc/predicates (cdr args))] - [else - (loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))]) - (let ([flat-contracts (map (λ (x) (if (flat-contract? x) - x - (flat-contract x))) - fc/predicates)] - [pred - (cond - [(null? fc/predicates) not] - [else - (let loop ([fst (car fc/predicates)] - [rst (cdr fc/predicates)]) - (let ([fst-pred (if (flat-contract? fst) - ((flat-get fst) fst) - fst)]) - (cond - [(null? rst) fst-pred] - [else - (let ([r (loop (car rst) (cdr rst))]) - (λ (x) (or (fst-pred x) (r x))))])))])]) - (cond - [(null? ho-contracts) - (make-flat-or/c pred flat-contracts)] - [(null? (cdr ho-contracts)) - (make-or/c pred flat-contracts (car ho-contracts))] - [else - (make-multi-or/c flat-contracts ho-contracts)])))])) +(define-syntax (union stx) + (begin + #; + (fprintf (current-error-port) + "WARNING: union is deprecated, use or/c (file ~a~a)\n" + (let ([file (syntax-source stx)]) + (if (path? file) + (path->string file) + (format "~s" file))) + (let ([line (syntax-line stx)]) + (if (number? line) + (format ", line ~a" line) + ""))) + (syntax-case stx () + [(_ args ...) (syntax (or/c args ...))] + [id (syntax or/c)]))) - (define-struct/prop or/c (pred flat-ctcs ho-ctc) - ((proj-prop (λ (ctc) - (let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))] - [pred (or/c-pred ctc)]) - (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)]) - (λ (val) +(define or/c + (case-lambda + [() (make-none/c '(or/c))] + [args + (for-each + (λ (x) + (unless (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1))) + (error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x))) + args) + (let-values ([(ho-contracts fc/predicates) + (let loop ([ho-contracts '()] + [fc/predicates null] + [args args]) + (cond + [(null? args) (values ho-contracts (reverse fc/predicates))] + [else + (let ([arg (car args)]) (cond - [(pred val) val] + [(and (contract? arg) + (not (flat-contract? arg))) + (loop (cons arg ho-contracts) fc/predicates (cdr args))] [else - (partial-contract val)]))))))) - - (name-prop (λ (ctc) - (apply build-compound-type-name - 'or/c - (or/c-ho-ctc ctc) - (or/c-flat-ctcs ctc)))) - (first-order-prop - (λ (ctc) - (let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))] - [ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]) - (λ (x) - (or (ho x) - (ormap (λ (f) (f x)) flats)))))) - - (stronger-prop - (λ (this that) - (and (or/c? that) - (contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that)) - (let ([this-ctcs (or/c-flat-ctcs this)] - [that-ctcs (or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))))))) - - (define (multi-or/c-proj ctc) - (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)] - [c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)] - [first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)] - [predicates (map (λ (x) ((flat-get x) x)) - (multi-or/c-flat-ctcs ctc))]) - (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str)) c-procs)]) - (λ (val) - (cond - [(ormap (λ (pred) (pred val)) predicates) - val] - [else - (let loop ([checks first-order-checks] - [procs partial-contracts] - [contracts ho-contracts] - [candidate-proc #f] - [candidate-contract #f]) - (cond - [(null? checks) - (if candidate-proc - (candidate-proc val) - (raise-contract-error val src-info pos-blame orig-str - "none of the branches of the or/c matched"))] - [((car checks) val) - (if candidate-proc - (error 'or/c "two arguments, ~s and ~s, might both match ~s" - (contract-name candidate-contract) - (contract-name (car contracts)) - val) - (loop (cdr checks) - (cdr procs) - (cdr contracts) - (car procs) - (car contracts)))] - [else - (loop (cdr checks) - (cdr procs) - (cdr contracts) - candidate-proc - candidate-contract)]))])))))) - - (define-struct/prop multi-or/c (flat-ctcs ho-ctcs) - ((proj-prop multi-or/c-proj) - (name-prop (λ (ctc) - (apply build-compound-type-name - 'or/c - (append - (multi-or/c-flat-ctcs ctc) - (reverse (multi-or/c-ho-ctcs ctc)))))) - (first-order-prop - (λ (ctc) - (let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))] - [hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))]) - (λ (x) - (or (ormap (λ (f) (f x)) hos) - (ormap (λ (f) (f x)) flats)))))) - - (stronger-prop - (λ (this that) - (and (multi-or/c? that) - (let ([this-ctcs (multi-or/c-ho-ctcs this)] - [that-ctcs (multi-or/c-ho-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs))) - (let ([this-ctcs (multi-or/c-flat-ctcs this)] - [that-ctcs (multi-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))))))) - - (define-struct/prop flat-or/c (pred flat-ctcs) - ((proj-prop flat-proj) - (name-prop (λ (ctc) - (apply build-compound-type-name - 'or/c - (flat-or/c-flat-ctcs ctc)))) - (stronger-prop - (λ (this that) - (and (flat-or/c? that) - (let ([this-ctcs (flat-or/c-flat-ctcs this)] - [that-ctcs (flat-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))))) - (flat-prop (λ (ctc) (flat-or/c-pred ctc))))) - - ;; - ;; or/c opter - ;; - (define/opter (or/c opt/i opt/info stx) - ;; FIXME code duplication - (define (opt/or-unknown uctc) - (let* ((lift-var (car (generate-temporaries (syntax (lift))))) - (partial-var (car (generate-temporaries (syntax (partial)))))) - (values - (with-syntax ((partial-var partial-var) - (lift-var lift-var) - (uctc uctc) - (val (opt/info-val opt/info))) - (syntax (partial-var val))) - (list (cons lift-var - ;; FIXME needs to get the contract name somehow - (with-syntax ((uctc uctc)) - (syntax (coerce-contract 'opt/c uctc))))) - null - (list (cons - partial-var - (with-syntax ((lift-var lift-var) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info))) - (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))) - #f - lift-var - (list #f) - null))) + (loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))]) + (let ([flat-contracts (map (λ (x) (if (flat-contract? x) + x + (flat-contract x))) + fc/predicates)] + [pred + (cond + [(null? fc/predicates) not] + [else + (let loop ([fst (car fc/predicates)] + [rst (cdr fc/predicates)]) + (let ([fst-pred (if (flat-contract? fst) + ((flat-get fst) fst) + fst)]) + (cond + [(null? rst) fst-pred] + [else + (let ([r (loop (car rst) (cdr rst))]) + (λ (x) (or (fst-pred x) (r x))))])))])]) + (cond + [(null? ho-contracts) + (make-flat-or/c pred flat-contracts)] + [(null? (cdr ho-contracts)) + (make-or/c pred flat-contracts (car ho-contracts))] + [else + (make-multi-or/c flat-contracts ho-contracts)])))])) - (define (opt/or-ctc ps) - (let ((lift-from-hos null) - (superlift-from-hos null) - (partial-from-hos null)) - (let-values ([(opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc) - (let loop ([ps ps] - [next-ps null] - [lift-ps null] - [superlift-ps null] - [partial-ps null] - [stronger-ribs null] - [hos null] - [ho-ctc #f]) +(define-struct/prop or/c (pred flat-ctcs ho-ctc) + ((proj-prop (λ (ctc) + (let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))] + [pred (or/c-pred ctc)]) + (λ (pos-blame neg-blame src-info orig-str) + (let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)]) + (λ (val) (cond - [(null? ps) (values next-ps - lift-ps - superlift-ps - partial-ps - stronger-ribs - (reverse hos) - ho-ctc)] + [(pred val) val] [else - (let-values ([(next lift superlift partial flat _ this-stronger-ribs) - (opt/i opt/info (car ps))]) - (if flat - (loop (cdr ps) - (cons flat next-ps) - (append lift-ps lift) - (append superlift-ps superlift) - (append partial-ps partial) - (append this-stronger-ribs stronger-ribs) - hos - ho-ctc) - (if (< (length hos) 1) - (loop (cdr ps) - next-ps - (append lift-ps lift) - (append superlift-ps superlift) - (append partial-ps partial) - (append this-stronger-ribs stronger-ribs) - (cons (car ps) hos) - next) - (loop (cdr ps) - next-ps - lift-ps - superlift-ps - partial-ps - stronger-ribs - (cons (car ps) hos) - ho-ctc))))]))]) - (with-syntax ((next-ps - (with-syntax (((opt-p ...) (reverse opt-ps))) - (syntax (or opt-p ...))))) - (values - (cond - [(null? hos) - (with-syntax ([val (opt/info-val opt/info)] - [pos (opt/info-pos opt/info)] - [src-info (opt/info-src-info opt/info)] - [orig-str (opt/info-orig-str opt/info)]) - (syntax - (if next-ps - val - (raise-contract-error val src-info pos orig-str - "none of the branches of the or/c matched"))))] - [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc)) - (syntax - (if next-ps val ho-ctc)))] - ;; FIXME something's not right with this case. - [(> (length hos) 1) - (let-values ([(next-hos lift-hos superlift-hos partial-hos _ __ stronger-hos stronger-vars-hos) - (opt/or-unknown stx)]) - (set! lift-from-hos lift-hos) - (set! superlift-from-hos superlift-hos) - (set! partial-from-hos partial-hos) - (with-syntax ((next-hos next-hos)) - (syntax - (if next-ps val next-hos))))]) - (append lift-ps lift-from-hos) - (append superlift-ps superlift-from-hos) - (append partial-ps partial-from-hos) - (if (null? hos) (syntax next-ps) #f) - #f - stronger-ribs))))) - - (syntax-case stx (or/c) - [(or/c p ...) - (opt/or-ctc (syntax->list (syntax (p ...))))])) - - (define false/c - (flat-named-contract - 'false/c - (λ (x) (not x)))) - - (define (string/len n) - (unless (number? n) - (error 'string/len "expected a number as argument, got ~e" n)) - (flat-named-contract - `(string/len ,n) - (λ (x) - (and (string? x) - ((string-length x) . < . n))))) - - (define (symbols . ss) - (unless ((length ss) . >= . 1) - (error 'symbols "expected at least one argument")) - (unless (andmap symbol? ss) - (error 'symbols "expected symbols as arguments, given: ~a" - (apply string-append (map (λ (x) (format "~e " x)) ss)))) - (make-one-of/c ss)) - - (define atomic-value? - (let ([undefined (letrec ([x x]) x)]) - (λ (x) - (or (char? x) (symbol? x) (boolean? x) - (null? x) (keyword? x) (number? x) - (void? x) (eq? x undefined))))) - - (define (one-of/c . elems) - (unless (andmap atomic-value? elems) - (error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e" - elems)) - (make-one-of/c elems)) + (partial-contract val)]))))))) + + (name-prop (λ (ctc) + (apply build-compound-type-name + 'or/c + (or/c-ho-ctc ctc) + (or/c-flat-ctcs ctc)))) + (first-order-prop + (λ (ctc) + (let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs ctc))] + [ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]) + (λ (x) + (or (ho x) + (ormap (λ (f) (f x)) flats)))))) + + (stronger-prop + (λ (this that) + (and (or/c? that) + (contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that)) + (let ([this-ctcs (or/c-flat-ctcs this)] + [that-ctcs (or/c-flat-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs)))))))) - (define (one-of-pc x) - (cond - [(symbol? x) - `',x] - [(null? x) - ''()] - [(void? x) - '(void)] - [(or (char? x) - (boolean? x) - (keyword? x) - (number? x)) - x] - [(eq? x (letrec ([x x]) x)) - '(letrec ([x x]) x)] - [else (error 'one-of-pc "undef ~s" x)])) - - - (define-struct/prop one-of/c (elems) - ((proj-prop flat-proj) - (name-prop (λ (ctc) - (let ([elems (one-of/c-elems ctc)]) - `(,(cond - [(andmap symbol? elems) - 'symbols] - [else - 'one-of/c]) - ,@(map one-of-pc elems))))) - (stronger-prop - (λ (this that) - (and (one-of/c? that) - (let ([this-elems (one-of/c-elems this)] - [that-elems (one-of/c-elems that)]) - (and - (andmap (λ (this-elem) (memv this-elem that-elems)) - this-elems) - #t))))) - (flat-prop - (λ (ctc) - (let ([elems (one-of/c-elems ctc)]) - (λ (x) (memv x elems))))))) - - (define printable/c - (flat-named-contract - 'printable/c - (λ (x) - (let printable? ([x x]) - (or (symbol? x) - (string? x) - (bytes? x) - (boolean? x) - (char? x) - (null? x) - (number? x) - (regexp? x) - (and (pair? x) - (printable? (car x)) - (printable? (cdr x))) - (and (vector? x) - (andmap printable? (vector->list x))) - (and (box? x) - (printable? (unbox x)))))))) - - (define-struct/prop between/c (low high) - ((proj-prop flat-proj) - (name-prop (λ (ctc) - (let ([n (between/c-low ctc)] - [m (between/c-high ctc)]) - (cond - [(= n -inf.0) `(<=/c ,m)] - [(= m +inf.0) `(>=/c ,n)] - [(= n m) `(=/c ,n)] - [else `(between/c ,n ,m)])))) - (stronger-prop - (λ (this that) - (and (between/c? that) - (<= (between/c-low that) (between/c-low this)) - (<= (between/c-high this) (between/c-high that))))) - (flat-prop (λ (ctc) - (let ([n (between/c-low ctc)] - [m (between/c-high ctc)]) - (λ (x) - (and (number? x) - (<= n x m)))))))) - - (define-syntax (check-unary-between/c stx) - (syntax-case stx () - [(_ 'sym x-exp) - (identifier? #'sym) - #'(let ([x x-exp]) - (unless (real? x) - (error 'sym "expected a real number, got ~e" x)))])) - - (define (=/c x) - (check-unary-between/c '=/c x) - (make-between/c x x)) - (define (<=/c x) - (check-unary-between/c '<=/c x) - (make-between/c -inf.0 x)) - (define (>=/c x) - (check-unary-between/c '>=/c x) - (make-between/c x +inf.0)) - (define (check-between/c x y) - (unless (number? x) - (error 'between/c "expected a number as first argument, got ~e, other arg ~e" x y)) - (unless (number? y) - (error 'between/c "expected a number as second argument, got ~e, other arg ~e" y x))) - (define (between/c x y) - (check-between/c x y) - (make-between/c x y)) - - ;; - ;; between/c opter helper - ;; - - - - ;; - ;; between/c opters - ;; - ;; note that the checkers are used by both optimized and normal contracts. - ;; - (define/opter (between/c opt/i opt/info stx) - (syntax-case stx (between/c) - [(between/c low high) - (let*-values ([(lift-low lifts1) (lift/binding #'low 'between-low empty-lifts)] - [(lift-high lifts2) (lift/binding #'high 'between-high lifts1)]) - (with-syntax ([n lift-low] - [m lift-high]) - (let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)]) - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (this (opt/info-this opt/info)) - (that (opt/info-that opt/info))) - (values - (syntax (if (and (number? val) (<= n val m)) - val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val))) - lifts3 - null - null - (syntax (and (number? val) (<= n val m))) - #f - (list (new-stronger-var - lift-low - (λ (this that) - (with-syntax ([this this] - [that that]) - (syntax (<= that this))))) - (new-stronger-var - lift-high - (λ (this that) - (with-syntax ([this this] - [that that]) - (syntax (<= this that)))))))))))])) - - (define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg) - (with-syntax ([comparison comparison]) - (let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)]) - (with-syntax ([m lift-low]) - (let ([lifts3 (lift/effect (check-arg #'m) lifts2)]) - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (this (opt/info-this opt/info)) - (that (opt/info-that opt/info))) - (values - (syntax - (if (and (number? val) (comparison val m)) - val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val))) - lifts3 - null - null - (syntax (and (number? val) (comparison val m))) - #f - (list (new-stronger-var - lift-low - (λ (this that) - (with-syntax ([this this] - [that that]) - (syntax (comparison this that))))))))))))) - - (define/opter (>=/c opt/i opt/info stx) - (syntax-case stx (>=/c) - [(>=/c low) - (single-comparison-opter - opt/info - stx - (λ (m) (with-syntax ([m m]) - #'(check-unary-between/c '>=/c m))) - #'>= - #'low)])) - - (define/opter (<=/c opt/i opt/info stx) - (syntax-case stx (<=/c) - [(<=/c high) - (single-comparison-opter - opt/info - stx - (λ (m) (with-syntax ([m m]) - #'(check-unary-between/c '<=/c m))) - #'<= - #'high)])) - - (define/opter (>/c opt/i opt/info stx) - (syntax-case stx (>/c) - [(>/c low) - (single-comparison-opter - opt/info - stx - (λ (m) (with-syntax ([m m]) - #'(check-unary-between/c '>/c m))) - #'> - #'low)])) - - (define/opter (/c x) - (flat-named-contract - `(>/c ,x) - (λ (y) (and (number? y) (> y x))))) - - (define natural-number/c - (flat-named-contract - 'natural-number/c - (λ (x) - (and (number? x) - (integer? x) - (x . >= . 0))))) - - (define (integer-in start end) - (unless (and (integer? start) - (exact? start) - (integer? end) - (exact? end)) - (error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end)) - (flat-named-contract - `(integer-in ,start ,end) - (λ (x) - (and (integer? x) - (exact? x) - (<= start x end))))) - - (define (real-in start end) - (unless (and (real? start) - (real? end)) - (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end)) - (flat-named-contract - `(real-in ,start ,end) - (λ (x) - (and (real? x) - (<= start x end))))) - - (define (not/c f) - (unless (flat-contract/predicate? f) - (error 'not/c "expected a procedure of arity 1 or , given: ~e" f)) - (build-flat-contract - (build-compound-type-name 'not/c (proc/ctc->ctc f)) - (λ (x) (not (test-proc/flat-contract f x))))) - - (define-syntax (*-immutableof stx) - (syntax-case stx () - [(_ predicate? fill testmap type-name name) - (identifier? (syntax predicate?)) - (syntax - (let ([fill-name fill]) - (λ (input) - (let ([ctc (coerce-contract 'name input)]) - (if (flat-contract? ctc) - (let ([content-pred? (flat-contract-predicate ctc)]) - (build-flat-contract - `(listof ,(contract-name ctc)) - (lambda (x) (and (predicate? x) (testmap content-pred? x))))) - (let ([proj (contract-proc ctc)]) - (make-proj-contract - (build-compound-type-name 'name ctc) - (λ (pos-blame neg-blame src-info orig-str) - (let ([p-app (proj pos-blame neg-blame src-info orig-str)]) - (λ (val) - (unless (predicate? val) - (raise-contract-error - val - src-info - pos-blame - orig-str - "expected <~a>, given: ~e" - 'type-name - val)) - (fill-name p-app val)))) - predicate?)))))))])) - - (define listof - (*-immutableof list? map andmap list listof)) - - (define (immutable-vector? val) (and (immutable? val) (vector? val))) - - (define vector-immutableof - (*-immutableof immutable-vector? - (λ (f v) (apply vector-immutable (map f (vector->list v)))) - (λ (f v) (andmap f (vector->list v))) - immutable-vector - vector-immutableof)) - - (define (vectorof p) - (unless (flat-contract/predicate? p) - (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) - (build-flat-contract - (build-compound-type-name 'vectorof (proc/ctc->ctc p)) - (λ (v) - (and (vector? v) - (andmap (λ (ele) (test-proc/flat-contract p ele)) - (vector->list v)))))) - - (define (vector/c . args) - (unless (andmap flat-contract/predicate? args) - (error 'vector/c "expected flat contracts as arguments, got: ~a" - (let loop ([args args]) +(define (multi-or/c-proj ctc) + (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)] + [c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)] + [first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)] + [predicates (map (λ (x) ((flat-get x) x)) + (multi-or/c-flat-ctcs ctc))]) + (λ (pos-blame neg-blame src-info orig-str) + (let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str)) c-procs)]) + (λ (val) + (cond + [(ormap (λ (pred) (pred val)) predicates) + val] + [else + (let loop ([checks first-order-checks] + [procs partial-contracts] + [contracts ho-contracts] + [candidate-proc #f] + [candidate-contract #f]) (cond - [(null? args) ""] - [(null? (cdr args)) (format "~e" (car args))] - [else (string-append - (format "~e " (car args)) - (loop (cdr args)))])))) - (let ([largs (length args)]) - (build-flat-contract - (apply build-compound-type-name 'vector/c (map proc/ctc->ctc args)) - (λ (v) - (and (vector? v) - (= (vector-length v) largs) - (andmap test-proc/flat-contract - args - (vector->list v))))))) + [(null? checks) + (if candidate-proc + (candidate-proc val) + (raise-contract-error val src-info pos-blame orig-str + "none of the branches of the or/c matched"))] + [((car checks) val) + (if candidate-proc + (error 'or/c "two arguments, ~s and ~s, might both match ~s" + (contract-name candidate-contract) + (contract-name (car contracts)) + val) + (loop (cdr checks) + (cdr procs) + (cdr contracts) + (car procs) + (car contracts)))] + [else + (loop (cdr checks) + (cdr procs) + (cdr contracts) + candidate-proc + candidate-contract)]))])))))) + +(define-struct/prop multi-or/c (flat-ctcs ho-ctcs) + ((proj-prop multi-or/c-proj) + (name-prop (λ (ctc) + (apply build-compound-type-name + 'or/c + (append + (multi-or/c-flat-ctcs ctc) + (reverse (multi-or/c-ho-ctcs ctc)))))) + (first-order-prop + (λ (ctc) + (let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))] + [hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))]) + (λ (x) + (or (ormap (λ (f) (f x)) hos) + (ormap (λ (f) (f x)) flats)))))) + + (stronger-prop + (λ (this that) + (and (multi-or/c? that) + (let ([this-ctcs (multi-or/c-ho-ctcs this)] + [that-ctcs (multi-or/c-ho-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs))) + (let ([this-ctcs (multi-or/c-flat-ctcs this)] + [that-ctcs (multi-or/c-flat-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs)))))))) + +(define-struct/prop flat-or/c (pred flat-ctcs) + ((proj-prop flat-proj) + (name-prop (λ (ctc) + (apply build-compound-type-name + 'or/c + (flat-or/c-flat-ctcs ctc)))) + (stronger-prop + (λ (this that) + (and (flat-or/c? that) + (let ([this-ctcs (flat-or/c-flat-ctcs this)] + [that-ctcs (flat-or/c-flat-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs)))))) + (flat-prop (λ (ctc) (flat-or/c-pred ctc))))) + +;; +;; or/c opter +;; +(define/opter (or/c opt/i opt/info stx) + ;; FIXME code duplication + (define (opt/or-unknown uctc) + (let* ((lift-var (car (generate-temporaries (syntax (lift))))) + (partial-var (car (generate-temporaries (syntax (partial)))))) + (values + (with-syntax ((partial-var partial-var) + (lift-var lift-var) + (uctc uctc) + (val (opt/info-val opt/info))) + (syntax (partial-var val))) + (list (cons lift-var + ;; FIXME needs to get the contract name somehow + (with-syntax ((uctc uctc)) + (syntax (coerce-contract 'opt/c uctc))))) + null + (list (cons + partial-var + (with-syntax ((lift-var lift-var) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str))))) + #f + lift-var + (list #f) + null))) - (define (box/c pred) - (unless (flat-contract/predicate? pred) - (error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred)) - (build-flat-contract - (build-compound-type-name 'box/c (proc/ctc->ctc pred)) - (λ (x) - (and (box? x) - (test-proc/flat-contract pred (unbox x)))))) - - ;; - ;; cons/c opter - ;; - (define/opter (cons/c opt/i opt/info stx) - (define (opt/cons-ctc hdp tlp) - (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd) - (opt/i opt/info hdp)] - [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl) - (opt/i opt/info tlp)] - [(error-check) (car (generate-temporaries (syntax (error-check))))]) - (with-syntax ((next (with-syntax ((flat-hdp flat-hdp) - (flat-tlp flat-tlp) - (val (opt/info-val opt/info))) - (syntax - (and (pair? val) - (let ((val (car val))) flat-hdp) - (let ((val (cdr val))) flat-tlp)))))) + (define (opt/or-ctc ps) + (let ((lift-from-hos null) + (superlift-from-hos null) + (partial-from-hos null)) + (let-values ([(opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc) + (let loop ([ps ps] + [next-ps null] + [lift-ps null] + [superlift-ps null] + [partial-ps null] + [stronger-ribs null] + [hos null] + [ho-ctc #f]) + (cond + [(null? ps) (values next-ps + lift-ps + superlift-ps + partial-ps + stronger-ribs + (reverse hos) + ho-ctc)] + [else + (let-values ([(next lift superlift partial flat _ this-stronger-ribs) + (opt/i opt/info (car ps))]) + (if flat + (loop (cdr ps) + (cons flat next-ps) + (append lift-ps lift) + (append superlift-ps superlift) + (append partial-ps partial) + (append this-stronger-ribs stronger-ribs) + hos + ho-ctc) + (if (< (length hos) 1) + (loop (cdr ps) + next-ps + (append lift-ps lift) + (append superlift-ps superlift) + (append partial-ps partial) + (append this-stronger-ribs stronger-ribs) + (cons (car ps) hos) + next) + (loop (cdr ps) + next-ps + lift-ps + superlift-ps + partial-ps + stronger-ribs + (cons (car ps) hos) + ho-ctc))))]))]) + (with-syntax ((next-ps + (with-syntax (((opt-p ...) (reverse opt-ps))) + (syntax (or opt-p ...))))) (values - (with-syntax ((val (opt/info-val opt/info)) - (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info))) - (syntax (if next - val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val)))) - (append - lifts-hdp lifts-tlp - (list (cons error-check - (with-syntax ((hdp hdp) - (tlp tlp) - (check (with-syntax ((flat-hdp - (cond - [unknown-hdp - (with-syntax ((ctc unknown-hdp)) - (syntax (flat-contract/predicate? ctc)))] - [else (if flat-hdp #'#t #'#f)])) - (flat-tlp - (cond - [unknown-tlp - (with-syntax ((ctc unknown-tlp)) - (syntax (flat-contract/predicate? ctc)))] - [else (if flat-tlp #'#t #'#f)]))) - (syntax (and flat-hdp flat-tlp))))) - (syntax - (unless check - (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" - hdp tlp))))))) - (append superlifts-hdp superlifts-tlp) - (append partials-hdp partials-tlp) - (syntax (if next #t #f)) + (cond + [(null? hos) + (with-syntax ([val (opt/info-val opt/info)] + [pos (opt/info-pos opt/info)] + [src-info (opt/info-src-info opt/info)] + [orig-str (opt/info-orig-str opt/info)]) + (syntax + (if next-ps + val + (raise-contract-error val src-info pos orig-str + "none of the branches of the or/c matched"))))] + [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc)) + (syntax + (if next-ps val ho-ctc)))] + ;; FIXME something's not right with this case. + [(> (length hos) 1) + (let-values ([(next-hos lift-hos superlift-hos partial-hos _ __ stronger-hos stronger-vars-hos) + (opt/or-unknown stx)]) + (set! lift-from-hos lift-hos) + (set! superlift-from-hos superlift-hos) + (set! partial-from-hos partial-hos) + (with-syntax ((next-hos next-hos)) + (syntax + (if next-ps val next-hos))))]) + (append lift-ps lift-from-hos) + (append superlift-ps superlift-from-hos) + (append partial-ps partial-from-hos) + (if (null? hos) (syntax next-ps) #f) #f - (append stronger-ribs-hd stronger-ribs-tl))))) - - (syntax-case stx (cons/c) - [(cons/c hdp tlp) - (opt/cons-ctc #'hdp #'tlp)])) + stronger-ribs))))) - (define-syntax (*-immutable/c stx) - (syntax-case stx () - [(_ predicate? constructor (arb? selectors ...) type-name name) - #'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)] - [(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?) - (and (eq? #f (syntax-object->datum (syntax arb?))) - (boolean? (syntax-object->datum #'test-immutable?))) - (let ([test-immutable? (syntax-object->datum #'test-immutable?)]) - (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] - [(p-apps ...) (generate-temporaries (syntax (selectors ...)))] - [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))] - [(procs ...) (generate-temporaries (syntax (selectors ...)))] - [(selector-names ...) (generate-temporaries (syntax (selectors ...)))]) - #`(let ([predicate?-name predicate?] - [constructor-name constructor] - [selector-names selectors] ...) - (λ (params ...) - (let ([ctc-x (coerce-contract 'name params)] ...) - (if (and (flat-contract? ctc-x) ...) - (let ([p-apps (flat-contract-predicate ctc-x)] ...) - (build-flat-contract - `(name ,(contract-name ctc-x) ...) - (lambda (x) - (and (predicate?-name x) - (p-apps (selector-names x)) - ...)))) - (let ([procs (contract-proc ctc-x)] ...) - (make-proj-contract - (build-compound-type-name 'name (proc/ctc->ctc params) ...) - (λ (pos-blame neg-blame src-info orig-str) - (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...) - (λ (v) - (if #,(if test-immutable? - #'(and (predicate?-name v) - (immutable? v)) - #'(predicate?-name v)) - (constructor-name (p-apps (selector-names v)) ...) - (raise-contract-error - v - src-info - pos-blame - orig-str - #,(if test-immutable? - "expected immutable <~a>, given: ~e" - "expected <~a>, given: ~e") - 'type-name - v))))) - #f))))))))] - [(_ predicate? constructor (arb? selector) correct-size type-name name) - (eq? #t (syntax-object->datum (syntax arb?))) - (syntax - (let ([predicate?-name predicate?] - [constructor-name constructor] - [selector-name selector]) - (λ params - (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)]) - (let ([procs (map contract-proc ctcs)]) - (make-proj-contract - (apply build-compound-type-name 'name (map proc/ctc->ctc params)) - (λ (pos-blame neg-blame src-info orig-str) - (let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)] - [count (length params)]) - (λ (v) - (if (and (immutable? v) - (predicate?-name v) - (correct-size count v)) - (apply constructor-name - (let loop ([p-apps p-apps] - [i 0]) - (cond - [(null? p-apps) null] - [else (let ([p-app (car p-apps)]) - (cons (p-app (selector-name v i)) - (loop (cdr p-apps) (+ i 1))))]))) - (raise-contract-error - v - src-info - pos-blame - orig-str - "expected <~a>, given: ~e" - 'type-name - v))))) - #f))))))])) - - (define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f)) - (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) - (define vector-immutable/c (*-immutable/c vector? - vector-immutable - (#t (λ (v i) (vector-ref v i))) - (λ (n v) (= n (vector-length v))) - immutable-vector - vector-immutable/c)) - - ;; - ;; cons/c opter - ;; - (define/opter (cons/c opt/i opt/info stx) - (define (opt/cons-ctc hdp tlp) - (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd) - (opt/i opt/info hdp)] - [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl) - (opt/i opt/info tlp)]) - (with-syntax ((check (with-syntax ((val (opt/info-val opt/info))) - (syntax (pair? val))))) - (values + (syntax-case stx (or/c) + [(or/c p ...) + (opt/or-ctc (syntax->list (syntax (p ...))))])) + +(define false/c + (flat-named-contract + 'false/c + (λ (x) (not x)))) + +(define (string/len n) + (unless (number? n) + (error 'string/len "expected a number as argument, got ~e" n)) + (flat-named-contract + `(string/len ,n) + (λ (x) + (and (string? x) + ((string-length x) . < . n))))) + +(define (symbols . ss) + (unless ((length ss) . >= . 1) + (error 'symbols "expected at least one argument")) + (unless (andmap symbol? ss) + (error 'symbols "expected symbols as arguments, given: ~a" + (apply string-append (map (λ (x) (format "~e " x)) ss)))) + (make-one-of/c ss)) + +(define atomic-value? + (let ([undefined (letrec ([x x]) x)]) + (λ (x) + (or (char? x) (symbol? x) (boolean? x) + (null? x) (keyword? x) (number? x) + (void? x) (eq? x undefined))))) + +(define (one-of/c . elems) + (unless (andmap atomic-value? elems) + (error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e" + elems)) + (make-one-of/c elems)) + +(define (one-of-pc x) + (cond + [(symbol? x) + `',x] + [(null? x) + ''()] + [(void? x) + '(void)] + [(or (char? x) + (boolean? x) + (keyword? x) + (number? x)) + x] + [(eq? x (letrec ([x x]) x)) + '(letrec ([x x]) x)] + [else (error 'one-of-pc "undef ~s" x)])) + + +(define-struct/prop one-of/c (elems) + ((proj-prop flat-proj) + (name-prop (λ (ctc) + (let ([elems (one-of/c-elems ctc)]) + `(,(cond + [(andmap symbol? elems) + 'symbols] + [else + 'one-of/c]) + ,@(map one-of-pc elems))))) + (stronger-prop + (λ (this that) + (and (one-of/c? that) + (let ([this-elems (one-of/c-elems this)] + [that-elems (one-of/c-elems that)]) + (and + (andmap (λ (this-elem) (memv this-elem that-elems)) + this-elems) + #t))))) + (flat-prop + (λ (ctc) + (let ([elems (one-of/c-elems ctc)]) + (λ (x) (memv x elems))))))) + +(define printable/c + (flat-named-contract + 'printable/c + (λ (x) + (let printable? ([x x]) + (or (symbol? x) + (string? x) + (bytes? x) + (boolean? x) + (char? x) + (null? x) + (number? x) + (regexp? x) + (and (pair? x) + (printable? (car x)) + (printable? (cdr x))) + (and (vector? x) + (andmap printable? (vector->list x))) + (and (box? x) + (printable? (unbox x)))))))) + +(define-struct/prop between/c (low high) + ((proj-prop flat-proj) + (name-prop (λ (ctc) + (let ([n (between/c-low ctc)] + [m (between/c-high ctc)]) + (cond + [(= n -inf.0) `(<=/c ,m)] + [(= m +inf.0) `(>=/c ,n)] + [(= n m) `(=/c ,n)] + [else `(between/c ,n ,m)])))) + (stronger-prop + (λ (this that) + (and (between/c? that) + (<= (between/c-low that) (between/c-low this)) + (<= (between/c-high this) (between/c-high that))))) + (flat-prop (λ (ctc) + (let ([n (between/c-low ctc)] + [m (between/c-high ctc)]) + (λ (x) + (and (number? x) + (<= n x m)))))))) + +(define-syntax (check-unary-between/c stx) + (syntax-case stx () + [(_ 'sym x-exp) + (identifier? #'sym) + #'(let ([x x-exp]) + (unless (real? x) + (error 'sym "expected a real number, got ~e" x)))])) + +(define (=/c x) + (check-unary-between/c '=/c x) + (make-between/c x x)) +(define (<=/c x) + (check-unary-between/c '<=/c x) + (make-between/c -inf.0 x)) +(define (>=/c x) + (check-unary-between/c '>=/c x) + (make-between/c x +inf.0)) +(define (check-between/c x y) + (unless (number? x) + (error 'between/c "expected a number as first argument, got ~e, other arg ~e" x y)) + (unless (number? y) + (error 'between/c "expected a number as second argument, got ~e, other arg ~e" y x))) +(define (between/c x y) + (check-between/c x y) + (make-between/c x y)) + +;; +;; between/c opter helper +;; + + + +;; +;; between/c opters +;; +;; note that the checkers are used by both optimized and normal contracts. +;; +(define/opter (between/c opt/i opt/info stx) + (syntax-case stx (between/c) + [(between/c low high) + (let*-values ([(lift-low lifts1) (lift/binding #'low 'between-low empty-lifts)] + [(lift-high lifts2) (lift/binding #'high 'between-high lifts1)]) + (with-syntax ([n lift-low] + [m lift-high]) + (let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)]) (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) (pos (opt/info-pos opt/info)) (src-info (opt/info-src-info opt/info)) (orig-str (opt/info-orig-str opt/info)) - (next-hdp next-hdp) - (next-tlp next-tlp)) - (syntax (if check - (cons (let ((val (car val))) next-hdp) - (let ((val (cdr val))) next-tlp)) - (raise-contract-error + (this (opt/info-this opt/info)) + (that (opt/info-that opt/info))) + (values + (syntax (if (and (number? val) (<= n val m)) val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val))) + lifts3 + null + null + (syntax (and (number? val) (<= n val m))) + #f + (list (new-stronger-var + lift-low + (λ (this that) + (with-syntax ([this this] + [that that]) + (syntax (<= that this))))) + (new-stronger-var + lift-high + (λ (this that) + (with-syntax ([this this] + [that that]) + (syntax (<= this that)))))))))))])) + +(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg) + (with-syntax ([comparison comparison]) + (let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)]) + (with-syntax ([m lift-low]) + (let ([lifts3 (lift/effect (check-arg #'m) lifts2)]) + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + (this (opt/info-this opt/info)) + (that (opt/info-that opt/info))) + (values + (syntax + (if (and (number? val) (comparison val m)) + val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val))) + lifts3 + null + null + (syntax (and (number? val) (comparison val m))) + #f + (list (new-stronger-var + lift-low + (λ (this that) + (with-syntax ([this this] + [that that]) + (syntax (comparison this that))))))))))))) + +(define/opter (>=/c opt/i opt/info stx) + (syntax-case stx (>=/c) + [(>=/c low) + (single-comparison-opter + opt/info + stx + (λ (m) (with-syntax ([m m]) + #'(check-unary-between/c '>=/c m))) + #'>= + #'low)])) + +(define/opter (<=/c opt/i opt/info stx) + (syntax-case stx (<=/c) + [(<=/c high) + (single-comparison-opter + opt/info + stx + (λ (m) (with-syntax ([m m]) + #'(check-unary-between/c '<=/c m))) + #'<= + #'high)])) + +(define/opter (>/c opt/i opt/info stx) + (syntax-case stx (>/c) + [(>/c low) + (single-comparison-opter + opt/info + stx + (λ (m) (with-syntax ([m m]) + #'(check-unary-between/c '>/c m))) + #'> + #'low)])) + +(define/opter (/c x) + (flat-named-contract + `(>/c ,x) + (λ (y) (and (number? y) (> y x))))) + +(define natural-number/c + (flat-named-contract + 'natural-number/c + (λ (x) + (and (number? x) + (integer? x) + (x . >= . 0))))) + +(define (integer-in start end) + (unless (and (integer? start) + (exact? start) + (integer? end) + (exact? end)) + (error 'integer-in "expected two exact integers as arguments, got ~e and ~e" start end)) + (flat-named-contract + `(integer-in ,start ,end) + (λ (x) + (and (integer? x) + (exact? x) + (<= start x end))))) + +(define (real-in start end) + (unless (and (real? start) + (real? end)) + (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end)) + (flat-named-contract + `(real-in ,start ,end) + (λ (x) + (and (real? x) + (<= start x end))))) + +(define (not/c f) + (unless (flat-contract/predicate? f) + (error 'not/c "expected a procedure of arity 1 or , given: ~e" f)) + (build-flat-contract + (build-compound-type-name 'not/c (proc/ctc->ctc f)) + (λ (x) (not (test-proc/flat-contract f x))))) + +(define-syntax (*-immutableof stx) + (syntax-case stx () + [(_ predicate? fill testmap type-name name) + (identifier? (syntax predicate?)) + (syntax + (let ([fill-name fill]) + (λ (input) + (let ([ctc (coerce-contract 'name input)]) + (if (flat-contract? ctc) + (let ([content-pred? (flat-contract-predicate ctc)]) + (build-flat-contract + `(listof ,(contract-name ctc)) + (lambda (x) (and (predicate? x) (testmap content-pred? x))))) + (let ([proj (contract-proc ctc)]) + (make-proj-contract + (build-compound-type-name 'name ctc) + (λ (pos-blame neg-blame src-info orig-str) + (let ([p-app (proj pos-blame neg-blame src-info orig-str)]) + (λ (val) + (unless (predicate? val) + (raise-contract-error + val + src-info + pos-blame + orig-str + "expected <~a>, given: ~e" + 'type-name + val)) + (fill-name p-app val)))) + predicate?)))))))])) + +(define listof + (*-immutableof list? map andmap list listof)) + +(define (immutable-vector? val) (and (immutable? val) (vector? val))) + +(define vector-immutableof + (*-immutableof immutable-vector? + (λ (f v) (apply vector-immutable (map f (vector->list v)))) + (λ (f v) (andmap f (vector->list v))) + immutable-vector + vector-immutableof)) + +(define (vectorof p) + (unless (flat-contract/predicate? p) + (error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) + (build-flat-contract + (build-compound-type-name 'vectorof (proc/ctc->ctc p)) + (λ (v) + (and (vector? v) + (andmap (λ (ele) (test-proc/flat-contract p ele)) + (vector->list v)))))) + +(define (vector/c . args) + (unless (andmap flat-contract/predicate? args) + (error 'vector/c "expected flat contracts as arguments, got: ~a" + (let loop ([args args]) + (cond + [(null? args) ""] + [(null? (cdr args)) (format "~e" (car args))] + [else (string-append + (format "~e " (car args)) + (loop (cdr args)))])))) + (let ([largs (length args)]) + (build-flat-contract + (apply build-compound-type-name 'vector/c (map proc/ctc->ctc args)) + (λ (v) + (and (vector? v) + (= (vector-length v) largs) + (andmap test-proc/flat-contract + args + (vector->list v))))))) + +(define (box/c pred) + (unless (flat-contract/predicate? pred) + (error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred)) + (build-flat-contract + (build-compound-type-name 'box/c (proc/ctc->ctc pred)) + (λ (x) + (and (box? x) + (test-proc/flat-contract pred (unbox x)))))) + +;; +;; cons/c opter +;; +(define/opter (cons/c opt/i opt/info stx) + (define (opt/cons-ctc hdp tlp) + (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd) + (opt/i opt/info hdp)] + [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl) + (opt/i opt/info tlp)] + [(error-check) (car (generate-temporaries (syntax (error-check))))]) + (with-syntax ((next (with-syntax ((flat-hdp flat-hdp) + (flat-tlp flat-tlp) + (val (opt/info-val opt/info))) + (syntax + (and (pair? val) + (let ((val (car val))) flat-hdp) + (let ((val (cdr val))) flat-tlp)))))) + (values + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info))) + (syntax (if next + val + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val)))) + (append + lifts-hdp lifts-tlp + (list (cons error-check + (with-syntax ((hdp hdp) + (tlp tlp) + (check (with-syntax ((flat-hdp + (cond + [unknown-hdp + (with-syntax ((ctc unknown-hdp)) + (syntax (flat-contract/predicate? ctc)))] + [else (if flat-hdp #'#t #'#f)])) + (flat-tlp + (cond + [unknown-tlp + (with-syntax ((ctc unknown-tlp)) + (syntax (flat-contract/predicate? ctc)))] + [else (if flat-tlp #'#t #'#f)]))) + (syntax (and flat-hdp flat-tlp))))) + (syntax + (unless check + (error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e" + hdp tlp))))))) + (append superlifts-hdp superlifts-tlp) + (append partials-hdp partials-tlp) + (syntax (if next #t #f)) + #f + (append stronger-ribs-hd stronger-ribs-tl))))) + + (syntax-case stx (cons/c) + [(cons/c hdp tlp) + (opt/cons-ctc #'hdp #'tlp)])) + +(define-syntax (*-immutable/c stx) + (syntax-case stx () + [(_ predicate? constructor (arb? selectors ...) type-name name) + #'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)] + [(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?) + (and (eq? #f (syntax->datum (syntax arb?))) + (boolean? (syntax->datum #'test-immutable?))) + (let ([test-immutable? (syntax->datum #'test-immutable?)]) + (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] + [(p-apps ...) (generate-temporaries (syntax (selectors ...)))] + [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))] + [(procs ...) (generate-temporaries (syntax (selectors ...)))] + [(selector-names ...) (generate-temporaries (syntax (selectors ...)))]) + #`(let ([predicate?-name predicate?] + [constructor-name constructor] + [selector-names selectors] ...) + (λ (params ...) + (let ([ctc-x (coerce-contract 'name params)] ...) + (if (and (flat-contract? ctc-x) ...) + (let ([p-apps (flat-contract-predicate ctc-x)] ...) + (build-flat-contract + `(name ,(contract-name ctc-x) ...) + (lambda (x) + (and (predicate?-name x) + (p-apps (selector-names x)) + ...)))) + (let ([procs (contract-proc ctc-x)] ...) + (make-proj-contract + (build-compound-type-name 'name (proc/ctc->ctc params) ...) + (λ (pos-blame neg-blame src-info orig-str) + (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...) + (λ (v) + (if #,(if test-immutable? + #'(and (predicate?-name v) + (immutable? v)) + #'(predicate?-name v)) + (constructor-name (p-apps (selector-names v)) ...) + (raise-contract-error + v + src-info + pos-blame + orig-str + #,(if test-immutable? + "expected immutable <~a>, given: ~e" + "expected <~a>, given: ~e") + 'type-name + v))))) + #f))))))))] + [(_ predicate? constructor (arb? selector) correct-size type-name name) + (eq? #t (syntax->datum (syntax arb?))) + (syntax + (let ([predicate?-name predicate?] + [constructor-name constructor] + [selector-name selector]) + (λ params + (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)]) + (let ([procs (map contract-proc ctcs)]) + (make-proj-contract + (apply build-compound-type-name 'name (map proc/ctc->ctc params)) + (λ (pos-blame neg-blame src-info orig-str) + (let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)] + [count (length params)]) + (λ (v) + (if (and (immutable? v) + (predicate?-name v) + (correct-size count v)) + (apply constructor-name + (let loop ([p-apps p-apps] + [i 0]) + (cond + [(null? p-apps) null] + [else (let ([p-app (car p-apps)]) + (cons (p-app (selector-name v i)) + (loop (cdr p-apps) (+ i 1))))]))) + (raise-contract-error + v src-info - pos + pos-blame orig-str "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val)))) - (append lifts-hdp lifts-tlp) - (append superlifts-hdp superlifts-tlp) - (append partials-hdp partials-tlp) - (if (and flat-hdp flat-tlp) - (with-syntax ((val (opt/info-val opt/info)) - (flat-hdp flat-hdp) - (flat-tlp flat-tlp)) - (syntax (if (and check - (let ((val (car val))) flat-hdp) - (let ((val (cdr val))) flat-tlp)) #t #f))) - #f) - #f - (append stronger-ribs-hd stronger-ribs-tl))))) - - (syntax-case stx (cons/c) - [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)])) - - (define (list/c . args) - (unless (andmap (λ (x) (or (contract? x) - (and (procedure? x) - (procedure-arity-includes? x 1)))) - args) - (error 'list/c "expected contracts or procedures of arity 1, got: ~a" - (let loop ([args args]) - (cond - [(null? args) ""] - [(null? (cdr args)) (format "~e" (car args))] - [else (string-append - (format "~e " (car args)) - (loop (cdr args)))])))) - (let loop ([args args]) - (cond - [(null? args) (flat-contract null?)] - [else (cons/c (car args) (loop (cdr args)))]))) + 'type-name + v))))) + #f))))))])) - (define (syntax/c ctc-in) - (let ([ctc (coerce-contract 'syntax/c ctc-in)]) - (build-flat-contract - (build-compound-type-name 'syntax/c ctc) - (let ([pred (flat-contract-predicate ctc)]) - (λ (val) - (and (syntax? val) - (pred (syntax-e val)))))))) +(define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f)) +(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) +(define vector-immutable/c (*-immutable/c vector? + vector-immutable + (#t (λ (v i) (vector-ref v i))) + (λ (n v) (= n (vector-length v))) + immutable-vector + vector-immutable/c)) + +;; +;; cons/c opter +;; +(define/opter (cons/c opt/i opt/info stx) + (define (opt/cons-ctc hdp tlp) + (let-values ([(next-hdp lifts-hdp superlifts-hdp partials-hdp flat-hdp unknown-hdp stronger-ribs-hd) + (opt/i opt/info hdp)] + [(next-tlp lifts-tlp superlifts-tlp partials-tlp flat-tlp unknown-tlp stronger-ribs-tl) + (opt/i opt/info tlp)]) + (with-syntax ((check (with-syntax ((val (opt/info-val opt/info))) + (syntax (pair? val))))) + (values + (with-syntax ((val (opt/info-val opt/info)) + (ctc (opt/info-contract opt/info)) + (pos (opt/info-pos opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + (next-hdp next-hdp) + (next-tlp next-tlp)) + (syntax (if check + (cons (let ((val (car val))) next-hdp) + (let ((val (cdr val))) next-tlp)) + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, given: ~e" + ((name-get ctc) ctc) + val)))) + (append lifts-hdp lifts-tlp) + (append superlifts-hdp superlifts-tlp) + (append partials-hdp partials-tlp) + (if (and flat-hdp flat-tlp) + (with-syntax ((val (opt/info-val opt/info)) + (flat-hdp flat-hdp) + (flat-tlp flat-tlp)) + (syntax (if (and check + (let ((val (car val))) flat-hdp) + (let ((val (cdr val))) flat-tlp)) #t #f))) + #f) + #f + (append stronger-ribs-hd stronger-ribs-tl))))) - (define promise/c - (λ (ctc-in) - (let* ([ctc (coerce-contract 'promise/c ctc-in)] - [ctc-proc (contract-proc ctc)]) - (make-proj-contract - (build-compound-type-name 'promise/c ctc) - (λ (pos-blame neg-blame src-info orig-str) - (let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str)]) - (λ (val) - (unless (promise? val) - (raise-contract-error - val - src-info - pos-blame - 'ignored - orig-str - "expected , given: ~e" - val)) - (delay (p-app (force val)))))) - promise?)))) - - #| + (syntax-case stx (cons/c) + [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)])) + +(define (list/c . args) + (unless (andmap (λ (x) (or (contract? x) + (and (procedure? x) + (procedure-arity-includes? x 1)))) + args) + (error 'list/c "expected contracts or procedures of arity 1, got: ~a" + (let loop ([args args]) + (cond + [(null? args) ""] + [(null? (cdr args)) (format "~e" (car args))] + [else (string-append + (format "~e " (car args)) + (loop (cdr args)))])))) + (let loop ([args args]) + (cond + [(null? args) (flat-contract null?)] + [else (cons/c (car args) (loop (cdr args)))]))) + +(define (syntax/c ctc-in) + (let ([ctc (coerce-contract 'syntax/c ctc-in)]) + (build-flat-contract + (build-compound-type-name 'syntax/c ctc) + (let ([pred (flat-contract-predicate ctc)]) + (λ (val) + (and (syntax? val) + (pred (syntax-e val)))))))) + +(define promise/c + (λ (ctc-in) + (let* ([ctc (coerce-contract 'promise/c ctc-in)] + [ctc-proc (contract-proc ctc)]) + (make-proj-contract + (build-compound-type-name 'promise/c ctc) + (λ (pos-blame neg-blame src-info orig-str) + (let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str)]) + (λ (val) + (unless (promise? val) + (raise-contract-error + val + src-info + pos-blame + 'ignored + orig-str + "expected , given: ~e" + val)) + (delay (p-app (force val)))))) + promise?)))) + +#| as with copy-struct in struct.ss, this first begin0 expansion "declares" that struct/c is an expression. It prevents further expansion until the internal definition context is sorted out. |# - (define-syntax (struct/c stx) - (syntax-case stx () - [(_ . args) - (with-syntax ([x (syntax/loc stx (do-struct/c . args))]) - (syntax/loc stx (begin0 x)))])) - - (define-syntax (do-struct/c stx) - (syntax-case stx () - [(_ struct-name args ...) - (and (identifier? (syntax struct-name)) - (struct-info? (syntax-local-value (syntax struct-name) (λ () #f)))) - (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))] - [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))] - [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))] - [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))] - [(field-numbers ...) - (let loop ([i 0] - [l (syntax->list (syntax (args ...)))]) +(define-syntax (struct/c stx) + (syntax-case stx () + [(_ . args) + (with-syntax ([x (syntax/loc stx (do-struct/c . args))]) + (syntax/loc stx (begin0 x)))])) + +(define-syntax (do-struct/c stx) + (syntax-case stx () + [(_ struct-name args ...) + (and (identifier? (syntax struct-name)) + (struct-info? (syntax-local-value (syntax struct-name) (λ () #f)))) + (with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-name-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))] + [(ctc-app-x ...) (generate-temporaries (syntax (args ...)))] + [(field-numbers ...) + (let loop ([i 0] + [l (syntax->list (syntax (args ...)))]) + (cond + [(null? l) '()] + [else (cons i (loop (+ i 1) (cdr l)))]))] + [(type-desc-id + constructor-id + predicate-id + (rev-selector-id ...) + (mutator-id ...) + super-id) + (lookup-struct-info (syntax struct-name) stx)]) + (unless (= (length (syntax->list (syntax (rev-selector-id ...)))) + (length (syntax->list (syntax (args ...))))) + (raise-syntax-error 'struct/c + (format "expected ~a contracts because struct ~a has ~a fields" + (length (syntax->list (syntax (rev-selector-id ...)))) + (syntax-e #'struct-name) + (length (syntax->list (syntax (rev-selector-id ...))))) + stx)) + (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]) + (syntax + (let ([ctc-x (coerce-contract 'struct/c args)] ...) + + (unless predicate-id + (error 'struct/c "could not determine predicate for ~s" 'struct-name)) + (unless (and selector-id ...) + (error 'struct/c "could not determine selectors for ~s" 'struct-name)) + + (unless (flat-contract? ctc-x) + (error 'struct/c "expected flat contracts as arguments, got ~e" args)) + ... + + (let ([ctc-pred-x (flat-contract-predicate ctc-x)] + ... + [ctc-name-x (contract-name ctc-x)] + ...) + (build-flat-contract + (build-compound-type-name 'struct/c 'struct-name ctc-x ...) + (λ (val) + (and (predicate-id val) + (ctc-pred-x (selector-id val)) ...))))))))] + [(_ struct-name anything ...) + (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) + + +(define (parameter/c x) + (make-parameter/c (coerce-contract 'parameter/c x))) + +(define-struct/prop parameter/c (ctc) + ((proj-prop (λ (ctc) + (let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) + (λ (pos-blame neg-blame src-info orig-str) + (let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)] + [partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str)]) + (λ (val) (cond - [(null? l) '()] - [else (cons i (loop (+ i 1) (cdr l)))]))] - [(type-desc-id - constructor-id - predicate-id - (rev-selector-id ...) - (mutator-id ...) - super-id) - (lookup-struct-info (syntax struct-name) stx)]) - (unless (= (length (syntax->list (syntax (rev-selector-id ...)))) - (length (syntax->list (syntax (args ...))))) - (raise-syntax-error 'struct/c - (format "expected ~a contracts because struct ~a has ~a fields" - (length (syntax->list (syntax (rev-selector-id ...)))) - (syntax-e #'struct-name) - (length (syntax->list (syntax (rev-selector-id ...))))) - stx)) - (with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]) - (syntax - (let ([ctc-x (coerce-contract 'struct/c args)] ...) - - (unless predicate-id - (error 'struct/c "could not determine predicate for ~s" 'struct-name)) - (unless (and selector-id ...) - (error 'struct/c "could not determine selectors for ~s" 'struct-name)) - - (unless (flat-contract? ctc-x) - (error 'struct/c "expected flat contracts as arguments, got ~e" args)) - ... - - (let ([ctc-pred-x (flat-contract-predicate ctc-x)] - ... - [ctc-name-x (contract-name ctc-x)] - ...) - (build-flat-contract - (build-compound-type-name 'struct/c 'struct-name ctc-x ...) - (λ (val) - (and (predicate-id val) - (ctc-pred-x (selector-id val)) ...))))))))] - [(_ struct-name anything ...) - (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) - - - (define (parameter/c x) - (make-parameter/c (coerce-contract 'parameter/c x))) - - (define-struct/prop parameter/c (ctc) - ((proj-prop (λ (ctc) - (let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) - (λ (pos-blame neg-blame src-info orig-str) - (let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str)] - [partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str)]) - (λ (val) - (cond - [(parameter? val) - (make-derived-parameter - val - partial-neg-contract - partial-pos-contract)] - [else - (raise-contract-error val src-info pos-blame orig-str - "expected a parameter")]))))))) - (name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))) - (first-order-prop - (λ (ctc) - (let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) - (λ (x) - (and (parameter? x) - (tst (x))))))) - - (stronger-prop - (λ (this that) - ;; must be invariant (because the library doesn't currently split out pos/neg contracts - ;; which could be tested individually ....) - (and (parameter/c? that) - (contract-stronger? (parameter/c-ctc this) - (parameter/c-ctc that)) - (contract-stronger? (parameter/c-ctc that) - (parameter/c-ctc this))))))) - - ) + [(parameter? val) + (make-derived-parameter + val + partial-neg-contract + partial-pos-contract)] + [else + (raise-contract-error val src-info pos-blame orig-str + "expected a parameter")]))))))) + (name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))) + (first-order-prop + (λ (ctc) + (let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) + (λ (x) + (and (parameter? x) + (tst (x))))))) + + (stronger-prop + (λ (this that) + ;; must be invariant (because the library doesn't currently split out pos/neg contracts + ;; which could be tested individually ....) + (and (parameter/c? that) + (contract-stronger? (parameter/c-ctc this) + (parameter/c-ctc that)) + (contract-stronger? (parameter/c-ctc that) + (parameter/c-ctc this))))))) +