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

added first stages of improvments to contract library to support lazy structure contracts. not yet complete, but contract system is in working order, so committing

Browse Source 
svn: r2452
This commit is contained in:
Robby Findler 2006-03-18 05:33:08 +00:00
parent 812a6cb4fe
commit d8217b9d27
10 changed files with 1135 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/errortrace/zo-compile.ss
View File

@ -9,7 +9,9 @@
(lambda (stx immediate-eval?) (lambda (stx immediate-eval?)
(if (null? (use-compiled-file-paths)) (if (null? (use-compiled-file-paths))
(orig stx immediate-eval?) (orig stx immediate-eval?)
(orig (errortrace-annotate stx) immediate-eval?)))))) (parameterize ([profiling-enabled #t])
(fprintf (current-error-port) "file ~s\n" (syntax-source stx))
(orig (errortrace-annotate stx) immediate-eval?)))))))

4
collects/mzlib/contract.ss
View File

@ -1,10 +1,12 @@
(module contract mzscheme (module contract mzscheme
(require "private/contract.ss" (require "private/contract.ss"
"private/contract-arrow.ss" "private/contract-arrow.ss"
"private/contract-util.ss") "private/contract-util.ss"
"private/contract-ds.ss")
(provide (provide
(all-from "private/contract-ds.ss")
(all-from "private/contract-arrow.ss") (all-from "private/contract-arrow.ss")
(all-from-except "private/contract-util.ss" (all-from-except "private/contract-util.ss"
raise-contract-error raise-contract-error

183
collects/mzlib/private/contract-ds-helpers.ss Normal file
View File

@ -0,0 +1,183 @@
(module contract-ds-helpers mzscheme
(provide ensure-well-formed
build-func-params
build-clauses
generate-arglists)
(require (lib "list.ss"))
(require-for-template mzscheme)
#|
With this definition:
(define-contract s (a b c))
this:
(s/dc [x e-x]
[y () e-y]
[z (x y) e-z])
expands into procedures & structs like this:
(let ([c-x e-x]
[c-y (lambda (_) e-y)]
[c-z (lambda (x y) e-z)])
... c-* variables get put into the contract struct ...
which are then called when the contract's fields are explored
|#
(define (build-clauses name stx clauses)
(let* ([field-names
(map (λ (clause)
(syntax-case clause ()
[(id . whatever) (syntax id)]
[else (raise-syntax-error name
"expected a field name at the beginning of a sequence"
stx
clause)]))
(syntax->list clauses))]
[all-ac-ids (generate-temporaries field-names)])
(let loop ([clauses (syntax->list clauses)]
[ac-ids all-ac-ids]
[prior-ac-ids '()]
[maker-args '()])
(cond
[(null? clauses)
(reverse maker-args)]
[else
(let ([clause (car clauses)]
[ac-id (car ac-ids)])
(syntax-case clause ()
[(id (x ...) ctc-exp)
(and (identifier? (syntax id))
(andmap identifier? (syntax->list (syntax (x ...)))))
(let ([maker-arg #`(λ #,(match-up (reverse prior-ac-ids)
(syntax (x ...))
field-names)
ctc-exp)])
(loop (cdr clauses)
(cdr ac-ids)
(cons (car ac-ids) prior-ac-ids)
(cons maker-arg maker-args)))]
[(id (x ...) ctc-exp)
(begin
(unless (identifier? (syntax id))
(raise-syntax-error name "expected identifier" stx (syntax id)))
(for-each (λ (x) (unless (identifier? x)
(raise-syntax-error name "expected identifier" stx x)))
(syntax->list (syntax (x ...)))))]
[(id ctc-exp)
(identifier? (syntax id))
(loop (cdr clauses)
(cdr ac-ids)
(cons (car ac-ids) prior-ac-ids)
(cons (syntax ctc-exp) maker-args))]
[(id ctc-exp)
(raise-syntax-error name "expected identifier" stx (syntax id))]))]))))
;; generate-arglists : (listof X) -> (listof (listof X))
;; produces the list of arguments to the dependent contract
;; functions, given the names of some variables.
;; eg: (generate-arglists '(x y z w))
;; = (list '() '(x) '(x y) '(x y z))
(define (generate-arglists vars)
(reverse
(let loop ([vars (reverse vars)])
(cond
[(null? vars) null]
[else (cons (reverse (cdr vars))
(loop (cdr vars)))]))))
(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]
[field-names field-names])
(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 id-used
(loop (cdr prior-ac-ids)
(cdr field-names)))
(cons (car (generate-temporaries '(ignored-arg)))
(loop (cdr prior-ac-ids)
(cdr field-names)))))]))))
(define (sort-wrt name stx ids current-order-field-names desired-order-field-names)
(let ([id/user-specs (map cons ids current-order-field-names)]
[ht (make-hash-table)])
(let loop ([i 0]
[orig-field-names desired-order-field-names])
(unless (null? orig-field-names)
(hash-table-put! ht (syntax-e (car orig-field-names)) i)
(loop (+ i 1) (cdr orig-field-names))))
(let* ([lookup
(λ (id-pr)
(let ([id (car id-pr)]
[use-field-name (cdr id-pr)])
(hash-table-get ht
(syntax-e use-field-name)
(λ ()
(raise-syntax-error name "unknown field name" stx use-field-name)))))]
[cmp (λ (x y) (<= (lookup x) (lookup y)))]
[sorted-id/user-specs (quicksort id/user-specs cmp)])
(map car sorted-id/user-specs))))
(define (find-matching all-ac-ids chosen-ids field-names)
(map (λ (chosen-id)
(let* ([chosen-sym (syntax-e chosen-id)]
[id (ormap (λ (ac-id field-name)
(and (eq? (syntax-e field-name) chosen-sym)
ac-id))
all-ac-ids
field-names)])
(unless id
(error 'find-matching "could not find matching for ~s" chosen-id))
id))
(syntax->list chosen-ids)))
(define (build-func-params ids)
(let ([temps (generate-temporaries ids)])
(let loop ([ids (syntax->list ids)]
[temps temps]
[can-refer-to '()])
(cond
[(null? ids) null]
[else (cons
(append (reverse can-refer-to) temps)
(loop (cdr ids)
(cdr temps)
(cons (car ids) can-refer-to)))]))))
(define (ensure-well-formed stx field-count)
(syntax-case stx ()
[(_ [id exp] ...)
(and (andmap identifier? (syntax->list (syntax (id ...))))
(equal? (length (syntax->list (syntax (id ...))))
field-count))
(void)]
[(_ [id exp] ...)
(andmap identifier? (syntax->list (syntax (id ...))))
(raise-syntax-error 'struct/dc
(format "expected ~a clauses, but found ~a"
field-count
(length (syntax->list (syntax (id ...)))))
stx)]
[(_ [id exp] ...)
(for-each
(λ (id) (unless (identifier? id) (raise-syntax-error 'struct/dc "expected identifier" stx id)))
(syntax->list (syntax (id ...))))])))

211
collects/mzlib/private/contract-ds.ss Normal file
View File

@ -0,0 +1,211 @@
(module contract-ds mzscheme
(require "contract-util.ss"
"same-closure.ss")
(require-for-syntax "contract-ds-helpers.ss"
"contract-helpers.scm")
(provide define-contract-struct)
(define-syntax (define-contract-struct stx)
(syntax-case stx ()
[(_ name (fields ...))
(syntax (define-contract-struct name (fields ...) (current-inspector)))]
[(_ name (fields ...) inspector)
(and (identifier? (syntax name))
(andmap identifier? (syntax->list (syntax (fields ...)))))
(let* ([add-suffix
(λ (suffix)
(datum->syntax-object (syntax name)
(string->symbol
(string-append (symbol->string (syntax-e (syntax name)))
suffix))
stx))]
[struct-names (build-struct-names (syntax name)
(syntax->list (syntax (fields ...)))
#f
#t
stx)]
[struct:-name (list-ref struct-names 0)]
[struct-maker/val (list-ref struct-names 1)]
[predicate/val (list-ref struct-names 2)]
[selectors/val (cdddr struct-names)]
[struct/c-name/val (add-suffix "/c")]
[struct/dc-name/val(add-suffix "/dc")]
[field-count/val (length selectors/val)]
[f-x/vals (generate-temporaries (syntax (fields ...)))])
(with-syntax ([struct/c struct/c-name/val]
[struct/dc struct/dc-name/val]
[field-count field-count/val]
[(selectors ...) selectors/val]
[struct-maker struct-maker/val]
[predicate predicate/val]
[contract-name (add-suffix "-contract")]
[(selector-indicies ...) (nums-up-to field-count/val)]
[(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))]
[(ctc-x ...) (generate-temporaries (syntax (fields ...)))]
[(f-x ...) f-x/vals]
[((f-xs ...) ...) (generate-arglists f-x/vals)]
[wrap-name (string->symbol (format "~a-wrap" (syntax-e (syntax name))))])
#`
(begin
(define-values (wrap-type wrap-maker wrap-predicate wrap-get wrap-set)
(make-struct-type 'wrap-name
#f ;; super struct
2 ;; field count
(- field-count 1) ;; auto-field-k
#f ;; auto-field-v
'() ;; prop-value-list
inspector))
(define-values (type struct-maker raw-predicate get set)
(make-struct-type 'name
#f ;; super struct
field-count
0 ;; auto-field-k
'() ;; auto-field-v
'() ;; prop-value-list
inspector))
(define (predicate x) (or (raw-predicate x) (wrap-predicate x)))
(define-syntax (struct/dc stx)
;(ensure-well-formed stx field-count)
(syntax-case stx ()
[(_ clause (... ...))
(with-syntax ([(maker-args (... ...))
(build-clauses 'struct/dc
stx
(syntax (clause (... ...))))])
(syntax (contract-maker maker-args (... ...))))]))
(define (do-selection stct i+1)
(let-values ([(stct fields ...)
(let loop ([stct stct])
(cond
[(raw-predicate stct)
;; found the original value
(values #f (get stct selector-indicies) ...)]
[(wrap-get stct 0)
;; we have a contract to update
(let-values ([(_1 fields ...) (loop (wrap-get stct 0))])
(let-values ([(fields ...)
(rewrite-fields (wrap-get stct 1) fields ...)])
(wrap-set stct 0 #f)
(wrap-set stct selector-indicies+1 fields) ...
(values stct fields ...)))]
[else
;; found a cached version of the value
(values #f (wrap-get stct selector-indicies+1) ...)]))])
(wrap-get stct i+1)))
(define (rewrite-fields stct ctc-x ...)
(let* ([f-x (let ([ctc-field (contract-get stct selector-indicies)])
(let ([ctc (if (procedure? ctc-field)
(ctc-field f-xs ...)
ctc-field)])
(((proj-get ctc) ctc) ctc-x)))] ...)
(values f-x ...)))
(define (stronger-lazy-contract? a b)
(and (contract-predicate b)
(check-sub-contract?
(contract-get a selector-indicies)
(contract-get b selector-indicies)) ...))
(define (lazy-contract-proj ctc)
(λ (val)
(unless (or (wrap-predicate val)
(raw-predicate val))
(blame (format "expected <~a>, got ~e" 'name val)))
(cond
[(already-there? ctc val lazy-depth-to-look)
val]
[else
(wrap-maker val ctc)])))
(define (already-there? ctc val depth)
(cond
[(raw-predicate val) #f]
[(zero? depth) #f]
[(wrap-get val 0)
(if (contract-stronger? (wrap-get val 1) ctc)
#t
(already-there? ctc (wrap-get val 0) (- depth 1)))]
[else
;; when the zeroth field is cleared out, we don't
;; have a contract to compare to anymore.
#f]))
(define (struct/c ctc-x ...)
(contract-maker ctc-x ...))
(define (no-depend-apply-to-fields ctc fields ...)
(let ([ctc-x (contract-get ctc selector-indicies)] ...)
(values (((proj-get ctc-x) ctc-x) fields) ...)))
(define (selectors x) (burrow-in x 'selectors selector-indicies)) ...
(define (burrow-in struct selector-name i)
(cond
[(raw-predicate struct)
(get struct i)]
[(wrap-predicate struct)
(if (wrap-get struct 0)
(do-selection struct (+ i 1))
(wrap-get struct (+ i 1)))]
[else
(error selector-name "expected <~a>, got ~e" 'name struct)]))
(define-values (contract-type contract-maker contract-predicate contract-get contract-set)
(make-struct-type 'contract-name
#f
field-count
0 ;; auto-field-k
'() ;; auto-field-v
(list (cons proj-prop lazy-contract-proj)
(cons stronger-prop stronger-lazy-contract?)))))))]))
(define max-cache-size 5)
(define lazy-depth-to-look 5)
(define (check-sub-contract? x y)
(cond
[(and (proj-pred? x) (proj-pred? y))
(contract-stronger? x y)]
[(and (procedure? x) (procedure? y))
(same-closure? x y)]
[else #f]))
#|
test case:
(define-contract-struct s (a b))
this contract:
(s/dc [a (flat number?)]
[b (λ (x) (and (number? x) (< a b)))])
should not signal a less than error for this value:
(make-s #f 2)
but this one:
(s/dc [a (flat boolean?)]
[b (λ (x) (and (number? x) (< a b)))])
should
|#
#|
test-case:
(define-contract-struct s (a b))
(s/dc [x 1])
=> wrong field count exn
|#
)

37
collects/mzlib/private/contract-helpers.scm
View File

@ -1,6 +1,8 @@
(module contract-helpers mzscheme (module contract-helpers mzscheme
(provide module-source-as-symbol build-src-loc-string mangle-id) (provide module-source-as-symbol build-src-loc-string mangle-id
build-struct-names
nums-up-to)
;; mangle-id : syntax string syntax ... -> syntax ;; mangle-id : syntax string syntax ... -> syntax
;; constructs a mangled name of an identifier from an identifier ;; constructs a mangled name of an identifier from an identifier
@ -59,4 +61,35 @@
(if path (if path
(string->symbol (format "~s" path)) (string->symbol (format "~s" path))
'top-level))] 'top-level))]
[else 'top-level])))) [else 'top-level])))
(define build-struct-names
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
(let ([name (symbol->string (syntax-e name-stx))]
[fields (map symbol->string (map syntax-e fields))]
[+ string-append])
(map (lambda (s)
(datum->syntax-object name-stx (string->symbol s) srcloc-stx))
(append
(list
(+ "struct:" name)
(+ "make-" name)
(+ name "?"))
(let loop ([l fields])
(if (null? l)
null
(append
(if omit-sel?
null
(list (+ name "-" (car l))))
(if omit-set?
null
(list (+ "set-" name "-" (car l) "!")))
(loop (cdr l))))))))))
(define (nums-up-to n)
(let loop ([i 0])
(cond
[(= i n) '()]
[else (cons i (loop (+ i 1)))]))))

174
collects/mzlib/private/contract-util.ss
View File

@ -1,14 +1,16 @@
(module contract-util mzscheme (module contract-util mzscheme
(require "contract-helpers.scm" (require "contract-helpers.scm"
"same-closure.ss"
(lib "pretty.ss") (lib "pretty.ss")
(lib "list.ss")) (lib "list.ss"))
(require-for-syntax "contract-helpers.scm")
(provide raise-contract-error (provide raise-contract-error
contract-violation->string contract-violation->string
coerce-contract coerce-contract
coerce/select-contract coerce/select-contract
contract?
contract-name
flat-contract/predicate? flat-contract/predicate?
flat-contract? flat-contract?
flat-contract flat-contract
@ -20,10 +22,82 @@
and/c and/c
any/c any/c
contract?
contract-name
contract-proc contract-proc
make-contract make-contract
build-flat-contract build-flat-contract
make-flat-contract)
define-struct/prop
contract-stronger?
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
flat-proj)
;; define-struct/prop is a define-struct-like macro that
;; also allows properties to be defined
;; it contains copied code (build-struct-names) in order to avoid
;; a module cycle
(define-syntax (define-struct/prop stx)
(let ()
(syntax-case stx ()
[(_ name (field ...) ((property value) ...))
(andmap identifier? (syntax->list (syntax (field ...))))
(let ([struct-names (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#f
#t
stx)]
[struct-names/bangers (build-struct-names (syntax name)
(syntax->list (syntax (field ...)))
#t
#f
stx)]
[field-count/val (length (syntax->list (syntax (field ...))))])
(with-syntax ([struct:-name (list-ref struct-names 0)]
[struct-maker (list-ref struct-names 1)]
[predicate (list-ref struct-names 2)]
[(count ...) (nums-up-to field-count/val)]
[(selectors ...) (cdddr struct-names)]
[(bangers ...) (cdddr struct-names/bangers)]
[field-count field-count/val]
[(field-indicies ...) (nums-up-to (length (syntax->list (syntax (field ...)))))])
(syntax
(begin
(define-values (struct:-name struct-maker predicate get set)
(make-struct-type 'name
#f ;; super
field-count
0 ;; auto-field-k
'()
(list (cons property value) ...)))
(define selectors (make-struct-field-accessor get count 'field))
...
(define bangers (make-struct-field-mutator set count 'field))
...))))])))
(define-values (proj-prop proj-pred? proj-get)
(make-struct-type-property 'contract-projection))
(define-values (name-prop name-pred? name-get)
(make-struct-type-property 'contract-name))
(define-values (stronger-prop stronger-pred? stronger-get)
(make-struct-type-property 'contract-stronger-than))
(define-values (flat-prop flat-pred? flat-get)
(make-struct-type-property 'contract-flat))
;; contract-stronger? : contract contract -> boolean
;; indicates if one contract is stronger (ie, likes fewer values) than another
;; this is not a total order.
(define (contract-stronger? a b)
(let ([a-ctc (coerce-contract contract-stronger? a)]
[b-ctc (coerce-contract contract-stronger? b)])
((stronger-get a-ctc) a-ctc b-ctc)))
;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc ;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc
;; contract-proc = sym sym stx -> alpha -> alpha ;; contract-proc = sym sym stx -> alpha -> alpha
@ -151,8 +225,7 @@
"")) ""))
"")) ""))
;
;
; ;
; ;
; ;
@ -188,28 +261,54 @@
;; the argument to the result function is the value to test. ;; the argument to the result function is the value to test.
;; (the result function is the projection) ;; (the result function is the projection)
;; ;;
(define (flat-proj ctc)
(let ([predicate ((flat-get ctc) ctc)]
[name ((name-get ctc) ctc)])
(λ (pos neg src-info orig-str)
(λ (val)
(if (predicate val)
val
(raise-contract-error
val
src-info
pos
neg
orig-str
"expected <~a>, given: ~e"
name
val))))))
(define-values (make-flat-contract (define-values (make-flat-contract
flat-contract-predicate make-contract)
flat-contract?
make-contract
contract-name
contract-proc
contract?)
(let () (let ()
(define-struct contract (name proc)) (define-struct/prop contract (the-name the-proc)
(define-struct (flat-contract contract) (predicate)) ((proj-prop (λ (ctc) (contract-the-proc ctc)))
(name-prop (λ (ctc) (contract-the-name ctc)))
(stronger-prop (λ (this that)
(and (contract? that)
(same-closure? (contract-the-proc this)
(contract-the-proc that)))))))
(define-struct/prop flat-contract (the-name predicate)
((proj-prop flat-proj)
(stronger-prop (λ (this that)
(and (flat-contract? that)
(same-closure? (flat-contract-predicate this)
(flat-contract-predicate that)))))
(name-prop (λ (ctc) (flat-contract-the-name ctc)))
(flat-prop (λ (ctc) (flat-contract-predicate ctc)))))
(values make-flat-contract (values make-flat-contract
flat-contract-predicate make-contract)))
flat-contract?
make-contract
contract-name
contract-proc
contract?)))
(define (flat-contract-predicate x)
(unless (flat-contract? x)
(error 'flat-contract-predicate "expected a flat contract, got ~e" x))
((flat-get x) x))
(define (flat-contract? x) (flat-pred? x))
(define (contract-name ctc) ((name-get ctc) ctc))
(define (contract? x) (proj-pred? x))
(define (contract-proc ctc) ((proj-get ctc) ctc))
(define (flat-contract predicate) (define (flat-contract predicate)
(unless (and (procedure? predicate) (unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1)) (procedure-arity-includes? predicate 1))
(error 'flat-contract (error 'flat-contract
@ -228,28 +327,11 @@
predicate name)) predicate name))
(build-flat-contract name predicate)) (build-flat-contract name predicate))
(define (build-flat-contract name predicate) (define (build-flat-contract name predicate) (make-flat-contract name predicate))
(make-flat-contract
name
(lambda (pos neg src-info orig-str)
(lambda (val)
(if (predicate val)
val
(raise-contract-error
val
src-info
pos
neg
orig-str
"expected <~a>, given: ~e"
name
val))))
predicate))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs) (define (build-compound-type-name . fs)
(let loop ([subs fs] (let loop ([subs fs])
[i 0])
(cond (cond
[(null? subs) [(null? subs)
'()] '()]
@ -257,8 +339,8 @@
(cond (cond
[(contract? sub) [(contract? sub)
(let ([mk-sub-name (contract-name sub)]) (let ([mk-sub-name (contract-name sub)])
`(,mk-sub-name ,@(loop (cdr subs) (+ i 1))))] `(,mk-sub-name ,@(loop (cdr subs))))]
[else `(,sub ,@(loop (cdr subs) i))]))]))) [else `(,sub ,@(loop (cdr subs)))]))])))
(define (and/c . fs) (define (and/c . fs)
(for-each (for-each
@ -312,11 +394,7 @@
(loop (lambda (x) (fst (ctct x))) (loop (lambda (x) (fst (ctct x)))
(cdr rest)))]))))))])) (cdr rest)))]))))))]))
(define any/c (define any/c (make-flat-contract 'any/c (lambda (x) #t)))
(make-flat-contract
'any/c
(lambda (pos neg src-info orig-str) (lambda (val) val))
(lambda (x) #t)))
(define (flat-contract/predicate? pred) (define (flat-contract/predicate? pred)
(or (flat-contract? pred) (or (flat-contract? pred)

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

@ -638,14 +638,12 @@ add struct contracts for immutable structs?
(define-syntax (recursive-contract stx) (define-syntax (recursive-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ arg) [(_ arg)
(syntax (recursive-contract/proc '(recursive-contract arg) (delay (check-contract arg))))])) (syntax (make-contract
'(recursive-contract arg)
(define (recursive-contract/proc name delayed-contract) (λ (pos neg src str)
(make-contract name (let ([proc (contract-proc arg)])
(λ (pos neg src str) (λ (val)
(let ([proc (contract-proc (force delayed-contract))]) ((proc pos neg src str) val))))))]))
(λ (val)
((proc pos neg src str) val))))))
(define (check-contract ctc) (define (check-contract ctc)
(unless (contract? ctc) (unless (contract? ctc)
@ -672,12 +670,11 @@ add struct contracts for immutable structs?
(provide anaphoric-contracts (provide flat-rec-contract
flat-rec-contract
flat-murec-contract flat-murec-contract
or/c union or/c union
not/c not/c
=/c >=/c <=/c </c >/c =/c >=/c <=/c </c >/c between/c
integer-in integer-in
exact-integer-in exact-integer-in
real-in real-in
@ -748,27 +745,6 @@ add struct contracts for immutable structs?
[(_ ([name ctc ...] ...)) [(_ ([name ctc ...] ...))
(raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)])) (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)]))
(define anaphoric-contracts
(case-lambda
[() (make-anaphoric-contracts (make-hash-table 'weak))]
[(x)
(unless (eq? x 'equal)
(error 'anaphoric-contracts "expected either no arguments, or 'equal as first argument, got ~e" x))
(make-anaphoric-contracts (make-hash-table 'equal 'weak))]))
(define (make-anaphoric-contracts ht)
(values
(flat-named-contract
"(anaphoric-contracts,from)"
(lambda (v)
(hash-table-put! ht v #t)
v))
(flat-named-contract
"(anaphoric-contracts,to)"
(lambda (v)
(hash-table-get ht v (lambda () #f))))))
(define-syntax (union stx) (define-syntax (union stx)
(begin (begin
#; #;
@ -830,10 +806,28 @@ add struct contracts for immutable structs?
[else [else
(partial-contract val)]))))))] (partial-contract val)]))))))]
[else [else
(build-flat-contract (make-flat-or/c-contract flat-contracts)]))))
(apply build-compound-type-name 'or/c flat-contracts)
(lambda (x) (define-struct/prop flat-or/c-contract (flat-ctcs)
(ormap (lambda (pred) (pred x)) predicates)))])))) ((proj-prop flat-proj)
(name-prop (λ (ctc)
(apply build-compound-type-name
'or/c
(flat-or/c-contract-flat-ctcs ctc))))
(stronger-prop
(λ (this that)
(and (flat-or/c-contract? that)
(let ([this-ctcs (flat-or/c-contract-flat-ctcs this)]
[that-ctcs (flat-or/c-contract-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))
(flat-prop (λ (ctc)
(let ([preds
(map (λ (x) ((flat-get x) x))
(flat-or/c-contract-flat-ctcs ctc))])
(λ (x) (ormap (λ (p?) (p? x)) preds)))))))
(define false/c (define false/c
(flat-named-contract (flat-named-contract
@ -881,18 +875,32 @@ add struct contracts for immutable structs?
(and (box? x) (and (box? x)
(printable? (unbox x)))))))) (printable? (unbox x))))))))
(define (=/c x) (define-struct/prop between/c (low high)
(flat-named-contract ((proj-prop flat-proj)
`(=/c ,x) (name-prop (λ (ctc)
(lambda (y) (and (number? y) (= y x))))) (let ([n (between/c-low ctc)]
(define (>=/c x) [m (between/c-high ctc)])
(flat-named-contract (cond
`(>=/c ,x) [(= n -inf.0) `(<=/c ,m)]
(lambda (y) (and (number? y) (>= y x))))) [(= m +inf.0) `(>=/c ,n)]
(define (<=/c x) [(= n m) `(=/c ,n)]
(flat-named-contract [else `(between/c ,n ,m)]))))
`(<=/c ,x) (stronger-prop
(lambda (y) (and (number? y) (<= y x))))) (λ (this that)
(and (between/c? that)
(<= (between/c-low that) (between/c-low this))
(<= (between/c-high this) (between/c-high that)))))
(flat-prop (λ (ctc)
(let ([n (between/c-low ctc)]
[m (between/c-high ctc)])
(λ (x)
(and (number? x)
(<= n x m))))))))
(define (=/c x) (make-between/c x x))
(define (<=/c x) (make-between/c -inf.0 x))
(define (>=/c x) (make-between/c x +inf.0))
(define (between/c x y) (make-between/c x y))
(define (</c x) (define (</c x)
(flat-named-contract (flat-named-contract
`(</c ,x) `(</c ,x)

270
collects/mzlib/private/same-closure.ss Normal file
View File

@ -0,0 +1,270 @@
#|
does not work for the
3m garbage collector
(it has a different
closure representation)
assumes the JIT is
compiled into mzscheme,
but not necc enabled.
(If the JIT isn't compiled in,
the closure representation
changes.)
|#
(module same-closure mzscheme
(require (lib "foreign.ss"))
(provide same-closure? closure-size)
(unsafe!)
(define 3m? (regexp-match #rx#"3m$" (path->bytes (system-library-subpath))))
(define-cstruct _scheme-object
((so _short)))
(define-cstruct _scheme-inclhash-object
((so _short)
(key _short)))
(define-cstruct _scheme-closure-data
((iso _scheme-inclhash-object)
(num-params _int)
(max-let-depth _int)
(closure-size _int)
;; more fields here in reality,
;; but don't matter for this code.
))
(define-cstruct _scheme-closure
((so _short)
(code _scheme-closure-data-pointer)
;; don't include the array at the end, so
;; the indexing computation below is right.
))
(define-cstruct _scheme-native-closure-data
((code _pointer)
(arity-stuff _pointer)
(arity-code _pointer)
(max-let-depth _int)
(closure-size _int)))
(define-cstruct _scheme-native-closure
((so _short)
(code _scheme-native-closure-data-pointer)
;; vals go here -- an array of pointers stuck on the end
;; of this struct.
))
(define closure-size
(if 3m?
(λ (a) (error 'closure-size "not supported for 3m"))
(λ (a)
(cond
[(not (procedure? a))
(error 'closure-size "expected a procedure, got ~e" a)]
[else
(let ([ptr-a (malloc _pointer)])
(ptr-set! ptr-a _scheme a)
(let* ([so-a (ptr-ref ptr-a _scheme-object-pointer)]
[a-type (scheme-object-so so-a)])
(case a-type
[(28)
(do-size-work ptr-a so-a
_scheme-closure-pointer
scheme-closure-code
scheme-closure-data-closure-size)]
[(29) #f]
[(33)
(do-size-work ptr-a so-a
_scheme-native-closure-pointer
scheme-native-closure-code
scheme-native-closure-data-closure-size)]
[else #f])))]))))
(define (do-size-work ptr-a so-a _ptr-type code-selector size-selector)
(let ([closure-data-a (code-selector (ptr-ref ptr-a _ptr-type))])
(size-selector closure-data-a)))
(define same-closure?
(if 3m?
(λ (a b) (error 'same-closure? "not supported for 3m"))
(λ (a b)
(cond
[(not (procedure? a))
(error 'same-closure? "expected a procedure as first argument, got ~e" a)]
[(not (procedure? b))
(error 'same-closure? "expected a procedure as first argument, got ~e" b)]
[(eq? a b) #t]
[else
(let ([ptr-a (malloc _pointer)]
[ptr-b (malloc _pointer)])
(ptr-set! ptr-a _scheme a)
(ptr-set! ptr-b _scheme b)
(let* ([so-a (ptr-ref ptr-a _scheme-object-pointer)]
[a-type (scheme-object-so so-a)]
[so-b (ptr-ref ptr-b _scheme-object-pointer)]
[b-type (scheme-object-so so-b)])
(if (= a-type b-type)
(case a-type
[(28)
(do-work ptr-a ptr-b so-a so-b
_scheme-closure-pointer
scheme-closure-code
scheme-closure-data-closure-size
_scheme-closure)]
[(29)
;; case lambda
;; cop out for now
(eq? a b)]
[(33)
(do-work ptr-a ptr-b so-a so-b
_scheme-native-closure-pointer
scheme-native-closure-code
scheme-native-closure-data-closure-size
_scheme-native-closure)]
[else
;(printf "unknown type ~s ~s\n" a a-type)
(eq? a b)])
#f)))]))))
(define (do-work ptr-a ptr-b so-a so-b _ptr-type code-selector size-selector _type)
(let ([closure-data-a (code-selector (ptr-ref ptr-a _ptr-type))]
[closure-data-b (code-selector (ptr-ref ptr-b _ptr-type))])
(and (ptr-equal? closure-data-a closure-data-b)
(let ([size (size-selector closure-data-a)])
(let loop ([i 0])
(or (= i size)
(let ([index (+ (ctype-sizeof _type)
(* (ctype-sizeof _pointer) i))])
(and (ptr-equal?
(ptr-ref so-a _pointer 'abs index)
(ptr-ref so-b _pointer 'abs index))
(loop (+ i 1))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; test cases
;; (use eval to construct functions so we can control
;; whether or not the JIT is enabled.)
;;
#;
(begin
(require (lib "etc.ss")
(lib "list.ss")
"test.scm")
(define (run-tests)
(test (eval `(,closure-size (lambda (x) x)))
0)
(test (eval `(,closure-size ((lambda (x) (lambda (y) x)) 1)))
1)
(test (eval `(,closure-size ((lambda (x y) (lambda (z) (x y))) 1 2)))
2)
(test (eval `(,closure-size (((lambda (x y) (lambda (p q) (lambda (z) (x y p q)))) 1 2) 3 4)))
4)
(test (eval `(,same-closure? (lambda (x) x) (lambda (x) x)))
#f)
(test (eval `(,same-closure? (call/cc values) (call/cc values)))
#f)
(test (eval `(,same-closure? + -))
#f)
(test (eval `(,same-closure? + +))
#t)
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
(,same-closure? (f 1) (f 1))))
#t)
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
(,same-closure? (f f) (f f))))
#t)
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
(,same-closure? (f 1) (f 2))))
#f)
(test (eval `(let ([f (lambda (x) (lambda (y) x))])
(,same-closure? (f 1) (f f))))
#f)
(test (eval `(let ([f 1])
(,same-closure?
(lambda (x) f)
(lambda (x) f))))
#f)
(test (eval `(let ([f (lambda (x y z p) (lambda (y) (x y z p)))])
(,same-closure? (f 1 2 3 4) (f 1 2 3 4))))
#t)
(test (eval `(let ([f (lambda (x y z p) (lambda (y) (x y z p)))])
(,same-closure? (f 1 2 3 5) (f 1 2 3 4))))
#f)
(test (eval `(let ([f (lambda () (lambda (y) +))])
(,same-closure? (f) (f))))
#t)
(test (eval `(,same-closure? (lambda (y) -) (lambda (y) +)))
#f)
(test (eval `(begin (module m mzscheme
(provide ans)
(define (f y z) (lambda (x) (+ x y z)))
(define ans (,same-closure? (f 1 2) (f 1 2))))
(require m)
ans))
#t)
(test (eval `(begin (module m mzscheme
(provide ans)
(define (f y z) (lambda (x) (+ x y z)))
(define ans (,same-closure? (f 1 2) (f 2 1))))
(require m)
ans))
#f)
(test (eval `(let ([f (λ (x)
(case-lambda
[() x]
[(x) x]))])
(,same-closure? (f 1) (f f))))
#f)
;; this test fails, because case-lambda isn't handled yet.
#;
(test (eval `(let ([f (λ (x)
(case-lambda
[() x]
[(x) x]))])
(,same-closure? (f 1) (f 1))))
#t)
;; make some big closures
(let* ([size 4000]
[vars (build-list size (λ (x) (string->symbol (format "x~a" x))))]
[lam (eval `(λ ,vars
(λ (x)
(list ,@vars))))]
[diff-list (map values vars)])
(set-car! (last-pair diff-list) 2) ;; set up difference
(test (same-closure? (apply lam vars) (apply lam vars))
#t)
(test (same-closure? (apply lam vars) (apply lam diff-list))
#f)))
(printf "non-jit tests\n")
(parameterize ([eval-jit-enabled #f]) (run-tests))
(printf "jit tests\n")
(parameterize ([eval-jit-enabled #t]) (run-tests))
(printf "tests done\n")
(define (timing-test)
(let* ([f (λ (x) (λ (y) x))]
[f1 (f 1)]
[f2 (f 2)])
(let loop ([i 10000])
(unless (zero? i)
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
(same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2) (same-closure? f1 f2)
(loop (- i 1))))))))

1
collects/syntax/struct.ss
View File

@ -93,7 +93,6 @@
(parse-at-id)) (parse-at-id))
;; build-struct-names : id (list-of id) bool bool -> (list-of id) ;; build-struct-names : id (list-of id) bool bool -> (list-of id)
(define build-struct-names (define build-struct-names
(opt-lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f]) (opt-lambda (name-stx fields omit-sel? omit-set? [srcloc-stx #f])

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

@ -77,6 +77,7 @@
(let ([name (if (pair? contract) (let ([name (if (pair? contract)
(car contract) (car contract)
contract)]) contract)])
(test #t flat-contract? (eval contract))
(test/spec-failed (format "~a fail" name) (test/spec-failed (format "~a fail" name)
`(contract ,contract ',fail 'pos 'neg) `(contract ,contract ',fail 'pos 'neg)
"pos") "pos")
@ -2999,36 +3000,6 @@
#t) #t)
(test/spec-passed
'anaphoric1
'(contract (let-values ([(in out) (anaphoric-contracts)]) in)
1
'pos
'neg))
(test/pos-blame
'anaphoric2
'(contract (let-values ([(in out) (anaphoric-contracts)]) out)
1
'pos
'neg))
(test/spec-passed
'anaphoric3
'((contract (let-values ([(in out) (anaphoric-contracts)]) (-> in out))
(lambda (x) x)
'pos
'neg)
1))
(test/pos-blame
'anaphoric4
'((contract (let-values ([(in out) (anaphoric-contracts)]) (-> in out))
(lambda (x) (* 2 x))
'pos
'neg)
1))
(test/pos-blame (test/pos-blame
'promise/c1 'promise/c1
'(force (contract (promise/c boolean?) '(force (contract (promise/c boolean?)
@ -3376,6 +3347,7 @@
(test-name '(<=/c 5) (<=/c 5)) (test-name '(<=/c 5) (<=/c 5))
(test-name '(</c 5) (</c 5)) (test-name '(</c 5) (</c 5))
(test-name '(>/c 5) (>/c 5)) (test-name '(>/c 5) (>/c 5))
(test-name '(between/c 5 6) (between/c 5 6))
(test-name '(integer-in 0 10) (integer-in 0 10)) (test-name '(integer-in 0 10) (integer-in 0 10))
(test-name '(exact-integer-in 0 10) (exact-integer-in 0 10)) (test-name '(exact-integer-in 0 10) (exact-integer-in 0 10))
(test-name '(real-in 1 10) (real-in 1 10)) (test-name '(real-in 1 10) (real-in 1 10))
@ -3479,5 +3451,251 @@
(test-name '(recursive-contract (box/c boolean?)) (recursive-contract (box/c boolean?))) (test-name '(recursive-contract (box/c boolean?)) (recursive-contract (box/c boolean?)))
(test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x))) (test-name '(recursive-contract x) (let ([x (box/c boolean?)]) (recursive-contract x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; stronger tests
;;
(test #t contract-stronger? any/c any/c)
(test #t contract-stronger? (between/c 1 3) (between/c 0 4))
(test #f contract-stronger? (between/c 0 4) (between/c 1 3))
(test #t contract-stronger? (>=/c 3) (>=/c 2))
(test #f contract-stronger? (>=/c 2) (>=/c 3))
(test #f contract-stronger? (<=/c 3) (<=/c 2))
(test #t contract-stronger? (<=/c 2) (<=/c 3))
(test #f contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3)))
(test #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2)))
(let ([f (λ (x) (recursive-contract (<=/c x)))])
(test #t contract-stronger? (f 1) (f 1)))
(test #t contract-stronger? (-> integer? integer?) (-> integer? integer?))
(test #f contract-stronger? (-> boolean? boolean?) (-> integer? integer?))
(test #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3)))
(test #f contract-stronger? (-> (>=/c 4) (>=/c 3)) (-> (>=/c 3) (>=/c 3)))
(test #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 3) (>=/c 2)))
(test #f contract-stronger? (-> (>=/c 3) (>=/c 2)) (-> (>=/c 3) (>=/c 3)))
(test #t contract-stronger? (or/c null? any/c) (or/c null? any/c))
(test #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c))
(test #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?))
(test #f contract-stronger? (or/c null? boolean?) (or/c boolean? null?))
(test #t contract-stronger? (or/c null? (-> integer? integer?)) (or/c null? (-> integer? integer?)))
(test #f contract-stronger? (or/c null? (-> boolean? boolean?)) (or/c null? (-> integer? integer?)))
(test #t contract-stronger? number? number?)
(test #f contract-stronger? boolean? number?)
#|
(test (contract-stronger? (couple/c any any)
(couple/c any any))
#t)
(test (contract-stronger? (couple/c (gt 2) (gt 3))
(couple/c (gt 4) (gt 5)))
#f)
(test (contract-stronger? (couple/c (gt 4) (gt 5))
(couple/c (gt 2) (gt 3)))
#t)
(test (contract-stronger? (couple/c (gt 1) (gt 5))
(couple/c (gt 5) (gt 1)))
#f)
(define (non-zero? x) (not (zero? x)))
(define list-of-numbers
(or-p? null?
(couple/c (flat number?)
(lift list-of-numbers))))
(test (contract-stronger? list-of-numbers
list-of-numbers)
#t)
(define (short-list/less-than n)
(or-p? null?
(couple/c (lt n)
(or-p? null?
(couple/c (lt n)
any)))))
(test (contract-stronger? (short-list/less-than 4)
(short-list/less-than 5))
#t)
(test (contract-stronger? (short-list/less-than 5)
(short-list/less-than 4))
#f)
(define (short-sorted-list/less-than n)
(or-p? null?
(couple/dc
[hd (lt n)]
[tl (hd) (or-p? null?
(couple/c (lt hd)
any))])))
(test (contract-stronger? (short-sorted-list/less-than 4)
(short-sorted-list/less-than 5))
#t)
(test (contract-stronger? (short-sorted-list/less-than 5)
(short-sorted-list/less-than 4))
#f)
(test (let ([x (make-couple 1 2)]
[y (make-couple 1 2)]
[c1 (couple/dc [hd any]
[tl (hd) any])]
[c2 (couple/c any any)])
(couple-hd (apply-contract c1 x))
(couple-hd (apply-contract c2 x))
(couple-hd (apply-contract c2 y))
(couple-hd (apply-contract c1 y)))
1)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; list of numbers test
;;
(let ()
(define list-of-number
(or-p? null?
(couple/c (flat number?)
(lift list-of-number))))
(let* ([l (make-couple 1 (make-couple 2 (make-couple 3 (make-couple 4 '()))))]
[ctc-l (apply-contract list-of-number l)])
;(clength ctc-l)
(values l ctc-l)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; kons tests
;;
(test-blame (apply-contract (kons-sorted-gt/c 1) 2))
(test-no-exn (apply-contract (kons-sorted-gt/c 1) (kons 1 '())))
(test (kar (kons 1 '())) 1)
(test (kdr (kons 1 '())) '())
(test (kons? (kons 1 '())) #t)
(test (kons? (apply-contract (kons-sorted-gt/c 1) (kons 1 '()))) #t)
(test (kons? 1) #f)
(test (kar (apply-contract (kons-sorted-gt/c 1) (kons 1 '())))
1)
(test (kdr (apply-contract (kons-sorted-gt/c 1) (kons 1 '())))
'())
(test (kar (apply-contract (kons-sorted-gt/c 1) (apply-contract (kons-sorted-gt/c 1) (kons 1 '()))))
1)
(test (kdr (apply-contract (kons-sorted-gt/c 1) (apply-contract (kons-sorted-gt/c 1) (kons 1 '()))))
'())
(test (let ([x (apply-contract (kons-sorted-gt/c 1) (kons 1 '()))])
(list (kar x)
(kar x)))
(list 1 1))
(test (let ([x (apply-contract (kons-sorted-gt/c 1) (kons 1 '()))])
(list (kdr x)
(kdr x)))
(list '() '()))
(test-blame (kdr (kdr (apply-contract (kons-sorted-gt/c 1) (kons 1 (kons 0 '()))))))
(test (kdr (kdr (apply-contract (kons-sorted-gt/c 1) (kons 1 (kons 2 '())))))
'())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; leftist-kheaps tests
;;
(test-blame (apply-contract kleftist-heap/c 2))
(test-no-exn (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f)))
(test-no-exn (apply-contract kleftist-heap/c #f))
(test-no-exn (apply-contract non-empty-kleftist-heap/c (make-knode 1 2 3 #f #f)))
(test-blame (apply-contract non-empty-kleftist-heap/c #f))
(test (knode? (make-knode 1 2 3 #f #f))
#t)
(test (knode-val (make-knode 1 2 3 #f #t)) 1)
(test (knode-obj (make-knode 1 2 3 #f #t)) 2)
(test (knode-rank (make-knode 1 2 3 #f #t)) 3)
(test (knode-left (make-knode 1 2 3 #f #t)) #f)
(test (knode-right (make-knode 1 2 3 #f #t)) #t)
(test (knode? (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f)))
#t)
(test (knode-val (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))) 1)
(test (knode-obj (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))) 2)
(test (knode-rank (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))) 3)
(test (knode-left (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))) #f)
(test (knode-right (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))) #f)
(test (knode-val (apply-contract kleftist-heap/c
(apply-contract kleftist-heap/c
(make-knode 1 2 3 #f #f)))) 1)
(test (knode-obj (apply-contract kleftist-heap/c
(apply-contract kleftist-heap/c
(make-knode 1 2 3 #f #f)))) 2)
(test (knode-rank (apply-contract kleftist-heap/c
(apply-contract kleftist-heap/c
(make-knode 1 2 3 #f #f)))) 3)
(test (knode-left (apply-contract kleftist-heap/c
(apply-contract kleftist-heap/c
(make-knode 1 2 3 #f #f)))) #f)
(test (knode-right (apply-contract kleftist-heap/c
(apply-contract kleftist-heap/c
(make-knode 1 2 3 #f #f)))) #f)
(test (let ([h (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))])
(knode-val h)
(knode-val h))
1)
(test (let ([h (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))])
(knode-obj h)
(knode-obj h))
2)
(test (let ([h (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))])
(knode-rank h)
(knode-rank h))
3)
(test (let ([h (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))])
(knode-left h)
(knode-left h))
#f)
(test (let ([h (apply-contract kleftist-heap/c (make-knode 1 2 3 #f #f))])
(knode-right h)
(knode-right h))
#f)
(test (knode-val
(knode-right
(apply-contract kleftist-heap/c
(make-knode 1 2 3
(make-knode 7 8 9 #f #f)
(make-knode 4 5 6 #f #f)))))
4)
(test (knode-val
(knode-left
(apply-contract kleftist-heap/c
(make-knode 1 2 3
(make-knode 7 8 9 #f #f)
(make-knode 4 5 6 #f #f)))))
7)
(test-blame
(knode-val
(knode-right
(apply-contract kleftist-heap/c
(make-knode 5 2 3
(make-knode 7 8 9 #f #f)
(make-knode 4 5 6 #f #f))))))
(test-blame
(knode-val
(knode-left
(apply-contract kleftist-heap/c
(make-knode 9 2 3
(make-knode 7 8 9 #f #f)
(make-knode 11 5 6 #f #f))))))
|#
)) ))
(report-errs) (report-errs)