update interpreters

interp-Cany.rkt

@@ -5,17 +5,19 @@
 (require "interp-Cif.rkt")
 (require "interp-Cwhile.rkt")
 (require "interp-Cvec.rkt")
+(require "interp-Cvecof.rkt")
 (require "interp-Cfun.rkt")
 (require "interp-Clambda.rkt")
 (provide interp-Cany)
 
 (define Cany-class (interp-Clambda-mixin
                     (interp-Cfun-mixin
-                     (interp-Cvec-mixin
-                      (interp-Cwhile-mixin
-                       (interp-Cif-mixin
-                        (interp-Cvar-mixin
-                         interp-Lany-prime-class)))))))
+                     (interp-Cvecof-mixin
+                      (interp-Cvec-mixin
+                       (interp-Cwhile-mixin
+                        (interp-Cif-mixin
+                         (interp-Cvar-mixin
+                          interp-Lany-prime-class))))))))
 
 (define (interp-Cany p)
   (send (new Cany-class) interp-program p))

interp-Cfun.rkt

@@ -5,6 +5,7 @@
 (require "interp-Cif.rkt")
 (require "interp-Cwhile.rkt")
 (require "interp-Cvec.rkt")
+(require "interp-Cvecof.rkt")
 (require (prefix-in runtime-config: "runtime-config.rkt"))
 (provide interp-Cfun interp-Cfun-mixin)
 
@@ -28,14 +29,14 @@
 
     (define/public (call-function fun arg-vals ast)
       (match fun
-        [`(function ,xs ,info ,blocks ,def-env)
+        [(CFunction xs info blocks def-env)
          (define f (dict-ref info 'name))
          (define f-start (symbol-append f 'start))
          (define params-args (for/list ([x xs] [arg arg-vals])
                                (cons x (box arg))))
          (define new-env (append params-args def-env))
          ((interp-tail new-env blocks) (dict-ref blocks f-start))]
-        [else (error 'interp-exp "expected function, not ~a\nin ~v" fun ast)]))
+        [else (error 'interp-exp "expected C function, not ~a\nin ~v" fun ast)]))
 
     (define/override ((interp-exp env) ast)
       (define result
@@ -59,7 +60,7 @@
     (define/override (interp-def ast)
       (match ast
         [(Def f `([,xs : ,ps] ...) rt info blocks)
-         (cons f (box `(function ,xs ((name . ,f)) ,blocks ())))]
+         (cons f (box (CFunction xs `((name . ,f)) blocks '())))]
         [else (error 'interp-def "unhandled" ast)]
         ))
 
@@ -71,8 +72,8 @@
          (define top-level (for/list ([d ds]) (interp-def d)))
          (for/list ([f (in-dict-values top-level)])
            (set-box! f (match (unbox f)
-                          [`(function ,xs ,info ,blocks ())
-                           `(function ,xs ,info ,blocks ,top-level)])))
+                          [(CFunction xs info blocks '())
+                           (CFunction xs info blocks top-level)])))
          ((interp-tail top-level '()) (TailCall (Var 'main) '()))]
         [else (error 'interp-program "unhandled ~a" ast)]
         ))
@@ -81,9 +82,10 @@
 
 (define (interp-Cfun p)
   (define Cfun-class (interp-Cfun-mixin
-                      (interp-Cvec-mixin
-                       (interp-Cwhile-mixin
-                        (interp-Cif-mixin
-                         (interp-Cvar-mixin
-                          interp-Lfun-prime-class))))))
+                      (interp-Cvecof-mixin
+                       (interp-Cvec-mixin
+                        (interp-Cwhile-mixin
+                         (interp-Cif-mixin
+                          (interp-Cvar-mixin
+                           interp-Lfun-prime-class)))))))
   (send (new Cfun-class) interp-program p))

interp-Cif.rkt

@@ -20,18 +20,19 @@
     (define/override (interp-tail env blocks)
       (lambda (t)
         (match t
+          ;; Cvar cases, repeated logic but with blocks added
           [(Return e)
            ((interp-exp env) e)]
+          [(Seq s t2)
+           (define new-env ((interp-stmt env) s))
+           ((interp-tail new-env blocks) t2)]
+          ;; Cif cases
           [(Goto l)
            ((interp-tail env blocks) (dict-ref blocks l))]
           [(IfStmt (Prim op arg*) (Goto thn-label) (Goto els-label))
            (if ((interp-exp env) (Prim op arg*))
                ((interp-tail env blocks) (dict-ref blocks thn-label))
                ((interp-tail env blocks) (dict-ref blocks els-label)))]
-          [(Seq s t2)
-           (define new-env ((interp-stmt env) s))
-           ((interp-tail new-env blocks) t2)]
-          [else ((super interp-tail env blocks) t)]
           )))
 
     (define/override (interp-program p)

interp-Clambda.rkt

@@ -5,6 +5,7 @@
 (require "interp-Cif.rkt")
 (require "interp-Cwhile.rkt")
 (require "interp-Cvec.rkt")
+(require "interp-Cvecof.rkt")
 (require "interp-Cfun.rkt")
 (require (prefix-in runtime-config: "runtime-config.rkt"))
 (provide interp-Clambda interp-Clambda-mixin)
@@ -18,18 +19,19 @@
       (match op
         ['procedure-arity
          (match-lambda
-           [(vector `(function ,xs ,info ,G ,env) vs ... `(arity ,n)) n]
+           [(vector (CFunction xs info G env) vs ... `(arity ,n)) n]
            [v (error 'interp-op "Clambda/expected function, not ~a" v)])]
         [else (super interp-op op)]))
     ))
 
 (define Clambda-class (interp-Clambda-mixin
                        (interp-Cfun-mixin
-                        (interp-Cvec-mixin
-                         (interp-Cwhile-mixin
-                          (interp-Cif-mixin
-                           (interp-Cvar-mixin
-                            interp-Llambda-prime-class)))))))
+                        (interp-Cvecof-mixin
+                         (interp-Cvec-mixin
+                          (interp-Cwhile-mixin
+                           (interp-Cif-mixin
+                            (interp-Cvar-mixin
+                             interp-Llambda-prime-class))))))))
 
 (define (interp-Clambda p)
   (send (new Clambda-class) interp-program p))

interp-Cvar.rkt

@@ -15,6 +15,8 @@
         (match s
           [(Assign (Var x) e)
            (dict-set env x ((interp-exp env) e))]
+          [else
+           (error 'interp-stmt "unmatched ~a" s)]
           )))
 
     (define/public (interp-tail env)

interp-Cvec.rkt

@@ -16,7 +16,7 @@
       (lambda (ast)
         (copious "interp-stmt" ast)
         (match ast
-          [(Prim 'vector-set! (list e-vec i e-arg))
+          #;[(Prim 'vector-set! (list e-vec i e-arg))
            ((interp-exp env) ast)
            env]
           ;; TODO: move the following to the interpreter for any

interp-Cvecof.rkt

@@ -1,12 +1,11 @@
 #lang racket
 (require "utilities.rkt")
-(require "interp-Lvecof-proxy-closure.rkt")
 (require "interp-Cvar.rkt")
 (require "interp-Cif.rkt")
 (require "interp-Cvec.rkt")
-(require "interp-Cfun.rkt")
-(require "interp-Clambda.rkt")
 (require "interp-Cwhile.rkt")
+(require "interp-Cvec.rkt")
+(require "interp-Lvecof-prime.rkt")
 (provide interp-Cvecof interp-Cvecof-mixin interp-Cvecof-class)
 
 (define (interp-Cvecof-mixin super-class)
@@ -16,22 +15,20 @@
 
     (define/override ((interp-stmt env) s)
       (match s
-        [(Prim 'vectorof-set! (list e-vec i e-arg))
+        #;[(Prim 'vectorof-set! (list e-vec i e-arg))
          ((interp-exp env) s)
          env]
         [else ((super interp-stmt env) s)]))
 
     ))
 
-
-(define interp-Cvecof-class (interp-Cvecof-mixin
-                             (interp-Cwhile-mixin
-                              (interp-Clambda-mixin
-                               (interp-Cfun-mixin
-                                (interp-Cvec-mixin
-                                 (interp-Cif-mixin
-                                  (interp-Cvar-mixin
-                                   interp-Lvecof-proxy-closure-class))))))))
+(define interp-Cvecof-class
+  (interp-Cvecof-mixin
+   (interp-Cvec-mixin
+    (interp-Cwhile-mixin
+     (interp-Cif-mixin
+      (interp-Cvar-mixin
+       interp-Lvecof-prime-class))))))
 
 (define (interp-Cvecof p)
   (send (new interp-Cvecof-class) interp-program p))

interp-Cwhile.rkt

@@ -16,7 +16,7 @@
 
     (define/override ((interp-stmt env) s)
       (match s
-        [(Prim 'read '())
+        [(Prim op es)
          ((interp-exp env) s)
          env]
         [(Assign (Var x) e)

interp-Lany-prime.rkt

@@ -1,5 +1,6 @@
 #lang racket
 (require "interp-Lvec-prime.rkt")
+(require "interp-Lvecof-prime.rkt")
 (require "interp-Lfun-prime.rkt")
 (require "interp-Llambda-prime.rkt")
 (require "interp-Lany.rkt")
@@ -29,15 +30,16 @@
          (match (recur e)
            [(Tagged v^ tg)  v^]
            [v (error 'interp-op "expected tagged value, not ~a" v)])]
-        [(Exit) (error 'interp-exp "exiting")]
         [else ((super interp-exp env) e)]))
   ))
 
 (define interp-Lany-prime-class
   (interp-Lany-prime-mixin
    (interp-Llambda-prime-mixin
     (interp-Lfun-prime-mixin
-     (interp-Lvec-prime-mixin interp-Lany-class)))))
+     (interp-Lvecof-prime-mixin
+      (interp-Lvec-prime-mixin
+       interp-Lany-class))))))
 
 (define (interp-Lany-prime p)
   (send (new interp-Lany-prime-class) interp-program p))

interp-Lany.rkt

@@ -31,7 +31,13 @@
         ['any-vector-set! (lambda (v i a)
                             (match v [(Tagged v^ tg) (vector-set! v^ i a)]))]
         ['any-vector-length (lambda (v)
-                            (match v [(Tagged v^ tg) (vector-length v^)]))]
+                              (match v [(Tagged v^ tg) (vector-length v^)]))]
+        ['any-vectorof-ref (lambda (v i)
+                             (match v [(Tagged v^ tg) (vector-ref v^ i)]))]
+        ['any-vectorof-set! (lambda (v i a)
+                              (match v [(Tagged v^ tg) (vector-set! v^ i a)]))]
+        ['any-vectorof-length (lambda (v)
+                              (match v [(Tagged v^ tg) (vector-length v^)]))]
         [else (super interp-op op)]))
 
     (define/public (apply-inject v tg) (Tagged v tg))
@@ -51,7 +57,7 @@
                               l1 (length ts))])]
               [`(,ts ... -> ,rt)
                (match v1
-                 [`(function ,xs ,body ,env)
+                 [(Function xs body env)
                   (cond [(eq? (length xs) (length ts)) v1]
                         [else
                          (error 'apply-project "arity mismatch ~a != ~a"

interp-Lcast.rkt

@@ -1,11 +1,11 @@
 #lang racket
 ;(require racket/fixnum)
 (require "utilities.rkt")
-(require "interp-Lwhile.rkt")
-(provide interp-Rcast interp-Rcast-class)
+(require "interp-Lany.rkt")
+(provide interp-Lcast interp-Lcast-class)
 
-(define interp-Rcast-class
-  (class interp-Lwhile-class
+(define interp-Lcast-class
+  (class interp-Lany-class
     (super-new)
     (inherit apply-fun apply-inject apply-project)
 
@@ -32,7 +32,7 @@
         [else (vector-length vec)]))
 
     (define/override (interp-op op)
-      (verbose "Rcast/interp-op" op)
+      (verbose "Lcast/interp-op" op)
       (match op
         ['vector-length guarded-vector-length]
         ['vector-ref guarded-vector-ref]
@@ -77,35 +77,36 @@
         [(`(Vector ,ts1 ...) `(Vector ,ts2 ...))
          (define x (gensym 'x))
          (define cast-reads (for/list ([t1 ts1] [t2 ts2])
-                              `(function (,x) ,(Cast (Var x) t1 t2) ())))
+                              (Function (list x) (Cast (Var x) t1 t2) '())))
          (define cast-writes
            (for/list ([t1 ts1] [t2 ts2])
-             `(function (,x) ,(Cast (Var x) t2 t1) ())))
+             (Function (list x) (Cast (Var x) t2 t1) '())))
          `(vector-proxy ,(vector v (apply vector cast-reads)
                                  (apply vector cast-writes)))]
         [(`(,ts1 ... -> ,rt1) `(,ts2 ... -> ,rt2))
          (define xs (for/list ([t2 ts2]) (gensym 'x)))
-         `(function ,xs ,(Cast
-                          (Apply (Value v)
-                                 (for/list ([x xs][t1 ts1][t2 ts2])
-                                   (Cast (Var x) t2 t1)))
-                          rt1 rt2) ())]
+         (Function xs (Cast
+                       (Apply (Value v)
+                              (for/list ([x xs][t1 ts1][t2 ts2])
+                                (Cast (Var x) t2 t1)))
+                       rt1 rt2)
+                   '())]
         ))
 
     (define/override ((interp-exp env) e)
       (define (recur e) ((interp-exp env) e))
-      (verbose "Rcast/interp-exp" e)
+      (verbose "Lcast/interp-exp" e)
       (define result
         (match e
           [(Value v) v]
           [(Cast e src tgt)
            (apply-cast (recur e) src tgt)]
           [else ((super interp-exp env) e)]))
-      (verbose "Rcast/interp-exp" e result)
+      (verbose "Lcast/interp-exp" e result)
       result)
 
     ))
 
-(define (interp-Rcast p)
-  (send (new interp-Rcast-class) interp-program p))
+(define (interp-Lcast p)
+  (send (new interp-Lcast-class) interp-program p))
 

interp-Ldyn.rkt

@@ -30,7 +30,7 @@
     ['void? void?]
     ['vector? vector?]
     ['vector-length vector-length]
-    ['procedure? (match-lambda [`(functions ,xs ,body ,env) #t]
+    ['procedure? (match-lambda [(Function xs body env) #t]
                                [else #f])]
     [else (error 'interp-op "unknown operator ~a" op)]))
 
@@ -73,7 +73,7 @@
       [(Int n) (Tagged n 'Integer)]
       [(Bool b) (Tagged b 'Boolean)]
       [(Lambda xs rt body)
-       (Tagged `(function ,xs ,body ,env) 'Procedure)]
+       (Tagged (Function xs body env) 'Procedure)]
       [(Prim 'vector es)
        (Tagged (apply vector (for/list ([e es]) (recur e))) 'Vector)]
       [(Prim 'vector-ref (list e1 e2))
@@ -119,7 +119,7 @@
        (check-tag new-f 'Procedure ast)
        (define f-val (Tagged-value new-f))
        (match f-val 
-         [`(function ,xs ,body ,lam-env)
+         [(Function xs body lam-env)
           (unless (eq? (length xs) (length args))
             (error 'trapped-error "number of arguments ~a != arity ~a\nin ~v"
                    (length args) (length xs) ast))
@@ -131,7 +131,7 @@
 
 (define (interp-Ldyn-def ast)
   (match ast
-    [(Def f xs rt info body) (mcons f `(function ,xs ,body ()))]))
+    [(Def f xs rt info body) (mcons f (Function xs body '()))]))
 
 ;; This version is for source code in Ldyn.
 (define (interp-Ldyn ast)
@@ -140,8 +140,8 @@
      (define top-level (map (lambda (d) (interp-Ldyn-def d)) ds))
      (for/list ([b top-level])
        (set-mcdr! b (match (mcdr b)
-                      [`(function ,xs ,body ())
-                       (Tagged `(function ,xs ,body ,top-level) 'Procedure)])))
+                      [(Function xs body '())
+                       (Tagged (Function xs body top-level) 'Procedure)])))
      (define result ((interp-Ldyn-exp top-level) body))
      (check-tag result 'Integer ast)
      (Tagged-value result)]
@@ -154,8 +154,8 @@
      (define top-level (map (lambda (d) (interp-Ldyn-def d)) ds))
      (for/list ([b top-level])
        (set-mcdr! b (match (mcdr b)
-                      [`(function ,xs ,body ())
-                       (Tagged `(function ,xs ,body ,top-level) 'Procedure)])))
+                      [(Function xs body '())
+                       (Tagged (Function xs body top-level) 'Procedure)])))
      (define result ((interp-Ldyn-exp top-level) (Apply (Var 'main) '())))
      (check-tag result 'Integer ast)
      (Tagged-value result)]))