fixes

Author: mvitousek

conditionals.rkt

@@ -164,6 +164,8 @@
         (verbose "flatten" e)
 	(match e
 	  ;; For atomic stuff, we keep the has-type annotation. -Jeremy
+	  [`(has-type (void) ,t)
+	   (values `(has-type (void) ,t) '())]
 	  [`(has-type ,e ,t) #:when (or (symbol? e) (integer? e) (boolean? e))
 	   (values `(has-type ,e ,t) '())]
 

dynamic-typing.rkt

@@ -24,6 +24,45 @@
     (define/override (type-check env)
       (lambda (e)
         (match e
+          [`(vector-ref ,(app (type-check env) e t) ,i)
+           (match t
+             [`(Vector ,ts ...)
+              (unless (and (exact-nonnegative-integer? i)
+                           (i . < . (length ts)))
+                (error 'type-check "invalid index ~a" i))
+              (let ([t (list-ref ts i)])
+                (values `(has-type (vector-ref ,e (has-type ,i Integer)) ,t) t))]
+             [`(Vectorof ,t)
+              (unless (exact-nonnegative-integer? i)
+                (error 'type-check "invalid index ~a" i))
+              (values `(has-type (vector-ref ,e (has-type ,i Integer)) ,t) t)]
+             [else (error "expected a vector in vector-ref, not" t)])]
+          [`(vector-set! ,e-vec ,i ,e-arg) 
+           (define-values (e-vec^ t-vec) ((type-check env) e-vec))
+           (define-values (e-arg^ t-arg) ((type-check env) e-arg))
+           (match t-vec
+             [`(Vector ,ts ...)
+              (unless (and (exact-nonnegative-integer? i)
+                           (i . < . (length ts)))
+                (error 'type-check "invalid index ~a" i))
+              (unless (equal? (list-ref ts i) t-arg)
+                (error 'type-check "type mismatch in vector-set! ~a ~a" 
+                       (list-ref ts i) t-arg))
+              (values `(has-type (vector-set! ,e-vec^
+                                              (has-type ,i Integer)
+                                              ,e-arg^) Void) 'Void)]
+             [`(Vectorof ,t)
+              (unless (exact-nonnegative-integer? i)
+                (error 'type-check "invalid index ~a" i))
+              (unless (equal? t t-arg)
+                (error 'type-check "type mismatch in vector-set! ~a ~a" 
+                       t t-arg))
+              (values `(has-type (vector-set! ,e-vec^
+                                              (has-type ,i Integer)
+                                              ,e-arg^) Void) 'Void)]
+             [else (error 'type-check
+                          "expected a vector in vector-set!, not ~a"
+                          t-vec)])]
           [`(inject ,e ,ty)
 	   (define-values (new-e e-ty) ((type-check env) e))
 	   (cond
@@ -127,6 +166,7 @@
     (define (any-tag ty)
       (match ty
 	 ['Integer 0]
+	 ['Void 0]
 	 ['Boolean 1]
 	 [`(Vector ,ts ...) 2]
 	 [`(Vectorof ,t) 2]
@@ -238,7 +278,7 @@
           [`(- ,e) `(inject (- (project ,((cast-insert) e) Integer)) Integer)]
           [`(let ([,x ,e1]) ,e2) `(let ([,x ,((cast-insert) e1)]) ,((cast-insert) e2))]
           [#t `(inject #t Boolean)]
-          [#t `(inject #f Boolean)]
+          [#f `(inject #f Boolean)]
           [`(and ,e1 ,e2) (let ([gen (gensym)])
                             `(let ([,gen ,((cast-insert) e1)])
                                (if (eq? ,gen (inject #f Boolean))
@@ -247,9 +287,9 @@
           [`(not ,e) `(inject (not (project ,((cast-insert) e) Boolean)) Boolean)]
           [`(eq? ,e1 ,e2) `(inject (eq? ,((cast-insert) e1),((cast-insert) e2)) Boolean)]
           [`(if ,eq ,et ,ef) `(if (eq? ,((cast-insert) eq) (inject #t Boolean)) ,((cast-insert) et) ,((cast-insert) ef))]
-          [`(vector ,es ...) `(inject (vector ,@(map (cast-insert) es)) (Vectorof Any))]
-          [`(vector-ref ,e1 ,n) `(vector-ref (project ,((cast-insert) e1) (Vectorof Any)) n)]
-          [`(vector-set! ,e1 ,n ,e2) `(vector-set! (project ,((cast-insert) e1) (Vectorof Any)) n ,((cast-insert) e2))]
+          [`(vector ,es ...) `(inject (vector ,@(map (cast-insert) es)) (Vector ,@(map (lambda (x) 'Any) es)))]
+          [`(vector-ref ,e1 ,n) `(vector-ref (project ,((cast-insert) e1) (Vectorof Any)) ,n)]
+          [`(vector-set! ,e1 ,n ,e2) `(vector-set! (project ,((cast-insert) e1) (Vectorof Any)) ,n ,((cast-insert) e2))]
           [`(void) `(inject (void) Void)] ; ???
           [`(lambda (,xs ...) ,e) `(inject (lambda: (,@(map (lambda (x) `[,x : Any]) xs)) : Any ,((cast-insert) e)) (,@(map (lambda (x) 'Any) xs) -> Any))]
           [`(app ,e ,es ...) `(app (project ,((cast-insert) e) (,@(map (lambda (x) 'Any) es) -> Any)) ,@(map (cast-insert) es))]
@@ -335,6 +375,7 @@
            (cond
             [(lookup e funs #f) `(function-ref ,e ,(lookup e funs))]
             [else e])]
+          ['(void) '(void)]
           [`(program ,ds ... ,body) #:when (or (null? ds) (not (eq? (caar ds) 'type)))
            (define funs 
              (for/list ([d ds]) 

functions.rkt

@@ -14,7 +14,7 @@
 
     (define/public (non-apply-ast)
       (set-union (primitives)
-		 (set 'if 'let 'define 'program)))
+		 (set 'if 'let 'define 'program 'void)))
 
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ;; type-check : env -> S3 -> S3 (for programs)

int_exp.rkt

@@ -18,18 +18,19 @@
       (lambda (e)
 	(define recur (uniquify env))
 	(match e
-	   [(? symbol?) (cdr (assq e env))]
-	   [(? integer?) e]
-	   [`(let ([,x ,e]) ,body)
-	    (define new-x (gensym (racket-id->c-id x)))
-	    (define new-e (recur e))
-	    `(let ([,new-x ,new-e])
+          ['(void) '(void)]
+          [(? symbol?) (cdr (assq e env))]
+          [(? integer?) e]
+          [`(let ([,x ,e]) ,body)
+           (define new-x (gensym (racket-id->c-id x)))
+           (define new-e (recur e))
+           `(let ([,new-x ,new-e])
 	       ,((uniquify (cons (cons x new-x) env)) body))]
-	   [`(program ,body)
-	    `(program ,(recur body))]
-	   [`(,op ,es ...) #:when (set-member? (primitives) op)
-	    `(,op ,@(map recur es))]
-	   [else (error "uniquify couldn't match" e)])))
+          [`(program ,body)
+           `(program ,(recur body))]
+          [`(,op ,es ...) #:when (set-member? (primitives) op)
+           `(,op ,@(map recur es))]
+          [else (error "uniquify couldn't match" e)])))
 
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ;; flatten : Bool -> S0 -> C0-expr x (C0-stmt list)

run-tests.rkt

@@ -42,7 +42,7 @@
     (3 . ,(range 1 20))
     (4 . ,(range 0 8))
     (6 . ,(range 0 8))
-    (7 . ,(range 0 3))
+    (7 . ,(range 0 8))
     ))
 
 (define (suite-range x)

vectors.rkt

@@ -21,6 +21,7 @@
       (lambda (e)
         (vomit "vectors/type-check" e env)
 	(match e
+          ['(void) (values '(has-type (void) Void) 'Void)]
           [`(vector ,(app (type-check env) e* t*) ...)
            (let ([t `(Vector ,@t*)])
              (values `(has-type (vector ,@e*) ,t) t))]
@@ -62,9 +63,13 @@
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ;; uniqueify : S1 -> C1-expr x (C1-stmt list)
 
+
+
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ;; flatten : S1 -> C1-expr x (C1-stmt list)
 
+    
+
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     ;; expose allocation : C1 -> ?
 
@@ -165,6 +170,7 @@
     (define/public (uncover-call-live-roots-exp e)
       (vomit "uncover-call-live-roots-exp" e)
       (match e
+        [`(has-type (void) ,t) (set)]
         [`(has-type ,(? symbol? x) ,t)
          (if (root-type? t)
              (set x)
@@ -239,6 +245,7 @@
     (lambda (x)
       (vomit "select instructions" x)
       (match x
+        [`(void) `(int 0)]
         [`(assign ,lhs (has-type (allocate ,length) (Vector ,ts ...)))
          (define lhs^ ((select-instructions) lhs))
          ;; Add one quad word for the meta info tag