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

svn: r2452

collects/errortrace/zo-compile.ss

@@ -9,7 +9,9 @@
       (lambda (stx immediate-eval?)
 	(if (null? (use-compiled-file-paths))
 	    (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?)))))))
 
 
 

collects/mzlib/contract.ss

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

collects/mzlib/private/contract-ds-helpers.ss

@@ -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 ...))))])))
+
+  

collects/mzlib/private/contract-ds.ss

@@ -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
+  |#
+  
+  
+  )

collects/mzlib/private/contract-helpers.scm

@@ -1,6 +1,8 @@
 (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
   ;; constructs a mangled name of an identifier from an identifier
@@ -59,4 +61,35 @@
            (if path
                (string->symbol (format "~s" path))
                '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)))]))))

collects/mzlib/private/contract-util.ss

@@ -1,14 +1,16 @@
 (module contract-util mzscheme
   (require "contract-helpers.scm"
+           "same-closure.ss"
            (lib "pretty.ss")
            (lib "list.ss"))
 
+  (require-for-syntax "contract-helpers.scm")
+  
   (provide raise-contract-error
            contract-violation->string
            coerce-contract 
            coerce/select-contract
-           contract?
-           contract-name
+           
            flat-contract/predicate?
            flat-contract?
            flat-contract
@@ -20,10 +22,82 @@
            and/c
            any/c
            
+           contract?
+           contract-name
            contract-proc
            make-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
   ;; 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 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
-                  flat-contract-predicate
-                  flat-contract?
-                  
-                  make-contract
-                  contract-name
-                  contract-proc
-                  contract?)
+                  make-contract)
     (let ()
-      (define-struct contract (name proc))
-      (define-struct (flat-contract contract) (predicate))
+      (define-struct/prop contract (the-name the-proc)
+        ((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
-              flat-contract-predicate
-              flat-contract?
-              
-              make-contract
-              contract-name
-              contract-proc
-              contract?)))
+              make-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)
                  (procedure-arity-includes? predicate 1))
       (error 'flat-contract
@@ -228,28 +327,11 @@
              predicate name))
     (build-flat-contract name predicate))
   
-  (define (build-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))
+  (define (build-flat-contract name predicate) (make-flat-contract name predicate))
   
   ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
   (define (build-compound-type-name . fs)
-    (let loop ([subs fs]
-               [i 0])
+    (let loop ([subs fs])
       (cond
         [(null? subs)
          '()]
@@ -257,8 +339,8 @@
                 (cond
                   [(contract? sub)
                    (let ([mk-sub-name (contract-name sub)])
-                     `(,mk-sub-name ,@(loop (cdr subs) (+ i 1))))]
-                  [else `(,sub ,@(loop (cdr subs) i))]))])))
+                     `(,mk-sub-name ,@(loop (cdr subs))))]
+                  [else `(,sub ,@(loop (cdr subs)))]))])))
   
   (define (and/c . fs)
     (for-each
@@ -312,11 +394,7 @@
                      (loop (lambda (x) (fst (ctct x)))
                            (cdr rest)))]))))))]))
   
-  (define any/c
-    (make-flat-contract
-     'any/c
-     (lambda (pos neg src-info orig-str) (lambda (val) val))
-     (lambda (x) #t)))
+  (define any/c (make-flat-contract 'any/c (lambda (x) #t)))
   
   (define (flat-contract/predicate? pred)
     (or (flat-contract? pred)

collects/mzlib/private/contract.ss

@@ -638,14 +638,12 @@ add struct contracts for immutable structs?
   (define-syntax (recursive-contract stx)
     (syntax-case stx ()
       [(_ arg)
-       (syntax (recursive-contract/proc '(recursive-contract arg) (delay (check-contract arg))))]))
-  
-  (define (recursive-contract/proc name delayed-contract)
-    (make-contract name
-                   (λ (pos neg src str)
-                     (let ([proc (contract-proc (force delayed-contract))])
-                       (λ (val)
-                         ((proc pos neg src str) val))))))
+       (syntax (make-contract 
+                '(recursive-contract arg) 
+                (λ (pos neg src str)
+                  (let ([proc (contract-proc arg)])
+                    (λ (val)
+                      ((proc pos neg src str) val))))))]))
   
   (define (check-contract ctc)
     (unless (contract? ctc)
@@ -672,12 +670,11 @@ add struct contracts for immutable structs?
 
   
   
-  (provide anaphoric-contracts
-           flat-rec-contract
+  (provide flat-rec-contract
            flat-murec-contract
 	   or/c union
 	   not/c
-           =/c >=/c <=/c </c >/c 
+           =/c >=/c <=/c </c >/c between/c
            integer-in
            exact-integer-in
 	   real-in
@@ -748,27 +745,6 @@ add struct contracts for immutable structs?
       [(_ ([name ctc ...] ...))
        (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)
     (begin
 #;
@@ -830,10 +806,28 @@ add struct contracts for immutable structs?
                       [else
                        (partial-contract val)]))))))]
           [else
-           (build-flat-contract
-            (apply build-compound-type-name 'or/c flat-contracts)
-            (lambda (x)
-              (ormap (lambda (pred) (pred x)) predicates)))]))))
+           (make-flat-or/c-contract flat-contracts)]))))
+
+  (define-struct/prop flat-or/c-contract (flat-ctcs)
+    ((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
     (flat-named-contract
@@ -881,18 +875,32 @@ add struct contracts for immutable structs?
 	     (and (box? x)
 		  (printable? (unbox x))))))))
   
-  (define (=/c x)
-    (flat-named-contract
-     `(=/c ,x)
-     (lambda (y) (and (number? y) (= y x)))))
-  (define (>=/c x)
-    (flat-named-contract
-     `(>=/c ,x)
-     (lambda (y) (and (number? y) (>= y x)))))
-  (define (<=/c x)
-    (flat-named-contract
-     `(<=/c ,x)
-     (lambda (y) (and (number? y) (<= y x)))))
+  (define-struct/prop between/c (low high)
+    ((proj-prop flat-proj)
+     (name-prop (λ (ctc) 
+                  (let ([n (between/c-low ctc)]
+                        [m (between/c-high ctc)])
+                    (cond
+                      [(= n -inf.0) `(<=/c ,m)]
+                      [(= m +inf.0) `(>=/c ,n)]
+                      [(= n m) `(=/c ,n)]
+                      [else `(between/c ,n ,m)]))))
+     (stronger-prop
+      (λ (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)
     (flat-named-contract
      `(</c ,x)

collects/mzlib/private/same-closure.ss

@@ -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))))))))

collects/syntax/struct.ss

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

collects/tests/mzscheme/contract-test.ss

@@ -77,6 +77,7 @@
     (let ([name (if (pair? contract)
                     (car contract)
                     contract)])
+      (test #t flat-contract? (eval contract))
       (test/spec-failed (format "~a fail" name)
                         `(contract ,contract ',fail 'pos 'neg)
                         "pos")
@@ -2999,36 +3000,6 @@
    #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
    'promise/c1
    '(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 '(between/c 5 6) (between/c 5 6))
   (test-name '(integer-in 0 10) (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))
@@ -3479,5 +3451,251 @@
   
   (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)))
+  
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;;  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)