crook

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.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.rkt

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

hoax/interp-prims-heap.rkt

@@ -0,0 +1,80 @@
+#lang racket
+(provide interp-prim0 interp-prim1 interp-prim2 interp-prim3)
+(require "heap.rkt")
+
+;; Op0 Heap -> Answer*
+(define (interp-prim0 op h)
+  (match op
+    ['read-byte (cons h (read-byte))]
+    ['peek-byte (cons h (peek-byte))]
+    ['void      (cons h (void))]))
+
+;; Op1 Value* Heap -> Answer*
+(define (interp-prim1 p v h)
+  (match (list p v)
+    [(list 'add1 (? integer? i))          (cons h (add1 i))]
+    [(list 'sub1 (? integer? i))          (cons h (sub1 i))]
+    [(list 'zero? (? integer? i))         (cons h (zero? i))]
+    [(list 'char? v)                      (cons h (char? v))]
+    [(list 'char->integer (? char?))      (cons h (char->integer v))]
+    [(list 'integer->char (? codepoint?)) (cons h (integer->char v))]
+    [(list 'eof-object? v)                (cons h (eof-object? v))]
+    [(list 'write-byte (? byte?))         (cons h (write-byte v))]
+    [(list 'box v)                        (alloc-box v h)]
+    [(list 'unbox (box-ptr i))            (cons h (heap-ref h i))]
+    [(list 'car   (cons-ptr i))           (cons h (heap-ref h i))]
+    [(list 'cdr   (cons-ptr i))           (cons h (heap-ref h (add1 i)))]
+    [(list 'empty? v)                     (cons h (empty? v))]
+    [(list 'vector? v)                    (cons h (vect-ptr? v))]
+    [(list 'string? v)                    (cons h (str-ptr? v))]
+    [(list 'vector-length (vect-ptr a))   (cons h (heap-ref h a))]
+    [(list 'string-length (str-ptr a))    (cons h (heap-ref h a))]
+    [_                                    'err]))
+
+;; Op2 Value* Value* Heap -> Answer*
+(define (interp-prim2 p v1 v2 h)
+  (match (list p v1 v2)
+    [(list '+ (? integer? i1) (? integer? i2)) (cons h (+ i1 i2))]
+    [(list '- (? integer? i1) (? integer? i2)) (cons h (- i1 i2))]
+    [(list '< (? integer? i1) (? integer? i2)) (cons h (< i1 i2))]
+    [(list '= (? integer? i1) (? integer? i2)) (cons h (= i1 i2))]
+    [(list 'eq? v1 v2)
+     (match (list v1 v2)
+       [(list (cons-ptr a1) (cons-ptr a2)) (cons h (= a1 a2))]
+       [(list (box-ptr a1)  (box-ptr a2))  (cons h (= a1 a2))]
+       [_                                  (cons h (eqv? v1 v2))])]
+    [(list 'cons v1 v2) (alloc-cons v1 v2 h)]
+    [(list 'make-vector (? integer? i) v)
+     (if (< i 0)
+         'err
+         (alloc-vect (make-list i v) h))]
+    [(list 'vector-ref (vect-ptr a) (? integer? i))
+     (if (<= 0 i (sub1 (heap-ref h a)))
+         (cons h (heap-ref h (+ a i 1)))
+         'err)]
+    [(list 'make-string (? integer? i) (? char? c))
+     (if (< i 0)
+         'err
+         (alloc-str (make-list i c) h))]
+    [(list 'string-ref (str-ptr a) (? integer? i))
+     (if (<= 0 i (sub1 (heap-ref h a)))
+         (cons h (heap-ref h (+ a i 1)))
+         'err)]
+    [_ 'err]))
+
+;; Op3 Value* Value* Value* Heap -> Answer*
+(define (interp-prim3 p v1 v2 v3 h)
+  (match (list p v1 v2 v3)
+    [(list 'vector-set! (vect-ptr a) (? integer? i) v)
+     (if (<= 0 i (sub1 (heap-ref h a)))
+         (cons (heap-set h (+ a i 1) v)
+               (void))
+         'err)]
+    [_ 'err]))
+
+;; Any -> Boolean
+(define (codepoint? v)
+  (and (integer? v)
+       (or (<= 0 v 55295)
+           (<= 57344 v 1114111))))
+

hoax/test/interp-heap.rkt

@@ -0,0 +1,11 @@
+#lang racket
+(require "test-runner.rkt")
+(require "../parse.rkt")
+(require "../interp-heap.rkt")
+(require "../interp-io.rkt")
+
+(test (λ (e) (interp (parse e))))
+
+;; FIXME: this is not running a heap-based interpreter!
+(test/io (λ (s e) (interp/io (parse e) s)))
+

hoax/unload.rkt

@@ -0,0 +1,29 @@
+#lang racket
+(provide unload unload-value)
+(require "heap.rkt")
+
+;; Answer* -> Answer
+(define (unload a)
+  (match a
+    ['err 'err]
+    [(cons h v) (unload-value v h)]))
+
+;; Value* Heap -> Value
+(define (unload-value v h)
+  (match v
+    [(? integer?)    v]
+    [(? boolean?)    v]
+    [(? char?)       v]
+    [(? eof-object?) v]
+    [(? void?)       v]
+    ['()             '()]
+    [(box-ptr a)
+     (box (unload-value (heap-ref h a) h))]
+    [(cons-ptr a)
+     (cons (unload-value (heap-ref h a) h)
+           (unload-value (heap-ref h (add1 a)) h))]
+    [(vect-ptr a)
+     (apply vector (heap-ref/n h a (heap-ref h a)))]
+    [(str-ptr a)
+     (apply string (heap-ref/n h a (heap-ref h a)))]))
+

hustle/heap.rkt

@@ -1,5 +1,7 @@
 #lang racket
-(provide alloc-box alloc-cons heap-ref heap-set box-ptr cons-ptr)
+(provide alloc-box alloc-cons heap-ref heap-set
+         (struct-out box-ptr)
+         (struct-out cons-ptr))
 
 (struct box-ptr (i))
 (struct cons-ptr (i))
@@ -22,3 +24,11 @@
 (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 '()))

hustle/interp-heap.rkt

@@ -19,6 +19,7 @@
 ;; | (box-ptr  Address)
 ;; | (cons-ptr Address)
 
+
 ;; type Address = Natural
 
 ;; type Heap = (Listof Value*)