suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

this checkpoint causes racket to crash, with a segfault. run racket racket/contract/scratch.rkt to

Browse Source 
see the error.
This commit is contained in:
Robby Findler 2010-08-02 15:29:47 -05:00
parent 4c240f2307
commit 9fcc157b0d
4 changed files with 52 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/racket/contract/private/arr-i.rkt
View File

@ -3,6 +3,7 @@
(require "arrow.rkt"
"prop.rkt"
"guts.rkt"
unstable/location
(for-syntax racket/base
racket/stxparam-exptime
"arr-i-parse.rkt"))
@ -17,32 +18,42 @@
;; mandatory-kwds, opt-kwds : (listof keyword?) sorted by keyword<?
;; rest? : boolean
;; mk-wrapper : creates the a wrapper function that implements the contract checking
(struct ->i (arg-ctcs arg-dep-ctcs 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? mk-wrapper)
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let ([arg-ctc-projs (map contract-projection (->i-arg-ctcs ctc))]
[indy-arg-ctc-projs (map contract-projection (->i-indy-arg-ctcs ctc))]
[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)])
(λ (blame)
(let ([swapped-blame (blame-swap blame)]
[indy-blame blame]) ;; WRONG!
(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-rngs (map (λ (rng) (rng blame)) rng-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-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))
@ -60,7 +71,6 @@
;; (vector-length vars) = (length args)
;; builds the parameter list for the wrapper λ
(define-for-syntax (args/vars->arglist args vars)
;; WRONG: does not deal with optional args properly
(let loop ([args args]
[i 0])
(cond
@ -105,18 +115,18 @@
#`(apply/no-unsupplied #,fn #,@(vector->list vars))]
[else
;; no optional args
`(,fn
,(let loop ([args args]
[i 0])
(cond
[(null? args) #'()]
[else
(let ([arg (car args)])
`(,@(if (arg-kwd arg)
`(,(arg-kwd arg) ,(vector-ref vars i))
`(,(vector-ref vars i)))
.
,(loop (cdr args) (+ i 1))))])))])))
#`(#,fn
#,@(let loop ([args args]
[i 0])
(cond
[(null? args) #'()]
[else
(let ([arg (car args)])
#`(#,@(if (arg-kwd arg)
#`(#,(arg-kwd arg) #,(vector-ref vars i))
#`(#,(vector-ref vars i)))
.
#,(loop (cdr args) (+ i 1))))])))])))
(define (apply/no-unsupplied fn . args)
(apply fn (filter (λ (x) (not (eq? x the-unsupplied-arg))) args)))
@ -142,7 +152,10 @@
(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))))])
[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)
(define (arg-to-indy-var var)
(let loop ([iargs indy-args]
@ -156,8 +169,7 @@
(cond
[(free-identifier=? var arg) iarg]
[else (loop (cdr iargs) (cdr args))]))])))
#`(λ (blame swapped-blame indy-blame chk ctc #,@(vector->list arg-proj-vars))
#`(λ (blame swapped-blame indy-dom-blame indy-rng-blame chk ctc #,@(vector->list arg-proj-vars) #,@(vector->list indy-arg-proj-vars))
(λ (val)
(chk val #,(and (syntax-parameter-value #'making-a-method) #t))
(make-contracted-function
@ -167,7 +179,8 @@
[arg (in-list ordered-args)]
[arg-index arg-indicies])
(let ([wrapper-arg (vector-ref wrapper-args arg-index)]
[arg-proj-var (vector-ref arg-proj-vars arg-index)])
[arg-proj-var (vector-ref arg-proj-vars arg-index)]
[indy-arg-proj-var (vector-ref indy-arg-proj-vars arg-index)])
(define (add-unsupplied-check stx)
(if (arg-optional? arg)
#`(if (eq? #,wrapper-arg the-unsupplied-arg)
@ -179,9 +192,9 @@
[#,indy-arg
#,(add-unsupplied-check
(if (arg-vars arg)
#`(un-dep (#,arg-proj-var #,@(map arg-to-indy-var (arg-vars arg))) #,wrapper-arg indy-blame)
#`(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)
#`(#,arg-proj-var #,wrapper-arg)))]
#`(#,indy-arg-proj-var #,wrapper-arg)))]
[#,wrapper-arg
#,(add-unsupplied-check
(if (arg-vars arg)
@ -191,6 +204,7 @@
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)
(let ([ctc (coerce-contract '->i ctc)])
(((contract-projection ctc) blame) obj)))
@ -200,9 +214,17 @@
[wrapper-func (mk-wrapper-func an-istx)])
#`(->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)
(list #,@(filter values (map (λ (arg) (and (not (arg-vars arg)) (arg-ctc arg)))
(istx-args an-istx))))
(list #,@(filter values (map (λ (arg) (and (arg-vars arg) #`(λ #,(arg-vars arg) #,(arg-ctc arg))))
(istx-args an-istx))))
#,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg)))
(istx-ress an-istx))))
#''())
;; WRONG! this needs to be a subset of the previuos (and to generate a let to share appropriately)
#,(if (istx-ress an-istx)
#`(list #,@(filter values (map (λ (arg) (and (not (res-vars arg)) (res-ctc arg)))
(istx-ress an-istx))))

2
collects/racket/contract/private/base.rkt
View File

@ -38,7 +38,7 @@ improve method arity mismatch contract violation error messages?
"(either 4 or 6 arguments)"))]))
(define (apply-contract c v pos neg name loc usr)
(let* ([c (coerce-contract 'contract c)])
(let ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc)
(((contract-projection c)
(make-blame loc name (contract-name c) pos neg usr #t))

4
collects/racket/contract/private/blame.rkt
View File

@ -12,6 +12,7 @@
blame-original?
blame-swapped?
blame-swap
blame-replace-negative ;; used for indy blame
raise-blame-error
current-blame-format
@ -45,6 +46,9 @@
[positive (blame-negative b)]
[negative (blame-positive b)]))
(define (blame-replace-negative b new-neg)
(struct-copy blame b [negative new-neg]))
(define (blame-swapped? b)
(not (blame-original? b)))

2
collects/racket/contract/scratch.rkt
View File

@ -9,7 +9,7 @@
any))))
((contract (->i ([f (-> number? number?)]
[y (f) (<=/c (f 0))])
[y (f) (<=/c (f 'not-a-number))])
any)
(λ (f y) 'final-result)
'pos 'neg)