From 74aa7392b12567d2a197bf13a21c6f3d8353d40f Mon Sep 17 00:00:00 2001 From: dvanhorn Date: Wed, 4 Dec 2024 02:51:01 +0000 Subject: [PATCH] crook --- hoax/env.rkt | 3 +- hoax/heap.rkt | 50 +++++++++++++++++++++++ hoax/interp-heap.rkt | 81 ++++++++++++++++++++++++++++++++++++++ hoax/interp-prims-heap.rkt | 80 +++++++++++++++++++++++++++++++++++++ hoax/test/interp-heap.rkt | 11 ++++++ hoax/unload.rkt | 29 ++++++++++++++ hustle/heap.rkt | 12 +++++- hustle/interp-heap.rkt | 1 + 8 files changed, 265 insertions(+), 2 deletions(-) create mode 100644 hoax/heap.rkt create mode 100644 hoax/interp-heap.rkt create mode 100644 hoax/interp-prims-heap.rkt create mode 100644 hoax/test/interp-heap.rkt create mode 100644 hoax/unload.rkt diff --git a/hoax/env.rkt b/hoax/env.rkt index c43be9c..5c2ab01 100644 --- a/hoax/env.rkt +++ b/hoax/env.rkt @@ -12,4 +12,5 @@ ;; Env Variable Value -> Value (define (ext r x i) - (cons (list x i) r)) \ No newline at end of file + (cons (list x i) r)) + diff --git a/hoax/heap.rkt b/hoax/heap.rkt new file mode 100644 index 0000000..1b6e57b --- /dev/null +++ b/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 '())) diff --git a/hoax/interp-heap.rkt b/hoax/interp-heap.rkt new file mode 100644 index 0000000..9244824 --- /dev/null +++ b/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)])])) + diff --git a/hoax/interp-prims-heap.rkt b/hoax/interp-prims-heap.rkt new file mode 100644 index 0000000..df7dbaa --- /dev/null +++ b/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)))) + diff --git a/hoax/test/interp-heap.rkt b/hoax/test/interp-heap.rkt new file mode 100644 index 0000000..6ad0cb9 --- /dev/null +++ b/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))) + diff --git a/hoax/unload.rkt b/hoax/unload.rkt new file mode 100644 index 0000000..443ac00 --- /dev/null +++ b/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)))])) + diff --git a/hustle/heap.rkt b/hustle/heap.rkt index 5eae8cb..d06911a 100644 --- a/hustle/heap.rkt +++ b/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 '())) diff --git a/hustle/interp-heap.rkt b/hustle/interp-heap.rkt index e10840f..9d9c198 100644 --- a/hustle/interp-heap.rkt +++ b/hustle/interp-heap.rkt @@ -19,6 +19,7 @@ ;; | (box-ptr Address) ;; | (cons-ptr Address) + ;; type Address = Natural ;; type Heap = (Listof Value*)