checkpoint

svn: r13777

original commit: 85de5f27bfdf2b5d22b0a0f0b3062bbda8ce7618

collects/typed-scheme/no-check.ss

@@ -1,5 +1,30 @@
 #lang scheme/base
 
-(require "private/prims.ss")
+#;(require "private/prims.ss")
 (provide (all-from-out scheme/base)
-	 (all-from-out "private/prims.ss"))
+	 (all-defined-out)
+	 #;(all-from-out "private/prims.ss"))
+
+(define-syntax-rule (define-type-alias . _) (begin))
+
+(define-syntax-rule (define: nm _ _ . body)
+  (define nm . body))
+
+(define-syntax-rule (ann e . rest) e)
+
+(define-syntax-rule (require/typed mod [id . _] ...)
+  (require (only-in mod id ...)))
+
+(define-syntax-rule (: . args) (begin))
+
+(define-syntax let:
+  (syntax-rules ()
+    [(_ ([id _ _ . rest] ...) . b)
+     (let ([id . rest] ...) . b)]
+    [(_ id _ _ ([ids _ _ e] ...) . b)
+     (let id ([ids e] ...) . b)]))
+
+(define-syntax-rule (lambda: ([id . rest] ...) . b)
+  (lambda (id ...) . b))
+
+(define-syntax-rule (λ: . arg) (lambda: . arg))

collects/typed-scheme/rep/interning.ss

@@ -1,14 +1,17 @@
 #lang scheme/base
 
-(require syntax/boundmap (for-syntax scheme/base stxclass))
+(require syntax/boundmap (for-syntax scheme/base stxclass)
+         macro-debugger/stepper)
 
 (provide defintern hash-id)
 
 (define-syntax (defintern stx)
   (syntax-parse stx
-    [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...) 
-     #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)]
-    [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr] #:opt) ...)
+    [(_ name+args make-name key (~or [#:extra-arg e:expr] #:opt) ...)
+     (if #'e
+         #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key #:extra-arg e)
+         #'(defintern name+args (lambda () (make-hash #;'weak)) make-name key))]
+    [(_ (*name:id arg:id ...) make-ht make-name key-expr (~or [#:extra-arg e:expr]) ...)
      #'(define *name
 	 (let ([table (make-ht)])
 	   (lambda (arg ...)
@@ -16,7 +19,7 @@
 	     (let ([key key-expr])
 	       (hash-ref table key
 			 (lambda ()
-			   (let ([new (make-name (count!) e arg ...)])
+			   (let ([new (make-name (count!) e ... arg ...)])
 			     (hash-set! table key new)
 			     new)))))))]))
 

collects/typed-scheme/rep/type-effect-printer.ss

@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require "../utils/utils.ss")
-(require (rep type-rep filter-rep rep-utils)
+(require (rep type-rep filter-rep object-rep rep-utils)
 	 (utils tc-utils)
 	 scheme/match)
 
@@ -30,7 +30,10 @@
 (define (print-latentfilter c port write?)
   (define (fp . args) (apply fprintf port args))
   (match c
-    [(LFilterSet: thn els) (fp "(~a | ~a)") thn els]
+    [(LFilterSet: thn els) (fp "(")
+                           (for ([i thn]) (fp "~a " i)) (fp "|")
+                           (for ([i els]) (fp " ~a" i))
+                           (fp")")]
     [(LNotTypeFilter: type path idx) (fp "(! ~a @ ~a ~a)" type path idx)]
     [(LTypeFilter: type path idx) (fp "(~a @ ~a ~a)" type path idx)]
     [(LBot:) (fp "LBot")]))
@@ -38,11 +41,26 @@
 (define (print-filter c port write?)
   (define (fp . args) (apply fprintf port args))
   (match c
-    [(FilterSet: thn els) (fp "(~a | ~a)") thn els]
+    [(FilterSet: thn els) (fp "(")
+                          (for ([i thn]) (fp "~a " i)) (fp "|")
+                          (for ([i els]) (fp " ~a" i))
+                          (fp")")]
     [(NotTypeFilter: type path id) (fp "(! ~a @ ~a ~a)" type path (syntax-e id))]
     [(TypeFilter: type path id) (fp "(~a @ ~a ~a)" type path (syntax-e id))]
     [(Bot:) (fp "Bot")]))
 
+(define (print-pathelem c port write?)
+  (define (fp . args) (apply fprintf port args))
+  (match c
+    [(CarPE:) (fp "car")]
+    [(CdrPE:) (fp "cdr")]
+    [(StructPE: t i) (fp "(~a ~a)" t i)]))
+
+(define (print-latentobject c port write?)
+  (define (fp . args) (apply fprintf port args))
+  (match c
+    [(LEmpty:) (fp "")]
+    [(LPath: pes i) (fp "~a" (append pes (list i)))]))
 
 ;; print out a type
 ;; print-type : Type Port Boolean -> Void
@@ -145,7 +163,7 @@
                               (Vector: (F: x))
                               (Box: (F: x))))))
      (fp "SyntaxObject")]
-    [(Mu-name: name body) (fp "(mu ~a ~a ~a)" (Type-seq c) name body)]
+    [(Mu-name: name body) (fp "(Rec ~a ~a)" name body)]
     ;; FIXME - this should not be used
     #;
     [(Scope: sc) (fp "(Scope ~a)" sc)]
@@ -160,3 +178,5 @@
 (set-box! print-type* print-type)
 (set-box! print-filter* print-filter)
 (set-box! print-latentfilter* print-latentfilter)
+(set-box! print-latentobject* print-latentobject)
+(set-box! print-pathelem* print-pathelem)

collects/typed-scheme/rep/type-rep.ss

@@ -122,7 +122,6 @@
 
 ;; types : Listof[Type]
 (dt Values ([rs (listof Result?)]) 
-    #:no-provide
     [#:frees (λ (f) (combine-frees (map f rs)))]
     [#:fold-rhs (*Values (map type-rec-id rs))])
 
@@ -315,11 +314,6 @@
         [(type<? s t) 1]
         [else -1]))
 
-(define (Values* l)
-  (if (and (pair? l) (null? (cdr l)))
-      (car l)
-      (*Values l)))
-
 (define ((sub-lf st) e)
   (latentfilter-case (#:Type st
                       #:LatentFilter (sub-lf st))
@@ -566,7 +560,6 @@
  remove-dups
  sub-lf
  Values: Values? Values-rs
- (rename-out [Values* make-Values])
  (rename-out [Mu:* Mu:]               
              [Poly:* Poly:]
              [PolyDots:* PolyDots:]
@@ -578,4 +571,3 @@
              [PolyDots-body* PolyDots-body]))
 
 ;(trace unfold)
-

collects/typed-scheme/utils/utils.ss

@@ -164,7 +164,7 @@
       [(_ val)
        #'(? (lambda (x) (equal? val x)))])))
 
-(define-for-syntax printing? #f)
+(define-for-syntax printing? #t)
 
 (define-syntax-rule (defprinter t ...)
   (begin