made some progress

Author: jsiek

dynamic-interp.rkt

@@ -3,10 +3,10 @@
 (require "utilities.rkt" (prefix-in runtime-config: "runtime-config.rkt"))
 (provide interp-r7)
 
-(define get-injected-type
+(define get-tagged-type
   (lambda (e)
     (match e
-      [`(inject ,v ,ty) ty])))
+      [`(tagged ,v ,ty) ty])))
 
 (define valid-op?
   (lambda (op)
@@ -15,36 +15,37 @@
 (define interp-r7-op
   (lambda (op es)
     (match `(,op ,es)
-      [`(+ ((inject ,v1 Integer) (inject ,v2 Integer)))
-       `(inject ,(fx+ v1 v2) Integer)]
-      [`(- ((inject ,v Integer)))
-       `(inject ,(fx- 0 v) Integer)]
+      [`(+ ((tagged ,v1 Integer) (tagged ,v2 Integer)))
+       `(tagged ,(fx+ v1 v2) Integer)]
+      [`(- ((tagged ,v Integer)))
+       `(tagged ,(fx- 0 v) Integer)]
       [`(and (,v1 ,v2))
        (match v1
-         [`(inject #f Boolean) v1]
+         [`(tagged #f Boolean) v1]
          [else v2])]
       [`(or (,v1 ,v2))
        (match v1
-         [`(inject #f Boolean) v2]
+         [`(tagged #f Boolean) v2]
          [else v1])]
       [`(not (,v1))
        (match v1
-         [`(inject #f Boolean) `(inject #t Boolean)]
-         [else `(inject #f Boolean)])])))
+         [`(tagged #f Boolean) `(tagged #t Boolean)]
+         [else `(tagged #f Boolean)])])))
 
 (define (interp-r7 env)
   (lambda (ast)
     (vomit "interp-r7" ast env)
+    (define recur (interp-r7 env))
     (match ast
       [(? symbol?) (lookup ast env)]
       [`(function-ref ,f) (lookup f env)]
       [`(function-ref ,f ,n) (lookup f env)] ;; This is to deal with the detail of our translation that it keeps the arity of functions in the funref 
-      [(? integer?) `(inject ,ast Integer)]
-      [#t `(inject #t Boolean)]
-      [#f `(inject #f Boolean)]
-      [`(read) `(inject ,(read-fixnum) Integer)]
+      [(? integer?) `(tagged ,ast Integer)]
+      [#t `(tagged #t Boolean)]
+      [#f `(tagged #f Boolean)]
+      [`(read) `(tagged ,(read-fixnum) Integer)]
       [`(lambda (,xs ...) ,body)
-       `(inject (lambda ,xs ,body ,env) (,@(map (lambda (x) 'Any) xs) -> Any))]
+       `(tagged (lambda ,xs ,body ,env) (,@(map (lambda (x) 'Any) xs) -> Any))]
       [`(define (,f ,xs ...) ,body)
        (mcons f `(lambda ,xs ,body))]
       [`(program ,ds ... ,body)
@@ -53,50 +54,50 @@
          (for/list ([b top-level])
            (set-mcdr! b (match (mcdr b)
                           [`(lambda ,xs ,body)
-                           `(inject (lambda ,xs ,body ,top-level) 
+                           `(tagged (lambda ,xs ,body ,top-level) 
                                     (,@(map (lambda (x) 'Any) xs) -> Any))])))
          ((interp-r7 top-level) body))]
       [`(vector ,es ...)
-       (let* ([elts (map (interp-r7 env) es)]
-              [tys (map get-injected-type elts)])
-         `(inject ,(apply vector (map (interp-r7 env) es)) (Vector ,@tys)))]
+       (let* ([elts (map recur es)]
+              [tys (map get-tagged-type elts)])
+         `(tagged ,(apply vector (map recur es)) (Vector ,@tys)))]
       [`(vector-set! ,e1 ,n ,e2)
-       (let ([e1^ ((interp-r7 env) e1)]
-             [e2^ ((interp-r7 env) e2)])
+       (let ([e1^ (recur e1)]
+             [e2^ (recur e2)])
          (match e1^ 
-           [`(inject ,vec ,ty) 
+           [`(tagged ,vec ,ty) 
             (vector-set! vec n e2^)
-            `(inject (void) Void)]))]
+            `(tagged (void) Void)]))]
       [`(vector-ref ,e ,n)
-       (let ([e^ ((interp-r7 env) e)])
+       (let ([e^ (recur e)])
          (match e^ 
-           [`(inject ,vec ,ty) 
+           [`(tagged ,vec ,ty) 
             (vector-ref vec n)]))]
       [`(let ([,x ,e]) ,body)
-       (let ([v ((interp-r7 env) e)])
+       (let ([v (recur e)])
          ((interp-r7 (cons (cons x v) env)) body))]
       [`(,op ,es ...) #:when (valid-op? op)
-       (interp-r7-op op (map (interp-r7 env) es))]
+       (interp-r7-op op (map recur es))]
       [`(eq? ,l ,r)
-       `(inject ,(equal? ((interp-r7 env) l) ((interp-r7 env) r)) Boolean)]
+       `(tagged ,(equal? (recur l) (recur r)) Boolean)]
       [`(if ,q ,t ,f)
-       (match ((interp-r7 env) q)
-         [`(inject #f Boolean)
-          ((interp-r7 env) f)]
-         [else ((interp-r7 env) t)])]
+       (match (recur q)
+         [`(tagged #f Boolean)
+          (recur f)]
+         [else (recur t)])]
       [`(app ,f ,es ...) 
-       (define new-args (map (interp-r7 env) es))
-       (let ([f-val ((interp-r7 env) f)])
+       (define new-args (map recur es))
+       (let ([f-val (recur f)])
          (match f-val 
-           [`(inject (lambda (,xs ...) ,body ,lam-env) ,ty)
+           [`(tagged (lambda (,xs ...) ,body ,lam-env) ,ty)
             (define new-env (append (map cons xs new-args) lam-env))
             ((interp-r7 new-env) body)]
            [else (error "interp-r7, expected function, not" f-val)]))]
       [`(,f ,es ...)
-       (define new-args (map (interp-r7 env) es))
-       (let ([f-val ((interp-r7 env) f)])
+       (define new-args (map recur es))
+       (let ([f-val (recur f)])
          (match f-val 
-           [`(inject (lambda (,xs ...) ,body ,lam-env) ,ty)
+           [`(tagged (lambda (,xs ...) ,body ,lam-env) ,ty)
             (define new-env (append (map cons xs new-args) lam-env))
             ((interp-r7 new-env) body)]
            [else (error "interp-r7, expected function, not" f-val)]))])))

dynamic-typing.rkt

@@ -24,8 +24,9 @@
 
     (define/override (type-check env)
       (lambda (e)
+	(define recur (type-check env))
         (match e
-          [`(vector-ref ,(app (type-check env) e t) ,i)
+          [`(vector-ref ,(app recur e t) ,i)
            (match t
              [`(Vector ,ts ...)
               (unless (and (exact-nonnegative-integer? i)
@@ -39,9 +40,8 @@
                 (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))
+          [`(vector-set! ,(app recur e-vec^ t-vec) ,i 
+			 ,(app recur e-arg^ t-arg) )
            (match t-vec
              [`(Vector ,ts ...)
               (unless (and (exact-nonnegative-integer? i)
@@ -65,22 +65,20 @@
              [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))
+          [`(inject ,(app recur new-e e-ty) ,ty)
 	   (cond
 	    [(equal? e-ty ty)
 	     (values `(has-type (inject ,new-e ,ty) Any) 'Any)]
 	    [else
 	     (error "injected expression does not have expected type" e ty)])]
-	  [`(project ,e ,ty)
-	   (define-values (new-e e-ty) ((type-check env) e))
+	  [`(project ,(app recur new-e e-ty) ,ty)
 	   (cond
 	    [(equal? e-ty 'Any)
 	     (values `(has-type (project ,new-e ,ty) ,ty) ty)]
 	    [else
 	     (error "project expression does not have type Any" e)])]
 	  [`(,pred ,e) #:when (set-member? type-predicates pred)
-	   (define-values (new-e e-ty) ((type-check env) e))
+	   (define-values (new-e e-ty) (recur e))
 	   (cond
 	    [(equal? e-ty 'Any)
 	     (values `(has-type (,pred ,new-e) Boolean) 'Boolean)]
@@ -451,11 +449,11 @@
       ("reveal-functions" ,(send compiler reveal-functions '())
        ,(interp-r7 '()))
       ("cast-insert" ,(send compiler cast-insert)
-       ,(send interp interp-scheme '()))
+       ,(send interp interp-F '()))
       ("type-check" ,(send compiler type-check '())
-       ,(send interp interp-scheme '()))
+       ,(send interp interp-F '()))
       ("convert-to-closures" ,(send compiler convert-to-closures)
-       ,(send interp interp-scheme '()))
+       ,(send interp interp-F '()))
       ("flatten" ,(send compiler flatten #f)
        ,(send interp interp-C '()))
       ("expose allocation"

interp.rkt

@@ -520,6 +520,14 @@
         ['vector-set! vector-set!]
         [else (super interp-op op)]))
 
+    (define/override (interp-scheme env)
+      (lambda (ast)
+        (verbose "R2/interp-scheme" ast)
+	(match ast
+          [`(void) (void)]
+          [else ((super interp-scheme env) ast)]
+          )))
+
     (define (mem-error message expr)
       (lambda (who fmt . args)
         (error who "~a in ~a raise error:\n~a"
@@ -546,6 +554,7 @@
       (lambda (ast)
         (vomit "R2/interp-C" ast)
         (match ast
+          [`(void) (void)]
           ;; I should do better than make these noops - andre
           [`(initialize ,s ,h)
            (unless (and (exact-nonnegative-integer? s)
@@ -690,7 +699,7 @@
 
     (define/public (non-apply-ast)
       (set-union (primitives)
-		 (set 'if 'let 'define 'program 'has-type)))
+		 (set 'if 'let 'define 'program 'has-type 'void)))
 
     (define/override (interp-scheme env)
       (lambda (ast)
@@ -719,7 +728,7 @@
         (verbose "R3/interp-F" ast)
 	(define result
         (match ast
-	  ;; For R3
+	  ;; For R4
           [`(define (,f [,xs : ,ps] ...) : ,rt ,body)
            (cons f `(lambda ,xs ,body))]
           [`(function-ref ,f)
@@ -737,7 +746,9 @@
           [`(program ,ds ... ,body)
            (let ([top-level (map  (interp-F '()) ds)])
 	      ((interp-F top-level) body))]
-           ;; For R2
+	  ;; For R3
+          [`(void) (void)]
+          ;; For R2
           [`(has-type ,e ,t) ((interp-F env) e)]
           [#t #t]
           [#f #f]

run-tests.rkt

@@ -39,7 +39,7 @@
 (define suite-list
   `((0 . ,(range 1 28))
     (1 . ,(range 1 33))
-    (2 . ,(range 1 19))
+    (2 . ,(range 1 20))
     (3 . ,(range 1 20))
     (4 . ,(range 0 8))
     (6 . ,(range 0 10))

tests/s2_19.res

@@ -0,0 +1 @@
+#<void>

tests/s2_19.rkt

@@ -0,0 +1 @@
+(void)

vectors.rkt

@@ -243,7 +243,9 @@
     (lambda (x)
       (vomit "select instructions" x)
       (match x
-        [`(void) `(int 0)]
+        ;[`(void) `(int 0)]   I don't think this line is needed. -Jeremy
+	[`(assign ,(app (select-instructions) lhs^) (void))
+	 `((movq (int 0) ,lhs^))]
         [`(assign ,lhs (has-type (allocate ,length) (Vector ,ts ...)))
          (define lhs^ ((select-instructions) lhs))
          ;; Add one quad word for the meta info tag