diff --git a/collects/racket/contract/private/arr-i-parse.rkt b/collects/racket/contract/private/arr-i-parse.rkt index 8c3f3b5811..784227e444 100644 --- a/collects/racket/contract/private/arr-i-parse.rkt +++ b/collects/racket/contract/private/arr-i-parse.rkt @@ -1,13 +1,13 @@ #lang racket/base -(require syntax/private/boundmap +(require (rename-in syntax/private/boundmap + ;; the private version of the library + ;; (the one without contracts) + ;; has these old, wrong names in it. + [make-module-identifier-mapping make-free-identifier-mapping] + [module-identifier-mapping-get free-identifier-mapping-get] + [module-identifier-mapping-put! free-identifier-mapping-put!]) (for-template racket/base "guts.rkt")) -;; the private version of the library -;; (the one without contracts) -;; has these old, wrong names in it. -(define make-free-identifier-mapping make-module-identifier-mapping) -(define free-identifier-mapping-get module-identifier-mapping-get) -(define free-identifier-mapping-put! module-identifier-mapping-put!) #| @@ -54,7 +54,7 @@ code does the parsing and validation of the syntax. (define (parse-->i stx) (let-values ([(raw-mandatory-doms raw-optional-doms - id/rest-id pre-cond range post-cond) + id/rest-id pre-cond range post-cond) (pull-out-pieces stx)]) (let ([candidate (istx (append (parse-doms stx #f raw-mandatory-doms) diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 8fdb8d6532..fb166aa3db 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -6,7 +6,16 @@ unstable/location (for-syntax racket/base racket/stxparam-exptime - "arr-i-parse.rkt")) + "arr-i-parse.rkt" + + (rename-in syntax/private/boundmap + ;; the private version of the library + ;; (the one without contracts) + ;; has these old, wrong names in it. + [make-module-identifier-mapping make-free-identifier-mapping] + [module-identifier-mapping-get free-identifier-mapping-get] + [module-identifier-mapping-put! free-identifier-mapping-put!] + [module-identifier-mapping-for-each free-identifier-mapping-for-each]))) (provide (rename-out [->i/m ->i])) @@ -18,7 +27,7 @@ ;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keywordi (arg-ctcs indy-arg-ctcs arg-dep-ctcs rng-ctcs indy-rng-ctcs rng-dep-ctcs mandatory-args opt-args mandatory-kwds opt-kwds rest? mk-wrapper) +(struct ->i (arg-ctcs indy-arg-ctcs arg-dep-ctcs rng-ctcs indy-rng-ctcs rng-dep-ctcs mandatory-args opt-args mandatory-kwds opt-kwds rest? here mk-wrapper) #:property prop:contract (build-contract-property #:projection @@ -28,36 +37,35 @@ [rng-ctc-projs (map contract-projection (->i-rng-ctcs ctc))] [indy-rng-ctc-projs (map contract-projection (->i-indy-rng-ctcs ctc))] [func (->i-mk-wrapper ctc)] - [has-rest? (->i-rest? ctc)]) + [has-rest? (->i-rest? ctc)] + [here (->i-here ctc)]) (λ (blame) (let* ([swapped-blame (blame-swap blame)] - [here (quote-module-path)] [indy-dom-blame (blame-replace-negative swapped-blame here)] - [indy-rng-blame (blame-replace-negative blame here)]) - (let ([partial-doms (map (λ (dom) (dom swapped-blame)) arg-ctc-projs)] - [partial-indy-doms (map (λ (dom) (dom indy-dom-blame)) indy-arg-ctc-projs)] - [partial-rngs (map (λ (rng) (rng blame)) rng-ctc-projs)] - [partial-indy-rngs (map (λ (rng) (rng indy-rng-blame)) rng-ctc-projs)]) - (printf "partial-doms ~s partial-indy-doms ~s\n" partial-doms partial-indy-doms) - (apply func - blame - swapped-blame - indy-dom-blame - indy-rng-blame - (λ (val mtd?) - (if has-rest? - (check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame) - (check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame))) - ctc - (append partial-doms - partial-indy-doms - (->i-arg-dep-ctcs ctc) - partial-rngs - partial-indy-rngs - (->i-rng-dep-ctcs ctc)))))))) - #:name (λ (ctc) '->i) - #:first-order (λ (ctc) (λ (x) #f)) - #:stronger (λ (this that) #f))) + [indy-rng-blame (blame-replace-negative blame here)] + [partial-doms (map (λ (dom) (dom swapped-blame)) arg-ctc-projs)] + [partial-indy-doms (map (λ (dom) (dom indy-dom-blame)) indy-arg-ctc-projs)] + [partial-rngs (map (λ (rng) (rng blame)) rng-ctc-projs)] + [partial-indy-rngs (map (λ (rng) (rng indy-rng-blame)) rng-ctc-projs)]) + (apply func + blame + swapped-blame + indy-dom-blame + indy-rng-blame + (λ (val mtd?) + (if has-rest? + (check-procedure/more val mtd? (->i-mandatory-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame) + (check-procedure val mtd? (->i-mandatory-args ctc) (->i-opt-args ctc) (->i-mandatory-kwds ctc) (->i-opt-kwds ctc) blame))) + ctc + (append partial-doms + (->i-arg-dep-ctcs ctc) + partial-indy-doms + partial-rngs + (->i-rng-dep-ctcs ctc) + partial-indy-rngs)))))) + #:name (λ (ctc) '->i) ;; WRONG + #:first-order (λ (ctc) (λ (x) #f)) ;; WRONG + #:stronger (λ (this that) #f))) ;; WRONG ;; find-ordering : (listof arg) -> (listof (cons number arg)) (define-for-syntax (find-ordering args) @@ -147,15 +155,20 @@ (cons (car kwd-args) args-rec))]))]))]) (keyword-apply fn kwds kwd-args (filter (λ (x) (not (eq? x the-unsupplied-arg))) args)))) +(define-for-syntax (maybe-generate-temporary x) + (and x (car (generate-temporaries (list x))))) + (define-for-syntax (mk-wrapper-func an-istx) (let-values ([(ordered-args arg-indicies) (find-ordering (istx-args an-istx))]) (let ([wrapper-args (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))] [indy-args (generate-temporaries (map arg-var ordered-args))] [arg-proj-vars (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))] - [indy-arg-proj-vars (list->vector (generate-temporaries (map arg-var (istx-args an-istx))))]) - - (printf "arg-proj-vars ~s indy-arg-proj-vars ~s\n" arg-proj-vars indy-arg-proj-vars) + + ;; WRONG: need to remove unused indy projections + ;; this list is parallel to arg-proj-vars (so use arg-indicies to find the right ones in the loop below) + ;; but it contains #fs in places where we don't need the indy projections + [indy-arg-proj-vars (list->vector (map maybe-generate-temporary (map (λ (x) (and (not (arg-vars x)) (arg-var x))) (istx-args an-istx))))]) (define (arg-to-indy-var var) (let loop ([iargs indy-args] @@ -169,7 +182,14 @@ (cond [(free-identifier=? var arg) iarg] [else (loop (cdr iargs) (cdr args))]))]))) - #`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc #,@(vector->list arg-proj-vars) #,@(vector->list indy-arg-proj-vars)) + + #`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc + ;; first the non-dependent arg projections + #,@(filter values (map (λ (arg arg-proj-var) (and (not (arg-vars arg)) arg-proj-var)) (istx-args an-istx) (vector->list arg-proj-vars))) + ;; then the dependent arg projections + #,@(filter values (map (λ (arg arg-proj-var) (and (arg-vars arg) arg-proj-var)) (istx-args an-istx) (vector->list arg-proj-vars))) + ;; then the non-dependent indy projections + #,@(filter values (vector->list indy-arg-proj-vars))) (λ (val) (chk val #,(and (syntax-parameter-value #'making-a-method) #t)) (make-contracted-function @@ -177,7 +197,8 @@ #,(for/fold ([body (args/vars->callsite #'val (istx-args an-istx) wrapper-args)]) ([indy-arg (in-list indy-args)] [arg (in-list ordered-args)] - [arg-index arg-indicies]) + [arg-index arg-indicies] + [i (in-naturals)]) (let ([wrapper-arg (vector-ref wrapper-args arg-index)] [arg-proj-var (vector-ref arg-proj-vars arg-index)] [indy-arg-proj-var (vector-ref indy-arg-proj-vars arg-index)]) @@ -193,7 +214,6 @@ #,(add-unsupplied-check (if (arg-vars arg) #`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg indy-dom-blame) - ;; WRONG! (need to pass in the indy'ized projections somewhere) #`(#,indy-arg-proj-var #,wrapper-arg)))] [#,wrapper-arg #,(add-unsupplied-check @@ -204,14 +224,28 @@ ctc)))))) (define (un-dep ctc obj blame) - (printf "un-dep blame ~s\n" blame) - ;; WRONG (well, just need to avoid calling coerce-contract if 'ctc' is something simple) + ;; WRONG (well, just need to avoid calling coerce-contract if 'ctc' is something simple) (let ([ctc (coerce-contract '->i ctc)]) (((contract-projection ctc) blame) obj))) +(define-for-syntax (used-indy-vars an-istx) + (let ([vars (make-free-identifier-mapping)]) + (for ([an-arg (in-list (istx-args an-istx))]) + (when (arg-vars an-arg) + (for ([var (in-list (arg-vars an-arg))]) + (free-identifier-mapping-put! vars var #t)))) + (when (istx-ress an-istx) + (for ([a-res (in-list (istx-ress an-istx))]) + (when (res-vars a-res) + (for ([var (in-list (res-vars a-res))]) + (free-identifier-mapping-put! vars var #t))))) + vars)) + (define-syntax (->i/m stx) (let* ([an-istx (parse-->i stx)] + [used-indy-vars (used-indy-vars an-istx)] [wrapper-func (mk-wrapper-func an-istx)]) + ;(printf "used-indy-vars:") (free-identifier-mapping-for-each used-indy-vars (λ (x y) (printf " ~a" x))) (printf "\n") #`(->i (list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg))) (istx-args an-istx)))) ;; WRONG! this needs to be a subset of the previous list (and to generate a let to share appropriately) @@ -245,4 +279,5 @@ (istx-args an-istx))) keyworddatum (expand + (syntax->datum (expand-once #'(->i ([f (-> number? number?)] - [y (f) (<=/c (f 0))]) + [y (f) (<=/c (begin (printf "f: ~s\n" f) (f 'not-a-number)))]) any)))) ((contract (->i ([f (-> number? number?)] - [y (f) (<=/c (f 'not-a-number))]) + [y (f) (<=/c (begin (printf "f: ~s\n" f) (f 'not-a-number)))]) any) - (λ (f y) 'final-result) + (λ (f y) (f 'another-non-number) 'final-result) 'pos 'neg) (λ (x) (* x x)) -10)