some cleanup

svn: r5503

collects/mzlib/contract.ss

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

collects/mzlib/private/contract-basic-opters.ss

@@ -8,7 +8,6 @@
   ;; opt/pred helper
   ;;
   (define-for-syntax (opt/pred opt/info pred)
-    (printf "~s\n" (list 'opt/pred opt/info pred))
     (with-syntax ((pred pred))
       (values
        (with-syntax ((val (opt/info-val opt/info))
@@ -40,7 +39,6 @@
     (syntax-case stx (null?)
       [null? (opt/pred opt/info #'null?)]))
   (define/opter (boolean? opt/i opt/info stx)
-    (printf "boolean opter\n")
     (syntax-case stx (boolean?)
       [boolean? (opt/pred opt/info #'boolean?)]))
   (define/opter (integer? opt/i opt/info stx)

collects/mzlib/private/contract-ds.ss

@@ -360,8 +360,7 @@ it around flattened out.
                                                                      (opt/info-recf opt/info)
                                                                      (opt/info-base-pred opt/info)
                                                                      (opt/info-this opt/info)
-                                                                     (opt/info-that opt/info)
+                                                                     (opt/info-that opt/info))
-                                                                     (opt/info-sv-index opt/info))
                                                       name
                                                       stx
                                                       clauses

collects/mzlib/private/contract-opt-guts.ss

@@ -19,10 +19,6 @@
            opt/info-base-pred
            opt/info-this
            opt/info-that
-           opt/info-sv-index
-           
-           sv-index
-           inc-sv-index!
            
            opt/info-swap-blame)
   
@@ -56,16 +52,7 @@
 
 
   ;; struct for color-keeping across opters
-  (define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that sv-index))
+  (define-struct opt/info (contract val pos neg src-info orig-str free-vars recf base-pred this that))
-  
-  ;; sv-index : opt/info -> int
-  (define (sv-index info)
-    (unbox (opt/info-sv-index info)))
-  
-  ;; inc-sv-index! : opt/info int -> unit
-  (define (inc-sv-index! info n)
-    (let ((old (unbox (opt/info-sv-index info))))
-      (set-box! (opt/info-sv-index info) (+ old n))))
   
   ;; opt/info-swap-blame : opt/info -> opt/info
   ;; swaps pos and neg
@@ -80,9 +67,8 @@
           (recf (opt/info-recf info))
           (base-pred (opt/info-base-pred info))
           (this (opt/info-this info))
-          (that (opt/info-that info))
+          (that (opt/info-that info)))
-          (sv-index (opt/info-sv-index info)))
+      (make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that)))
-      (make-opt/info ctc val pos neg src-info orig-str free-vars recf base-pred this that sv-index)))
   
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -126,11 +112,6 @@
            (number? (syntax-e e))
            (boolean? (syntax-e e)))
        (values e lifts)]
-      #;
-      [x
-       (identifier? e)
-       (values e
-               (snoc (cons e e) lifts))]
       [else
        (let ([x (car (generate-temporaries (list id-hint)))])
          (values x

collects/mzlib/private/contract-opt.ss

@@ -1,11 +1,13 @@
 (module contract-opt mzscheme
   (require "contract-guts.ss"
+           (lib "stxparam.ss")
            (lib "etc.ss"))
   (require-for-syntax "contract-opt-guts.ss"
                       (lib "etc.ss")
+                      (lib "stxparam.ss")
                       (lib "list.ss"))
   
-  (provide opt/c define/opter define/osc opt-stronger-vars-ref)
+  (provide opt/c define-opt/c define/opter define/osc opt-stronger-vars-ref)
   
   ;; define/opter : id -> syntax
   ;;
@@ -138,6 +140,19 @@
         [argless-ctc
          (and (identifier? #'argless-ctc) (opter #'argless-ctc))
          ((opter #'argless-ctc) opt/i opt/info stx)]
+        [(f arg ...)
+         (and (identifier? #'f) 
+              (syntax-parameter-value #'define/opt-recursive-fn)
+              (module-identifier=? (syntax-parameter-value #'define/opt-recursive-fn)
+                                   #'f))
+         (values
+          #`(f #,(opt/info-val opt/info) arg ...)
+          null
+          null
+          null
+          #f
+          #f
+          null)]
         [else
          (opt/unknown opt/i opt/info stx)]))
     
@@ -153,25 +168,44 @@
                                             #f
                                             #f
                                             #'this
-                                            #'that
+                                            #'that)]
-                                            (box 0))]
                      [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
-         (with-syntax ((next next))
+         (with-syntax ([next next])
-           (bind-superlifts 
+           (let ([superlifts2
-            superlifts
+                  (if (syntax-parameter-value #'define/opt-recursive-fn)
-            (bind-lifts
+                      (cons (cons
-             lifts
+                             (syntax-parameter-value #'define/opt-recursive-fn)
-             #`(make-opt-contract
+                             (with-syntax ([(args ...)
-                (λ (ctc)
+                                            (syntax-parameter-value #'define/opt-recursive-args)])
-                  (λ (pos neg src-info orig-str)
+                               #'(lambda (val info args ...) 'next)))
-                    #,(bind-lifts
+                            superlifts)
-                       partials
+                      superlifts)])
-                       #`(λ (val) 
+             (bind-superlifts 
-                           next))))
+              superlifts2
-                (λ () e)
+              (bind-lifts
-                (λ (this that) #f)
+               lifts
-                (vector)
+               #`(make-opt-contract
-                (begin-lifted (box #f)))))))]))
+                  (λ (ctc)
+                    (λ (pos neg src-info orig-str)
+                      #,(bind-lifts
+                         partials
+                         #`(λ (val) 
+                             next))))
+                  (λ () e)
+                  (λ (this that) #f)
+                  (vector)
+                  (begin-lifted (box #f))))))))]))
+
+  (define-syntax-parameter define/opt-recursive-fn #f)
+  (define-syntax-parameter define/opt-recursive-args #f)
+  
+  (define-syntax (define-opt/c stx)
+    (syntax-case stx ()
+      [(_ (id args ...) body)
+       #'(define (id args ...)
+           (syntax-parameterize ([define/opt-recursive-fn #'id]
+                                 [define/opt-recursive-args #'(args ...)])
+                                (opt/c body)))]))
   
   ;; define/osc : syntax -> syntax
   ;; define/osc allows you define optimized recursive contracts, and must be used
@@ -210,8 +244,7 @@
                                             #'f
                                             #'base-pred
                                             #'this
-                                            #'that
+                                            #'that)]
-                                            (box 0))]
                      [(next lifts superlifts partials _ __ stronger-ribs) (opt/i info #'e)])
          (with-syntax ((next next)
                        ((superlift ...) (map (λ (x) (with-syntax ((var (car x))