added define-opt/c
svn: r5515
This commit is contained in:
Robby Findler
parent
0610ffdd41
commit
81ce545d63
|
|
@ -9,7 +9,7 @@
|
|||
"private/contract-basic-opters.ss")
|
||||
|
||||
(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"
|
||||
lazy-depth-to-look)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
helper-id helper-info helper-freev)
|
||||
(define (opt/enforcer-clause stx)
|
||||
(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 #,(opt/info-val opt/info) arg ...)
|
||||
#`(f #,id arg ...)
|
||||
null
|
||||
null
|
||||
null
|
||||
#f
|
||||
#f
|
||||
null)]
|
||||
#;
|
||||
[(f arg ...)
|
||||
;; 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)]))
|
||||
[else (opt/i (opt/info-change-val id opt/info)
|
||||
stx)]))
|
||||
|
||||
(let* ([field-names
|
||||
(map (λ (clause)
|
||||
|
|
@ -197,21 +183,21 @@ which are then called when the contract's fields are explored
|
|||
(and (identifier? (syntax id))
|
||||
(andmap identifier? (syntax->list (syntax (x ...)))))
|
||||
(let*-values ([(next lifts superlifts partials _ _2 _3)
|
||||
(opt/enforcer-clause (syntax ctc-exp))]
|
||||
(opt/enforcer-clause let-var (syntax ctc-exp))]
|
||||
[(maker-arg)
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
((arg ...) arglist)
|
||||
[(new-let-vars ...) (match-up (reverse prior-ac-ids)
|
||||
(with-syntax ([val (opt/info-val opt/info)]
|
||||
[(new-let-bindings ...)
|
||||
(match-up/bind (reverse prior-ac-ids)
|
||||
(syntax (x ...))
|
||||
field-names)])
|
||||
field-names
|
||||
arglist)])
|
||||
#`(#,let-var
|
||||
#,(bind-lifts
|
||||
superlifts
|
||||
#`(let ([new-let-vars arg] ...)
|
||||
#`(let (new-let-bindings ...)
|
||||
#,(bind-lifts
|
||||
(append lifts partials)
|
||||
#`(let ((val #,let-var))
|
||||
#,next))))))])
|
||||
next)))))])
|
||||
(loop (cdr clauses)
|
||||
(cdr let-vars)
|
||||
(cdr arglists)
|
||||
|
|
@ -231,14 +217,13 @@ which are then called when the contract's fields are explored
|
|||
[(id ctc-exp)
|
||||
(identifier? (syntax id))
|
||||
(let*-values ([(next lifts superlifts partials _ __ stronger-ribs)
|
||||
(opt/enforcer-clause (syntax ctc-exp))]
|
||||
(opt/enforcer-clause let-var (syntax ctc-exp))]
|
||||
[(maker-arg)
|
||||
(with-syntax ((val (opt/info-val opt/info)))
|
||||
#`(#,let-var
|
||||
#,(bind-lifts
|
||||
partials
|
||||
#`(let ((val #,let-var))
|
||||
#,next))))])
|
||||
next)))])
|
||||
(loop (cdr clauses)
|
||||
(cdr let-vars)
|
||||
(cdr arglists)
|
||||
|
|
@ -282,6 +267,31 @@ which are then called when the contract's fields are explored
|
|||
[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]
|
||||
|
|
|
|||
|
|
@ -19,7 +19,8 @@ it around flattened out.
|
|||
(module contract-ds mzscheme
|
||||
(require "contract-guts.ss"
|
||||
"contract-opt.ss"
|
||||
"contract-ds-helpers.ss")
|
||||
"contract-ds-helpers.ss"
|
||||
(lib "etc.ss"))
|
||||
(require-for-syntax "contract-ds-helpers.ss"
|
||||
"contract-helpers.ss"
|
||||
"contract-opt-guts.ss"
|
||||
|
|
@ -28,12 +29,10 @@ it around flattened out.
|
|||
(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
|
||||
opt-contract/info-pos
|
||||
opt-contract/info-neg
|
||||
opt-contract/info-src-info
|
||||
opt-contract/info-orig-str
|
||||
lazy-depth-to-look
|
||||
|
||||
unknown?
|
||||
|
|
@ -350,17 +349,7 @@ it around flattened out.
|
|||
(let*-values ([(inner-val) #'val]
|
||||
[(clauses lifts superlifts stronger-ribs)
|
||||
(build-enforcer-clauses opt/i
|
||||
(make-opt/info #'ctc
|
||||
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))
|
||||
(opt/info-change-val inner-val opt/info)
|
||||
name
|
||||
stx
|
||||
clauses
|
||||
|
|
@ -372,33 +361,16 @@ it around flattened out.
|
|||
(with-syntax ([(clause (... ...)) clauses]
|
||||
[enforcer-id enforcer-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)])
|
||||
(values
|
||||
#`(λ (stct f-x ...)
|
||||
(let* ([info (opt-wrap-get stct 1)]
|
||||
[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
|
||||
(let ((free-var free-var-val) (... ...))
|
||||
#,(bind-lifts
|
||||
lifts
|
||||
#`(let-syntax #,(if (opt/info-recf opt/info)
|
||||
#`([#,(opt/info-recf opt/info)
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(f val args ((... ...) (... ...)))
|
||||
#'(helper-id val
|
||||
info
|
||||
args
|
||||
((... ...) (... ...))
|
||||
saved-lifts (... ...))]))])
|
||||
#`())
|
||||
(let* (clause (... ...))
|
||||
(values f-x ...)))))))
|
||||
#'(let* (clause (... ...))
|
||||
(values f-x ...)))))
|
||||
lifts
|
||||
superlifts
|
||||
stronger-ribs))))
|
||||
|
|
@ -411,7 +383,8 @@ it around flattened out.
|
|||
[(_ 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))))))
|
||||
(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
|
||||
|
|
@ -430,33 +403,34 @@ it around flattened out.
|
|||
(src-info (opt/info-src-info opt/info))
|
||||
(orig-str (opt/info-orig-str opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(base-pred (or (opt/info-base-pred opt/info) #'(λ (x) #f)))
|
||||
(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))
|
||||
(values
|
||||
(syntax (helper-id val contract/info free-var (... ...)))
|
||||
lifts
|
||||
(append
|
||||
superlifts
|
||||
(list (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
|
||||
(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)])
|
||||
(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
|
||||
[(= i 0) #f]
|
||||
[(and (opt-wrap-predicate val)
|
||||
(opt-wrap-get val 0))
|
||||
[(opt-wrap-predicate val)
|
||||
(if (and (opt-wrap-get val 0)
|
||||
(let ([stronger-this-var stronger-var]
|
||||
(... ...)
|
||||
|
||||
|
|
@ -465,35 +439,21 @@ it around flattened out.
|
|||
;; saved in the wrapper are the same
|
||||
[stronger-that-var (opt-wrap-get val stronger-indexes)]
|
||||
(... ...))
|
||||
|
||||
(or (and
|
||||
(and
|
||||
;; make sure this is the same contract -- if not,
|
||||
;; the rest of this test is bogus and may fail at runtime
|
||||
(eq? enforcer-id (opt-contract/info-enforcer
|
||||
(opt-wrap-get val 1)))
|
||||
stronger-exps
|
||||
(... ...))
|
||||
(is-stronger? (opt-wrap-get val 0)
|
||||
(- i 1)
|
||||
free-var (... ...))))]
|
||||
[else #f]))))
|
||||
(cons
|
||||
helper-id-var
|
||||
(syntax
|
||||
(λ (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]
|
||||
(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
|
||||
(begin
|
||||
(unless (or (wrap-predicate val)
|
||||
(opt-wrap-predicate val)
|
||||
(raw-predicate val))
|
||||
(raise-contract-error
|
||||
val
|
||||
src-info
|
||||
|
|
@ -501,29 +461,13 @@ it around flattened out.
|
|||
orig-str
|
||||
"expected <~a>, got ~e"
|
||||
((name-get ctc) ctc)
|
||||
val))
|
||||
(cond
|
||||
;; this is where the optimized stronger needs to be called.
|
||||
[(is-stronger? val 5 free-var (... ...))
|
||||
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))))
|
||||
val)]))
|
||||
lifts
|
||||
superlifts
|
||||
partials
|
||||
#f
|
||||
#f
|
||||
stronger-ribs)))))]))
|
||||
|
||||
stronger-ribs)))))))]))
|
||||
)))]))
|
||||
|
||||
(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)]))]))
|
||||
|
||||
(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)
|
||||
;; vals : hash-table[symbol -o> (union (make-unknown proc[field-vals -> any]) any)
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@
|
|||
opt/info-this
|
||||
opt/info-that
|
||||
|
||||
opt/info-swap-blame)
|
||||
opt/info-swap-blame
|
||||
opt/info-change-val)
|
||||
|
||||
;; a hash table of opters
|
||||
(define opters-table
|
||||
|
|
@ -70,6 +71,21 @@
|
|||
(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)))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
(lib "stxparam.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
|
||||
;;
|
||||
|
|
@ -146,7 +146,7 @@
|
|||
(module-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
|
||||
#'f))
|
||||
(values
|
||||
#`(f #,(opt/info-val opt/info) arg ...)
|
||||
#`(#,(syntax-parameter-value #'define/opt-recursive-fn) #,(opt/info-val opt/info) arg ...)
|
||||
null
|
||||
null
|
||||
null
|
||||
|
|
@ -157,129 +157,53 @@
|
|||
(opt/unknown opt/i opt/info stx)]))
|
||||
|
||||
(syntax-case stx ()
|
||||
[(_ e)
|
||||
[(_ e) #'(opt/c e ())]
|
||||
[(_ e (opt-recursive-args ...))
|
||||
(let*-values ([(info) (make-opt/info #'ctc
|
||||
#'val
|
||||
#'pos
|
||||
#'neg
|
||||
#'src-info
|
||||
#'orig-str
|
||||
null
|
||||
(syntax->list #'(opt-recursive-args ...))
|
||||
#f
|
||||
#f
|
||||
#'this
|
||||
#'that)]
|
||||
[(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
|
||||
(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
|
||||
superlifts2
|
||||
superlifts
|
||||
(bind-lifts
|
||||
lifts
|
||||
#`(make-opt-contract
|
||||
(λ (ctc)
|
||||
(λ (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
|
||||
#`(λ (val)
|
||||
next))))
|
||||
#`(λ (val) next)))))
|
||||
(λ () e)
|
||||
(λ (this that) #f)
|
||||
(vector)
|
||||
(begin-lifted (box #f))))))))]))
|
||||
(begin-lifted (box #f)))))))]))
|
||||
|
||||
(define-syntax-parameter define/opt-recursive-fn #f)
|
||||
(define-syntax-parameter define/opt-recursive-args #f)
|
||||
|
||||
(define-syntax (define-opt/c stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id args ...) body)
|
||||
#'(define (id args ...)
|
||||
(syntax-parameterize ([define/opt-recursive-fn #'id]
|
||||
[define/opt-recursive-args #'(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))))))))]))
|
||||
(syntax-parameterize ([define/opt-recursive-fn #'id])
|
||||
(opt/c body (args ...))))]))
|
||||
|
||||
;; optimized contracts
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -1288,9 +1288,14 @@ add struct contracts for immutable structs?
|
|||
(and (number? x)
|
||||
(<= 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)
|
||||
(error sym "expected a number, got ~e" x)))
|
||||
(error 'sym "expected a number, got ~e" x)))]))
|
||||
|
||||
(define (=/c x)
|
||||
(check-unary-between/c '=/c x)
|
||||
(make-between/c x x))
|
||||
|
|
@ -1377,7 +1382,8 @@ add struct contracts for immutable structs?
|
|||
(this (opt/info-this opt/info))
|
||||
(that (opt/info-that opt/info)))
|
||||
(values
|
||||
(syntax (if (and (number? val) (comparison val m))
|
||||
(syntax
|
||||
(if (and (number? val) (comparison val m))
|
||||
val
|
||||
(raise-contract-error
|
||||
val
|
||||
|
|
|
|||
|
|
@ -3552,6 +3552,202 @@
|
|||
((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
|
||||
#;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user