Merge pull request #25 from cmsc430/crook

crook

abscond/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

blackmail/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

con/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

dodger/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

dupe/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

evildoer/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

extort/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

fraud/env.rkt

@@ -0,0 +1,16 @@
+#lang racket
+(provide lookup ext)
+
+;; Env Variable -> Answer
+(define (lookup env x)
+  (match env
+    ['() 'err]
+    [(cons (list y i) env)
+     (match (symbol=? x y)
+       [#t i]
+       [#f (lookup env x)])]))
+
+;; Env Variable Value -> Value
+(define (ext r x i)
+  (cons (list x i) r))
+

fraud/interp.rkt

@@ -3,6 +3,7 @@
 (provide interp-env)
 (require "ast.rkt")
 (require "interp-prim.rkt")
+(require "env.rkt")
 
 ;; type Value =
 ;; | Integer
@@ -51,15 +52,3 @@
        ['err 'err]
        [v (interp-env e2 (ext r x v))])]))
 
-;; Env Id -> Value
-(define (lookup r x)
-  (match r
-    [(cons (list y val) r)
-     (if (symbol=? x y)
-         val
-         (lookup r x))]))
-
-;; Env Id Value -> Env
-(define (ext r x v)
-  (cons (list x v) r))
-

hoax/env.rkt

@@ -12,4 +12,5 @@
 
 ;; Env Variable Value -> Value
 (define (ext r x i)
-  (cons (list x i) r))
+  (cons (list x i) r))
+

hoax/heap-bits.rkt

@@ -0,0 +1,69 @@
+#lang racket
+(require "types.rkt")
+(provide (struct-out heap) heap-ref heap-set!
+         alloc-box alloc-cons
+         alloc-vect alloc-str)
+
+(struct heap ([n #:mutable] bytes))
+
+;; Value* Heap -> Value*
+(define (alloc-box v h)
+  (match h
+    [(heap n bs)
+     (heap-set! h n v)
+     (set-heap-n! h (+ n 8))
+     (bitwise-xor n type-box)]))
+
+;; Value* Value* Heap -> Value*
+(define (alloc-cons v1 v2 h)
+  (match h
+    [(heap n bs)
+     (heap-set! h (+ n 0) v1)
+     (heap-set! h (+ n 8) v2)
+     (set-heap-n! h (+ n 16))
+     (bitwise-xor n type-cons)]))
+
+;; [Listof Value*] Heap -> Value*
+(define (alloc-vect vs h)
+  (match h
+    [(heap n bs)
+     (heap-set! h n (arithmetic-shift (length vs) int-shift))
+     (write-values! h vs (+ n 8))
+     (set-heap-n! h (+ n (* 8 (add1 (length vs)))))
+     (bitwise-xor n type-vect)]))
+
+;; [Listof CharBits] Heap -> Value*
+(define (alloc-str cs h)
+  (match h
+    [(heap n bs)
+     (heap-set! h n (arithmetic-shift (length cs) int-shift))
+     (write-values! h cs (+ n 8))
+     (set-heap-n! h (+ n (* 8 (add1 (length cs)))))
+     (bitwise-xor n type-str)]))
+
+
+;; Heap [Listof Value*] Natural -> Void
+(define (write-values! h vs i)
+  (match vs
+    ['() (void)]
+    [(cons v vs)
+     (heap-set! h i v)
+     (write-values! h vs (+ i 8))]))
+
+;; Heap Address -> Value*
+(define (heap-ref h a)
+  (integer-bytes->integer (heap-bytes h) #t #f a (+ a 8)))
+
+;; Heap Address Natural -> [Listof Value*]
+(define (heap-ref/n h a n)
+  (define (loop n vs)
+    (match n
+      [0 vs]
+      [_ (loop (sub1 n)
+               (cons (heap-ref h (+ a n)) vs))]))
+  (loop n '()))
+
+;; Heap Address Value* -> Void
+(define (heap-set! h i v)
+  (integer->integer-bytes v 8 (negative? v) #f (heap-bytes h) i))
+

hoax/heap.rkt

@@ -0,0 +1,50 @@
+#lang racket
+(provide alloc-box alloc-cons heap-ref heap-set
+         (struct-out box-ptr)
+         (struct-out cons-ptr)
+         heap-ref/n
+         alloc-vect alloc-str
+         (struct-out vect-ptr)
+         (struct-out str-ptr))
+
+(struct box-ptr (i))
+(struct cons-ptr (i))
+(struct vect-ptr (i))
+(struct str-ptr (i))
+
+;; Value* Heap -> Answer*
+(define (alloc-box v h)
+  (cons (cons v h)
+        (box-ptr (length h))))
+
+;; Value* Value* Heap -> Answer*
+(define (alloc-cons v1 v2 h)
+  (cons (cons v2 (cons v1 h))
+        (cons-ptr (length h))))
+
+;; [Listof Value*] Heap -> Answer*
+(define (alloc-vect vs h)
+  (cons (append (reverse (cons (length vs) vs)) h)
+        (vect-ptr (length h))))
+
+;; [Listof Char] Heap -> Answer*
+(define (alloc-str cs h)
+  (cons (append (reverse (cons (length cs) cs)) h)
+        (str-ptr (length h))))
+
+;; Heap Address -> Value*
+(define (heap-ref h a)
+  (list-ref h (- (length h) (add1 a))))
+
+;; Heap Address Value* -> Heap
+(define (heap-set h i v)
+  (list-set h (- (length h) i 1) v))
+
+;; Heap Address Natural -> [Listof Value*]
+(define (heap-ref/n h a n)
+  (define (loop n vs)
+    (match n
+      [0 vs]
+      [_ (loop (sub1 n)
+               (cons (heap-ref h (+ a n)) vs))]))
+  (loop n '()))

hoax/interp-heap-bits.rkt

@@ -0,0 +1,85 @@
+#lang racket
+(provide interp)
+(require "ast.rkt")
+(require "types.rkt")
+(require "env.rkt")
+(require "heap-bits.rkt")
+(require "interp-prims-heap-bits.rkt")
+(require "unload-bits.rkt")
+
+(define *heap-size* 100000) ; # words in heap
+
+;; type Answer* =
+;; | Value*
+;; | 'err
+
+;; type Value* =
+;; | (value->bits Integer)
+;; | (value->bits Boolean)
+;; | (value->bits Character)
+;; | (value->bits Eof)
+;; | (value->bits Void)
+;; | (value->bits '())
+;; | (bitwise-xor Address type-box)
+;; | (bitwise-xor Address type-cons)
+
+;; type Address = Natural divisible by 8
+
+;; type Heap = (heap Address Bytes)
+
+;; type REnv = (Listof (List Id Value*))
+
+;; Expr -> Value
+(define (interp e)
+  (define h (heap 0 (make-bytes (* 8 *heap-size*) 0)))
+  (unload h (interp-env-heap-bits e '() h)))
+
+;; Expr REnv Heap -> Answer*
+(define (interp-env-heap-bits e r h)
+  (match e
+    [(Lit (? string? s)) (alloc-str (map value->bits (string->list s)) h)]
+    [(Lit d) (value->bits d)]
+    [(Eof)   (value->bits eof)]
+    [(Var x) (lookup r x)]
+    [(Prim0 p) (interp-prim0 p h)]
+    [(Prim1 p e)
+     (match (interp-env-heap-bits e r h)
+       ['err 'err]
+       [v
+        (interp-prim1 p v h)])]
+    [(Prim2 p e1 e2)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [v1
+        (match (interp-env-heap-bits e2 r h)
+          ['err 'err]
+          [v2
+           (interp-prim2 p v1 v2 h)])])]
+    [(Prim3 p e1 e2 e3)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [v1
+        (match (interp-env-heap-bits e2 r h)
+          ['err 'err]
+          [v2
+           (match (interp-env-heap-bits e3 r h)
+             ['err 'err]
+             [v3
+              (interp-prim3 p v1 v2 v3 h)])])])]
+    [(If p e1 e2)
+     (match (interp-env-heap-bits p r h)
+       ['err 'err]
+       [v
+        (if (= v (value->bits #f))
+            (interp-env-heap-bits e2 r h)
+            (interp-env-heap-bits e1 r h))])]
+    [(Begin e1 e2)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [_ (interp-env-heap-bits e2 r h)])]
+    [(Let x e1 e2)
+     (match (interp-env-heap-bits e1 r h)
+       ['err 'err]
+       [v
+        (interp-env-heap-bits e2 (ext r x v) h)])]))
+