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

renamed the contract obligation properties and added options to a few more contract combinators

Browse Source
This commit is contained in:
Robby Findler 2010-07-13 16:44:03 -05:00
parent 8e4b169583
commit 2b2fb3c07e
5 changed files with 22 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/drracket/private/syncheck/contract-traversal.rkt
View File

@ -21,8 +21,8 @@
(let loop ([stx stx])
(add-to-map stx 'racket/contract:contract-on-boundary boundary-start-map)
(add-to-map stx 'racket/contract:internal-contract internal-start-map)
(add-to-map stx 'racket/contract:domain-of domain-map)
(add-to-map stx 'racket/contract:rng-of range-map)
(add-to-map stx 'racket/contract:negative-position domain-map)
(add-to-map stx 'racket/contract:positive-position range-map)
(add-to-map stx 'racket/contract:function-contract arrow-map)
(syntax-case stx ()
[(a . b) (loop #'a) (loop #'b)]
@ -44,7 +44,7 @@
my-coloring-plans client-coloring-plans
low-binders binding-inits
arrow-map domain-map range-map
#t)))
#f)))
;; enact the coloring plans
(for ((coloring-plans (in-list (list my-coloring-plans client-coloring-plans)))

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

@ -146,19 +146,21 @@
leftover)
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]
[(this->i) (gensym '->i)])
(define (add-indy-prop stx)
(syntax-property stx 'racket/contract:internal-contract (gensym '->i-boundary)))
(with-syntax ([(([mandatory-regular-id mandatory-dom/no-prop] ... )
([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom/no-prop)] ...))
(verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))]
[(([optional-regular-id optional-dom/no-prop] ...)
([optional-kwd (optional-kwd-id optional-kwd-dom/no-prop)] ...))
(verify-->i-structure stx (split-doms stx '->i raw-optional-doms))])
(with-syntax ([(mandatory-dom ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->i))
(with-syntax ([(mandatory-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
(syntax->list #'(mandatory-dom/no-prop ...)))]
[(mandatory-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->i))
[(mandatory-kwd-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
(syntax->list #'(mandatory-kwd-dom/no-prop ...)))]
[(optional-dom ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->i))
[(optional-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
(syntax->list #'(optional-dom/no-prop ...)))]
[(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->i))
[(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->i))
(syntax->list #'(optional-kwd-dom/no-prop ...)))])
(with-syntax ([((kwd kwd-id) ...)
(sort-keywords
@ -182,13 +184,13 @@
(with-syntax ([((rng-params ...) rng-ctcs)
(syntax-case range (any values)
[(values [id ctc/no-prop] ...)
(with-syntax ([(ctc ...) (map (λ (x) (syntax-property x 'racket/contract:rng-of this->i))
(with-syntax ([(ctc ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:positive-position this->i)))
(syntax->list #'(ctc/no-prop ...)))])
#'((id ...) (ctc ...)))]
[(values [id ctc] ... x . y) (raise-syntax-error #f "expected binding pair" stx #'x)]
[any #'(() #f)]
[[id ctc]
#`((id) (#,(syntax-property #'ctc 'racket/contract:rng-of this->i)))]
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
[mtd? (and (syntax-parameter-value #'making-a-method) #t)])
(let ([rng-underscores?
@ -232,7 +234,6 @@
(syntax-parameterize
((making-a-method #f))
#,(syntax-property
(syntax-property
#`(build-->d mtd?
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-dom)) ...)
@ -279,9 +280,7 @@
kwd))
(if pre-kwd
(list pre-kwd)
'()))))
'racket/contract:internal-contract
(gensym '->i-boundary)))))))))))]))
'())))))))))))))]))
(define ->d-tail-key (gensym '->d-tail-key))

6
collects/racket/contract/private/arrow.rkt
View File

@ -301,11 +301,11 @@ v4 todo:
(with-syntax ([(dom-names ...) dom-names]
[(rng-names ...) rng-names]
[(kwd-names ...) kwd-names]
[(dom-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->))
[(dom-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->))
(syntax->list dom-ctcs))]
[(rng-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:rng-of this->))
[(rng-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:positive-position this->))
(syntax->list rng-ctcs))]
[(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:domain-of this->))
[(kwd-ctcs ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->))
(syntax->list kwd-ctcs))]
[(kwds ...) kwds]
[inner-lambda

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

@ -435,7 +435,7 @@
[(_ margs (... ...))
(let ([this-one (gensym 'ctc)])
(with-syntax ([(margs (... ...))
(map (λ (x) (syntax-property x 'racket/contract:rng-of this-one))
(map (λ (x) (syntax-property x 'racket/contract:positive-position this-one))
(syntax->list #'(margs (... ...))))])
(syntax-property
#'(ctc/proc margs (... ...))

10
collects/racket/contract/private/misc.rkt
View File

@ -753,12 +753,13 @@
'type-name val))
(fill-name p-app val))))))))))]))
(define listof
(*-immutableof list? for-each map andmap list listof))
(define listof-func (*-immutableof list? for-each map andmap list listof))
(define/subexpression-pos-prop (listof x) (listof-func x))
(define (non-empty-list? x) (and (pair? x) (list? (cdr x))))
(define non-empty-listof
(define non-empty-listof-func
(*-immutableof non-empty-list? for-each map andmap non-empty-list non-empty-listof))
(define/subexpression-pos-prop (non-empty-listof a) (non-empty-listof-func a))
(define/final-prop (immutable-vector? val) (and (immutable? val) (vector? val)))
@ -978,7 +979,8 @@
[i (in-naturals)])
(p (selector-name v i)))))))))))))]))
(define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define cons/c-main-function (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b))
(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