hack to experiment with disabling contracts

svn: r5454

collects/mzlib/contract.ss

@@ -1,3 +1,4 @@
+
 (module contract mzscheme
   (require "private/contract.ss"
            "private/contract-arrow.ss"
@@ -26,4 +27,118 @@
                     check-flat-named-contract)
    (all-from-except "private/contract.ss"
                     check-between/c
-                    check-unary-between/c)))
+                    check-unary-between/c)))
+
+;; ======================================================================
+;; The alternate implementation disables contracts. Its useful mainly to
+;; measure the cost of contracts. It's not necessarily complete, but it
+;;  works well enough for starting DrScheme.
+
+#;
+(module contract mzscheme
+
+  (define-syntax provide/contract
+    (syntax-rules ()
+      [(_ elem ...)
+       (begin (provide-one elem) ...)]))
+
+  (define-syntax provide-one
+    (syntax-rules (struct rename)
+      [(_ (struct (id par-id) ([field . rest] ...)))
+       (provide-struct id par-id (field ...))]
+      [(_ (struct id ([field . rest] ...)))
+       (provide (struct id (field ...)))]
+      [(_ (rename id1 id2 c))
+       (provide (rename id1 id2))]
+      [(_ (id c))
+       (provide id)]))
+
+  (define-syntax (provide-struct stx)
+    (syntax-case stx ()
+      [(_ id par-id . rest)
+       (let ([info (syntax-local-value #'id (lambda () #f))]
+             [p-info (syntax-local-value #'par-id (lambda () #f))]
+             [prefix (lambda (l n)
+                       (let loop ([l l][len (length l)])
+                         (if (= n len)
+                             null
+                             (cons (car l) (loop (cdr l)
+                                                 (- len 1))))))]
+             [ids (lambda (l) (let loop ([l l])
+                                (cond
+                                 [(null? l) null]
+                                 [(car l) (cons (car l) (loop (cdr l)))]
+                                 [else (loop (cdr l))])))])
+         (if (and info
+                  p-info
+                  (list? info)
+                  (list? p-info)
+                  (= (length info) 6)
+                  (= (length p-info) 6))
+             #`(provide #,@(append
+                            (list #'id
+                                  (list-ref info 0)
+                                  (list-ref info 1)
+                                  (list-ref info 2))
+                            (ids (prefix (list-ref info 3) (length (list-ref p-info 3))))
+                            (ids (prefix (list-ref info 4) (length (list-ref p-info 4))))))
+             (raise-syntax-error 
+              #f
+              (cond
+               [(not info) "cannot find struct info"]
+               [(not p-info) "cannot find parent-struct info"]
+               [else (format "struct or parent-struct info has unexpected shape: ~e and ~e"
+                             info p-info)])
+              #'id)))]))
+
+  (define-syntax define-contract-struct
+    (syntax-rules ()
+      [(_ . rest) (define-struct . rest)]))
+
+  (define-syntax define/contract
+    (syntax-rules ()
+      [(_ id c expr) (define id expr)]))
+
+  (define-syntax contract
+    (syntax-rules ()
+      [(_ c expr . rest) expr]))
+
+  (provide provide/contract
+           define-contract-struct
+           define/contract
+           contract)
+
+  (define mk*
+    (lambda args (lambda (x) x)))
+
+  (define-syntax mk 
+    (syntax-rules ()
+      [(_ id) (begin
+                (define-syntax (id stx) (quote-syntax mk*))
+                (provide id))]
+      [(_ id ...)
+       (begin (mk id) ...)]))
+
+  (mk ->
+      ->*
+      opt->
+      case->
+      ->r
+      or/c
+      and/c
+      any/c
+      flat-named-contract
+      flat-contract
+      flat-contract-predicate
+      object-contract
+      union
+      listof
+      is-a?/c)
+
+  (define-syntax symbols
+    (syntax-rules ()
+      [(_ sym ...)
+       (lambda (v) (memq v '(sym ...)))]))
+  (provide symbols)
+  
+  )