some fixes to R6 passes

Author: jsiek

dynamic-typing.rkt

@@ -32,7 +32,8 @@
                            (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))]
+                (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))
@@ -401,6 +402,7 @@
 (define R6-typechecker
   (let ([compiler (new compile-R6)])
     (send compiler type-check '())))
+
 (define R6-passes
   (let ([compiler (new compile-R6)]
         [interp (new interp-R6)])
@@ -410,9 +412,9 @@
       ("uniquify" ,(send compiler uniquify '())
        ,(send interp interp-scheme '()))
       ("reveal-functions" ,(send compiler reveal-functions '())
-       ,(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"
@@ -448,9 +450,9 @@
        ,(interp-r7 '()))
       ("reveal-functions" ,(send compiler reveal-functions '())
        ,(interp-r7 '()))
-      ("translate" ,(send compiler cast-insert)
+      ("cast-insert" ,(send compiler cast-insert)
        ,(send interp interp-scheme '()))
-      ("inserthastype" ,(send compiler type-check '())
+      ("type-check" ,(send compiler type-check '())
        ,(send interp interp-scheme '()))
       ("convert-to-closures" ,(send compiler convert-to-closures)
        ,(send interp interp-scheme '()))

interp.rkt

@@ -47,12 +47,12 @@
            [(? symbol?)
 	    (lookup ast env)]
 	   [(? integer?) ast]
-	   [`(let ([,x ,e]) ,body)
-	    (let ([v ((interp-scheme env) e)])
-	      ((interp-scheme (cons (cons x v) env)) body))]
+	   [`(let ([,x ,(app (interp-scheme env) v)]) ,body)
+	    ((interp-scheme (cons (cons x v) env)) body)]
 	   [`(program ,e) ((interp-scheme '()) e)]
-	   [`(,op ,args ...) #:when (set-member? (primitives) op)
-	    (apply (interp-op op) (map (interp-scheme env) args))]
+	   [`(,op ,(app (interp-scheme env) args) ...)
+	    #:when (set-member? (primitives) op)
+	    (apply (interp-op op) args)]
 	   [else
 	    (error (format "no match in interp-scheme S0 for ~a" ast))]
 	   )))
@@ -979,23 +979,36 @@
     (define/override (interp-scheme env)
       (lambda (ast)
         (verbose "R6/interp-scheme" ast)
+	(define recur (interp-scheme env))
 	(match ast
-          [`(inject ,e ,t)
-	   `(tagged ,((interp-scheme env) e) ,t)]
-	  [`(project ,e ,t2)
-	   (define v ((interp-scheme env) e))
+          [`(inject ,(app recur v) ,t)
+	   `(tagged ,v ,t)]
+	  [`(project ,(app recur v) ,t2)
 	   (match v
 	      [`(tagged ,v1 ,t1)
-	       (cond [(tyeq? t1 t2)
-		      v1]
-		     [else
-		      (error "in project, type mismatch" t1 t2)])]
-	      [else
-	       (error "in project, expected injected value" v)])]
+	       (cond [(tyeq? t1 t2) v1]
+		     [else (error "in project, type mismatch" t1 t2)])]
+	      [else (error "in project, expected injected value" v)])]
 	  [else 
 	   ((super interp-scheme env) ast)]
 	  )))
 
+    (define/override (interp-F env)
+      (lambda (ast)
+        (verbose "R6/interp-F" ast)
+	(define recur (interp-F env))
+        (match ast
+          [`(inject ,(app recur v) ,t)
+	   `(tagged ,v ,t)]
+	  [`(project ,(app recur v) ,t2)
+	   (match v
+	      [`(tagged ,v1 ,t1)
+	       (cond [(tyeq? t1 t2) v1]
+		     [else (error "in project, type mismatch" t1 t2)])]
+	      [else (error "in project, expected injected value" v)])]
+          [else ((super interp-F env) ast)]
+	  )))
+
     (define/override (interp-C env)
       (lambda (ast)
 	(verbose "R6/interp-C" ast)