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

added define-opt/c

Browse Source 
svn: r5515
This commit is contained in:
Robby Findler 2007-01-31 01:12:19 +00:00
parent 0610ffdd41
commit 81ce545d63
7 changed files with 374 additions and 278 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/contract.ss
View File

@ -9,7 +9,7 @@
"private/contract-basic-opters.ss") "private/contract-basic-opters.ss")
(provide (provide
opt/c #;define-opt/c ;(all-from "private/contract-opt.ss") opt/c define-opt/c ;(all-from "private/contract-opt.ss")
(all-from-except "private/contract-ds.ss" (all-from-except "private/contract-ds.ss"
lazy-depth-to-look) lazy-depth-to-look)

68
collects/mzlib/private/contract-ds-helpers.ss
View File

@ -132,35 +132,21 @@ which are then called when the contract's fields are explored
(define (build-enforcer-clauses opt/i opt/info name stx clauses f-x/vals f-xs/vals (define (build-enforcer-clauses opt/i opt/info name stx clauses f-x/vals f-xs/vals
helper-id helper-info helper-freev) helper-id helper-info helper-freev)
(define (opt/enforcer-clause stx) (define (opt/enforcer-clause id stx)
(syntax-case stx () (syntax-case stx ()
[(f arg ...) [(f arg ...)
;; we need to override the default optimization of recursive calls to use our helper ;; 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)) (and (opt/info-recf opt/info) (module-identifier=? (opt/info-recf opt/info) #'f))
(values (values
#`(f #,(opt/info-val opt/info) arg ...) #`(f #,id arg ...)
null null
null null
null null
#f #f
#f #f
null)] null)]
#; [else (opt/i (opt/info-change-val id opt/info)
[(f arg ...) stx)]))
;; we need to override the default optimization of recursive calls to use our helper
(module-identifier=? (opt/info-recf opt/info) #'f)
(with-syntax ((helper helper-id)
(val (opt/info-val opt/info))
(info helper-info))
(values
(syntax (helper val info arg ...))
null
null
null
#f
#f
null))]
[else (opt/i opt/info stx)]))
(let* ([field-names (let* ([field-names
(map (λ (clause) (map (λ (clause)
@ -197,21 +183,21 @@ which are then called when the contract's fields are explored
(and (identifier? (syntax id)) (and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...))))) (andmap identifier? (syntax->list (syntax (x ...)))))
(let*-values ([(next lifts superlifts partials _ _2 _3) (let*-values ([(next lifts superlifts partials _ _2 _3)
(opt/enforcer-clause (syntax ctc-exp))] (opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg) [(maker-arg)
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ([val (opt/info-val opt/info)]
((arg ...) arglist) [(new-let-bindings ...)
[(new-let-vars ...) (match-up (reverse prior-ac-ids) (match-up/bind (reverse prior-ac-ids)
(syntax (x ...)) (syntax (x ...))
field-names)]) field-names
arglist)])
#`(#,let-var #`(#,let-var
#,(bind-lifts #,(bind-lifts
superlifts superlifts
#`(let ([new-let-vars arg] ...) #`(let (new-let-bindings ...)
#,(bind-lifts #,(bind-lifts
(append lifts partials) (append lifts partials)
#`(let ((val #,let-var)) next)))))])
#,next))))))])
(loop (cdr clauses) (loop (cdr clauses)
(cdr let-vars) (cdr let-vars)
(cdr arglists) (cdr arglists)
@ -231,14 +217,13 @@ which are then called when the contract's fields are explored
[(id ctc-exp) [(id ctc-exp)
(identifier? (syntax id)) (identifier? (syntax id))
(let*-values ([(next lifts superlifts partials _ __ stronger-ribs) (let*-values ([(next lifts superlifts partials _ __ stronger-ribs)
(opt/enforcer-clause (syntax ctc-exp))] (opt/enforcer-clause let-var (syntax ctc-exp))]
[(maker-arg) [(maker-arg)
(with-syntax ((val (opt/info-val opt/info))) (with-syntax ((val (opt/info-val opt/info)))
#`(#,let-var #`(#,let-var
#,(bind-lifts #,(bind-lifts
partials partials
#`(let ((val #,let-var)) next)))])
#,next))))])
(loop (cdr clauses) (loop (cdr clauses)
(cdr let-vars) (cdr let-vars)
(cdr arglists) (cdr arglists)
@ -282,6 +267,31 @@ which are then called when the contract's fields are explored
[else (cons (reverse (cdr vars)) [else (cons (reverse (cdr vars))
(loop (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) (define (match-up prior-ac-ids used-field-names field-names)
(let ([used-field-ids (syntax->list used-field-names)]) (let ([used-field-ids (syntax->list used-field-names)])
(let loop ([prior-ac-ids prior-ac-ids] (let loop ([prior-ac-ids prior-ac-ids]

142
collects/mzlib/private/contract-ds.ss
View File

@ -19,7 +19,8 @@ it around flattened out.
(module contract-ds mzscheme (module contract-ds mzscheme
(require "contract-guts.ss" (require "contract-guts.ss"
"contract-opt.ss" "contract-opt.ss"
"contract-ds-helpers.ss") "contract-ds-helpers.ss"
(lib "etc.ss"))
(require-for-syntax "contract-ds-helpers.ss" (require-for-syntax "contract-ds-helpers.ss"
"contract-helpers.ss" "contract-helpers.ss"
"contract-opt-guts.ss" "contract-opt-guts.ss"
@ -28,12 +29,10 @@ it around flattened out.
(provide define-contract-struct (provide define-contract-struct
make-opt-contract/info make-opt-contract/info
set-opt-contract/info-enforcer!
opt-contract/info-contract opt-contract/info-contract
opt-contract/info-id
opt-contract/info-enforcer opt-contract/info-enforcer
opt-contract/info-pos
opt-contract/info-neg
opt-contract/info-src-info
opt-contract/info-orig-str
lazy-depth-to-look lazy-depth-to-look
unknown? unknown?
@ -350,17 +349,7 @@ it around flattened out.
(let*-values ([(inner-val) #'val] (let*-values ([(inner-val) #'val]
[(clauses lifts superlifts stronger-ribs) [(clauses lifts superlifts stronger-ribs)
(build-enforcer-clauses opt/i (build-enforcer-clauses opt/i
(make-opt/info #'ctc (opt/info-change-val inner-val opt/info)
inner-val
#'pos
#'neg
#'src-info
#'orig-str
(opt/info-free-vars opt/info)
(opt/info-recf opt/info)
(opt/info-base-pred opt/info)
(opt/info-this opt/info)
(opt/info-that opt/info))
name name
stx stx
clauses clauses
@ -372,33 +361,16 @@ it around flattened out.
(with-syntax ([(clause (... ...)) clauses] (with-syntax ([(clause (... ...)) clauses]
[enforcer-id enforcer-id-var] [enforcer-id enforcer-id-var]
[helper-id helper-id-var] [helper-id helper-id-var]
[free-vars (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)] [((free-var free-var-val) (... ...))
(make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
[(saved-lifts (... ...)) (lifts-to-save lifts)]) [(saved-lifts (... ...)) (lifts-to-save lifts)])
(values (values
#`(λ (stct f-x ...) #`(λ (stct f-x ...)
(let* ([info (opt-wrap-get stct 1)] (let ((free-var free-var-val) (... ...))
[enforcer (opt-contract/info-enforcer info)]
[ctc (opt-contract/info-contract info)]
[pos (opt-contract/info-pos info)]
[neg (opt-contract/info-neg info)]
[src-info (opt-contract/info-src-info info)]
[orig-str (opt-contract/info-orig-str info)])
(let free-vars
#,(bind-lifts #,(bind-lifts
lifts lifts
#`(let-syntax #,(if (opt/info-recf opt/info) #'(let* (clause (... ...))
#`([#,(opt/info-recf opt/info) (values f-x ...)))))
(lambda (stx)
(syntax-case stx ()
[(f val args ((... ...) (... ...)))
#'(helper-id val
info
args
((... ...) (... ...))
saved-lifts (... ...))]))])
#`())
(let* (clause (... ...))
(values f-x ...)))))))
lifts lifts
superlifts superlifts
stronger-ribs)))) stronger-ribs))))
@ -411,7 +383,8 @@ it around flattened out.
[(_ clause (... ...)) [(_ clause (... ...))
(let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer))))) (let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer)))))
(helper-id-var (car (generate-temporaries (syntax (helper))))) (helper-id-var (car (generate-temporaries (syntax (helper)))))
(contract/info-var (car (generate-temporaries (syntax (contract/info)))))) (contract/info-var (car (generate-temporaries (syntax (contract/info)))))
(id-var (car (generate-temporaries (syntax (id))))))
(let-values ([(enforcer lifts superlifts stronger-ribs) (let-values ([(enforcer lifts superlifts stronger-ribs)
(build-enforcer opt/i (build-enforcer opt/i
opt/info opt/info
@ -430,33 +403,34 @@ it around flattened out.
(src-info (opt/info-src-info opt/info)) (src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)) (orig-str (opt/info-orig-str opt/info))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(base-pred (or (opt/info-base-pred opt/info) #'(λ (x) #f)))
(enforcer-id enforcer-id-var) (enforcer-id enforcer-id-var)
(helper-id helper-id-var) (helper-id helper-id-var)
(contract/info contract/info-var) (contract/info contract/info-var)
(id id-var)
((j (... ...)) (let loop ([i 2] ((j (... ...)) (let loop ([i 2]
[lst to-save]) [lst to-save])
(cond (cond
[(null? lst) null] [(null? lst) null]
[else (cons i (loop (+ i 1) (cdr lst)))]))) [else (cons i (loop (+ i 1) (cdr lst)))])))
((free-var (... ...)) to-save)) ((free-var (... ...)) to-save))
(values (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
(syntax (helper-id val contract/info free-var (... ...)))
lifts
(append
superlifts
(list (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
[(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)] [(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)]
[(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)] [(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)]
[(stronger-indexes (... ...)) (build-list (length stronger-ribs) [(stronger-indexes (... ...)) (build-list (length stronger-ribs)
(λ (x) (+ x 2)))] (λ (x) (+ x 2)))]
[(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)]) [(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)])
(cons #'is-stronger?
#'(λ (val i free-var (... ...)) (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 (cond
[(= i 0) #f] [(opt-wrap-predicate val)
[(and (opt-wrap-predicate val) (if (and (opt-wrap-get val 0)
(opt-wrap-get val 0))
(let ([stronger-this-var stronger-var] (let ([stronger-this-var stronger-var]
(... ...) (... ...)
@ -465,35 +439,21 @@ it around flattened out.
;; saved in the wrapper are the same ;; saved in the wrapper are the same
[stronger-that-var (opt-wrap-get val stronger-indexes)] [stronger-that-var (opt-wrap-get val stronger-indexes)]
(... ...)) (... ...))
(and
(or (and
;; make sure this is the same contract -- if not, ;; make sure this is the same contract -- if not,
;; the rest of this test is bogus and may fail at runtime ;; the rest of this test is bogus and may fail at runtime
(eq? enforcer-id (opt-contract/info-enforcer (eq? id (opt-contract/info-id (opt-wrap-get val 1)))
(opt-wrap-get val 1))) stronger-exps (... ...))))
stronger-exps val
(... ...)) (let ([w (opt-wrap-maker val contract/info)])
(is-stronger? (opt-wrap-get val 0) (opt-wrap-set w j free-var) (... ...)
(- i 1) w))]
free-var (... ...))))] [(or (raw-predicate val)
[else #f])))) (wrap-predicate val))
(cons (let ([w (opt-wrap-maker val contract/info)])
helper-id-var (opt-wrap-set w j free-var) (... ...)
(syntax w)]
(λ (val info free-var (... ...))
(let ([ctc (opt-contract/info-contract info)]
[pos (opt-contract/info-pos info)]
[neg (opt-contract/info-neg info)]
[src-info (opt-contract/info-src-info info)]
[orig-str (opt-contract/info-orig-str info)])
(cond
;; FIXME terribly broken
[(base-pred val) val]
[else [else
(begin
(unless (or (wrap-predicate val)
(opt-wrap-predicate val)
(raw-predicate val))
(raise-contract-error (raise-contract-error
val val
src-info src-info
@ -501,29 +461,13 @@ it around flattened out.
orig-str orig-str
"expected <~a>, got ~e" "expected <~a>, got ~e"
((name-get ctc) ctc) ((name-get ctc) ctc)
val)) val)]))
(cond lifts
;; this is where the optimized stronger needs to be called. superlifts
[(is-stronger? val 5 free-var (... ...)) partials
val]
;; ALLOCATE OPT-WRAP
[else
(let ([w (opt-wrap-maker val info)])
(opt-wrap-set w j free-var) (... ...)
w)]))])))))
(cons enforcer-id-var enforcer)))
(list (cons contract/info-var
(syntax
(make-opt-contract/info ctc
enforcer-id
pos
neg
src-info
orig-str))))
#f #f
#f #f
stronger-ribs)))))])) stronger-ribs)))))))]))
)))])) )))]))
(define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs)
@ -550,7 +494,7 @@ it around flattened out.
[else (apply build-compound-type-name name/dc fields)]))])) [else (apply build-compound-type-name name/dc fields)]))]))
(define-struct contract/info (contract pos neg src-info orig-str)) (define-struct contract/info (contract pos neg src-info orig-str))
(define-struct opt-contract/info (contract enforcer pos neg src-info orig-str)) (define-struct opt-contract/info (contract enforcer id))
;; parents : (listof wrap-parent) ;; parents : (listof wrap-parent)
;; vals : hash-table[symbol -o> (union (make-unknown proc[field-vals -> any]) any) ;; vals : hash-table[symbol -o> (union (make-unknown proc[field-vals -> any]) any)

18
collects/mzlib/private/contract-opt-guts.ss
View File

@ -20,7 +20,8 @@
opt/info-this opt/info-this
opt/info-that opt/info-that
opt/info-swap-blame) opt/info-swap-blame
opt/info-change-val)
;; a hash table of opters ;; a hash table of opters
(define opters-table (define opters-table
@ -70,6 +71,21 @@
(that (opt/info-that info))) (that (opt/info-that info)))
(make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that))) (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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;

116
collects/mzlib/private/contract-opt.ss
View File

@ -7,7 +7,7 @@
(lib "stxparam.ss") (lib "stxparam.ss")
(lib "list.ss")) (lib "list.ss"))
(provide opt/c define-opt/c define/opter define/osc opt-stronger-vars-ref) (provide opt/c define-opt/c define/opter opt-stronger-vars-ref)
;; define/opter : id -> syntax ;; define/opter : id -> syntax
;; ;;
@ -146,7 +146,7 @@
(module-identifier=? (syntax-parameter-value #'define/opt-recursive-fn) (module-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
#'f)) #'f))
(values (values
#`(f #,(opt/info-val opt/info) arg ...) #`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
null null
null null
null null
@ -157,129 +157,53 @@
(opt/unknown opt/i opt/info stx)])) (opt/unknown opt/i opt/info stx)]))
(syntax-case stx () (syntax-case stx ()
[(_ e) [(_ e) #'(opt/c e ())]
[(_ e (opt-recursive-args ...))
(let*-values ([(info) (make-opt/info #'ctc (let*-values ([(info) (make-opt/info #'ctc
#'val #'val
#'pos #'pos
#'neg #'neg
#'src-info #'src-info
#'orig-str #'orig-str
null (syntax->list #'(opt-recursive-args ...))
#f #f
#f #f
#'this #'this
#'that)] #'that)]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)]) [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
(with-syntax ([next next]) (with-syntax ([next next])
(let ([superlifts2
(if (syntax-parameter-value #'define/opt-recursive-fn)
(cons (cons
(syntax-parameter-value #'define/opt-recursive-fn)
(with-syntax ([(args ...)
(syntax-parameter-value #'define/opt-recursive-args)])
#'(lambda (val info args ...) 'next)))
superlifts)
superlifts)])
(bind-superlifts (bind-superlifts
superlifts2 superlifts
(bind-lifts (bind-lifts
lifts lifts
#`(make-opt-contract #`(make-opt-contract
(λ (ctc) (λ (ctc)
(λ (pos neg src-info orig-str) (λ (pos neg src-info orig-str)
#,(bind-lifts #,(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 ...))))
(bind-superlifts
partials partials
#`(λ (val) #`(λ (val) next)))))
next))))
(λ () e) (λ () e)
(λ (this that) #f) (λ (this that) #f)
(vector) (vector)
(begin-lifted (box #f))))))))])) (begin-lifted (box #f)))))))]))
(define-syntax-parameter define/opt-recursive-fn #f) (define-syntax-parameter define/opt-recursive-fn #f)
(define-syntax-parameter define/opt-recursive-args #f)
(define-syntax (define-opt/c stx) (define-syntax (define-opt/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ (id args ...) body) [(_ (id args ...) body)
#'(define (id args ...) #'(define (id args ...)
(syntax-parameterize ([define/opt-recursive-fn #'id] (syntax-parameterize ([define/opt-recursive-fn #'id])
[define/opt-recursive-args #'(args ...)]) (opt/c body (args ...))))]))
(opt/c body)))]))
;; define/osc : syntax -> syntax
;; define/osc allows you define optimized recursive contracts, and must be used
;; to define struct contracts.
(define-syntax (define/osc stx)
;; opt/i : id opt/info syntax ->
;; syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
;;
;; this is different from opt/i only in the aspect that it calls the recursive-call opter
;; if it recognizes a recursive call.
(define (opt/i opt/info stx)
(syntax-case stx ()
[(ctc arg ...)
(and (identifier? #'ctc) (or (opter #'ctc)
(module-identifier=? (opt/info-recf opt/info) #'ctc)))
(if (module-identifier=? (opt/info-recf opt/info) #'ctc)
;; this is a recursive call
(opt/recursive-call opt/info stx)
((opter #'ctc) opt/i opt/info stx))]
[argless-ctc
(and (identifier? #'argless-ctc) (opter #'argless-ctc))
((opter #'argless-ctc) opt/i opt/info stx)]
[else
(opt/unknown opt/i opt/info stx)]))
(syntax-case stx ()
[(_ (f arg ...) base-pred e)
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'pos
#'neg
#'src-info
#'orig-str
(syntax->list (syntax (arg ...)))
#'f
#'base-pred
#'this
#'that)]
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
(with-syntax ((next next)
((superlift ...) (map (λ (x) (with-syntax ((var (car x))
(e (cdr x)))
(syntax (define var e)))) superlifts))
((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) values))
((stronger-var ...) (map stronger-rib-save-id stronger-ribs)))
#`(begin
;; superlifts are defines
superlift ...
(define (f arg ...)
#,(bind-lifts
lifts
#`(make-opt-contract
(λ (ctc)
(λ (pos neg src-info orig-str)
#,(bind-lifts
partials
#`(λ (val) (if (base-pred val)
val
next)))))
(λ () e)
(λ (this that)
(let ([stronger-that-var (vector-ref (opt-contract-stronger-vars that) stronger-indexes)]
...
[stronger-this-var (vector-ref (opt-contract-stronger-vars this) stronger-indexes)]
...)
(and stronger-exps ...)))
(vector stronger-var ...)
(begin-lifted (box #f))))))))]))
;; optimized contracts ;; optimized contracts
;; ;;

12
collects/mzlib/private/contract.ss
View File

@ -1288,9 +1288,14 @@ add struct contracts for immutable structs?
(and (number? x) (and (number? x)
(<= n x m)))))))) (<= n x m))))))))
(define (check-unary-between/c sym x) (define-syntax (check-unary-between/c stx)
(syntax-case stx ()
[(_ 'sym x-exp)
(identifier? #'sym)
#'(let ([x x-exp])
(unless (number? x) (unless (number? x)
(error sym "expected a number, got ~e" x))) (error 'sym "expected a number, got ~e" x)))]))
(define (=/c x) (define (=/c x)
(check-unary-between/c '=/c x) (check-unary-between/c '=/c x)
(make-between/c x x)) (make-between/c x x))
@ -1377,7 +1382,8 @@ add struct contracts for immutable structs?
(this (opt/info-this opt/info)) (this (opt/info-this opt/info))
(that (opt/info-that opt/info))) (that (opt/info-that opt/info)))
(values (values
(syntax (if (and (number? val) (comparison val m)) (syntax
(if (and (number? val) (comparison val m))
val val
(raise-contract-error (raise-contract-error
val val

196
collects/tests/mzscheme/contract-test.ss
View File

@ -3552,6 +3552,202 @@
((couple-tl (contract c x 'pos 'neg)) -11))) ((couple-tl (contract c x 'pos 'neg)) -11)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing define-opt/c
;;
(contract-eval '(define-contract-struct node (val obj rank left right) (make-inspector)))
(contract-eval '(define (compute-rank n)
(cond
[(not n) 0]
[else (node-rank n)])))
(contract-eval '(define-opt/c (leftist-heap-greater-than/rank/opt n r)
(or/c not
(node/dc [val (>=/c n)]
[obj any/c]
[rank (<=/c r)]
[left (val) (leftist-heap-greater-than/rank/opt val +inf.0)]
[right (val left) (leftist-heap-greater-than/rank/opt val (compute-rank left))]))))
(contract-eval '(define leftist-heap/c (leftist-heap-greater-than/rank/opt -inf.0 +inf.0)))
(test/pos-blame 'd-o/c1 '(contract leftist-heap/c 2 'pos 'neg))
(test/spec-passed 'd-o/c2 '(contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg))
(test/spec-passed 'd-o/c3 '(contract leftist-heap/c #f 'pos 'neg))
(test/spec-passed 'd-o/c4 '(contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg))
(test/spec-passed/result 'd-o/c5
'(node? (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg))
#t)
(test/spec-passed/result 'd-o/c6 '(node-val (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) 1)
(test/spec-passed/result 'd-o/c7 '(node-obj (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) 2)
(test/spec-passed/result 'd-o/c8 '(node-rank (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) 3)
(test/spec-passed/result 'd-o/c9 '(node-left (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) #f)
(test/spec-passed/result 'd-o/c10 '(node-right (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)) #f)
(test/spec-passed/result 'd-o/c11
'(node-val (contract leftist-heap/c
(contract leftist-heap/c
(make-node 1 2 3 #f #f)
'pos 'neg)
'pos 'neg))
1)
(test/spec-passed/result 'd-o/c12
'(node-obj (contract leftist-heap/c
(contract leftist-heap/c
(make-node 1 2 3 #f #f)
'pos 'neg)
'pos 'neg))
2)
(test/spec-passed/result 'd-o/c13
'(node-rank (contract leftist-heap/c
(contract leftist-heap/c
(make-node 1 2 3 #f #f)
'pos 'neg)
'pos 'neg))
3)
(test/spec-passed/result 'd-o/c14
'(node-left (contract leftist-heap/c
(contract leftist-heap/c
(make-node 1 2 3 #f #f)
'pos 'neg)
'pos 'neg))
#f)
(test/spec-passed/result 'd-o/c15
'(node-right (contract leftist-heap/c
(contract leftist-heap/c
(make-node 1 2 3 #f #f)
'pos 'neg)
'pos 'neg))
#f)
(test/spec-passed/result 'd-o/c16
'(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)])
(node-val h)
(node-val h))
1)
(test/spec-passed/result 'd-o/c17
'(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)])
(node-obj h)
(node-obj h))
2)
(test/spec-passed/result 'd-o/c18
'(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f)'pos 'neg)])
(node-rank h)
(node-rank h))
3)
(test/spec-passed/result 'd-o/c19
'(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)])
(node-left h)
(node-left h))
#f)
(test/spec-passed/result 'd-o/c20
'(let ([h (contract leftist-heap/c (make-node 1 2 3 #f #f) 'pos 'neg)])
(node-right h)
(node-right h))
#f)
(test/spec-passed/result 'd-o/c21
'(node-val
(node-right
(contract leftist-heap/c
(make-node 1 2 3
(make-node 7 8 9 #f #f)
(make-node 4 5 6 #f #f))
'pos 'neg)))
4)
(test/spec-passed/result 'd-o/c22
'(node-val
(node-left
(contract leftist-heap/c
(make-node 1 2 3
(make-node 7 8 9 #f #f)
(make-node 4 5 6 #f #f))
'pos 'neg)))
7)
(test/pos-blame 'd-o/c23
'(node-val
(node-right
(contract leftist-heap/c
(make-node 5 2 3
(make-node 7 8 9 #f #f)
(make-node 4 5 6 #f #f))
'pos 'neg))))
(test/pos-blame 'd-o/c24
'(node-val
(node-left
(contract leftist-heap/c
(make-node 9 2 3
(make-node 7 8 9 #f #f)
(make-node 11 5 6 #f #f))
'pos 'neg))))
(test/neg-blame 'd-o/c25
'((contract (-> leftist-heap/c any)
(λ (kh)
(node-val
(node-left
kh)))
'pos 'neg)
(make-node 9 2 3
(make-node 7 8 9 #f #f)
(make-node 11 5 6 #f #f))))
(test/spec-passed/result
'd-o/c26
'(let ([ai (λ (x) (contract leftist-heap/c x 'pos 'neg))])
(define (remove-min t) (merge (node-left t) (node-right t)))
(define (merge t1 t2)
(cond
[(not t1) t2]
[(not t2) t1]
[else
(let ([t1-val (node-val t1)]
[t2-val (node-val t2)])
(cond
[(<= t1-val t2-val)
(pick t1-val
(node-obj t1)
(node-left t1)
(merge (node-right t1)
t2))]
[else
(pick t2-val
(node-obj t2)
(node-left t2)
(merge t1
(node-right t2)))]))]))
(define (pick x obj a b)
(let ([ra (compute-rank a)]
[rb (compute-rank b)])
(cond
[(>= ra rb)
(make-node x obj (+ rb 1) a b)]
[else
(make-node x obj (+ ra 1) b a)])))
(node-val
(remove-min (ai (make-node 137 'x 1
(ai (make-node 178 'y 1
(make-node 178 'z 1 #f #f)
#f))
#f)))))
178)
;;
;; end of define-opt/c
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; NOT YET RELEASED ;; NOT YET RELEASED
#; #;