├── code
    ├── init-store-env.rkt
    ├── primitives.rkt
    ├── top.rkt
    ├── run.rkt
    ├── semantic-domains.rkt
    ├── env.rkt
    ├── parser.rkt
    ├── ast.rkt
    ├── store-list.rkt
    └── eval-ast.rkt
├── readme
├── readme~
└── tests
    └── tests.rkt


/code/init-store-env.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | 
 4 | (provide
 5 |   make-init-store-env
 6 |   *init-store-env*
 7 |   *init-env*
 8 |   *init-store*)
 9 | 
10 | ;;; ===================
11 | ;;; Initial Environment
12 | ;;; ===================
13 | 
14 | (require "primitives.rkt")
15 | (require "store-list.rkt")
16 | (require "env.rkt")
17 | 
18 | ;;; [(listof id?) (listof storable-value?) -> (list store? env?)
19 | (define make-init-store-env
20 |   (lambda (ids vals)
21 |     (let-values ([(store refs) (new-refs (new-store) vals)])
22 |       (let ([env (extended-env
23 |                    ids refs (empty-env))])
24 |         (list store env)))))
25 | 
26 | 
27 | ;;; (list store? env?)
28 | (define *init-store-env*
29 |   (make-init-store-env
30 |        '(+  -  *  /  <  <=  eq?  0?)
31 |    (list +p -p *p /p <p <=p eq?p 0?p)))
32 | 
33 | (define *init-store* (first *init-store-env*))
34 | (define *init-env* (second *init-store-env*))
35 | 
36 | 


--------------------------------------------------------------------------------
/code/primitives.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | ;;; Primitive Procedures
 4 | ;;; --------------------
 5 | 
 6 | 
 7 | (provide
 8 |   +p -p *p /p <p <=p eq?p 0?p)
 9 | 
10 | (require "semantic-domains.ss")
11 | 
12 | (define nonzero? (and/c number? (not/c zero?)))
13 | 
14 | 
15 | (define +p
16 |   (prim-proc +
17 |     (list number? number? number?)))
18 | 
19 | (define -p
20 |   (prim-proc -
21 |     (list number? number? number?)))
22 | 
23 | (define *p
24 |   (prim-proc *
25 |     (list number? number? number?)))
26 | 
27 | (define /p
28 |   (prim-proc /
29 |     (list number? number? nonzero?)))
30 | 
31 | (define <p
32 |   (prim-proc  <
33 |     (list boolean? number? number?)))
34 | 
35 | (define <=p
36 |   (prim-proc   <=
37 |     (list boolean? number? number?)))
38 | 
39 | (define eq?p
40 |   (prim-proc eq?
41 |     (list boolean? expressible-value? expressible-value?)))
42 | 
43 | (define 0?p
44 |   (prim-proc zero?
45 |     (list boolean? number?)))
46 | 
47 | 


--------------------------------------------------------------------------------
/readme:
--------------------------------------------------------------------------------
 1 | Implemention of store passing, implicit allocation, call by value interpreter. 
 2 | 
 3 | 
 4 | 
 5 | ;;; ==================================================================
 6 | ;;; Abstract Syntax for the STORE-PASSING/IMPLICIT ALLOCATION language
 7 | ;;; ==================================================================
 8 | 
 9 | 
10 | 
11 | ;;; <ast> ::= <num-ast> |
12 | ;;;           <bool-ast> |
13 | ;;;           <id-ref-ast> |
14 | ;;;           <assume-ast> |
15 | ;;;           <ifte-ast>   |  
16 | ;;;           <rec-ast> |
17 | ;;;           <function-ast> |
18 | ;;;           <app-ast> |
19 | 
20 | ;;;           <set-ast> |
21 | ;;;           <seq-ast>
22 | 
23 | ;;; <num-ast>        ::= (number <number>)
24 | ;;; <bool-ast>       ::= (boolean <boolean>)
25 | ;;; <function-ast>   ::= (function (<id> ... ) <ast>)
26 | ;;; <app-ast>        ::= (app  <ast>  <ast> ...)
27 | ;;; <assume-ast>     ::= (assume (<bind> ...) <ast>)
28 | ;;; <bind-ast>       ::= (<id> <ast>)
29 | ;;; <id-ref-ast>     ::= (id-ref <id>)
30 | ;;; <id>             ::= <symbol>
31 | ;;; <ifte-ast>       ::= (ifte <ast> <ast> <ast>)
32 | ;;; <assume-rec-ast> ::= (assume-rec (<bind> ...) <ast>)
33 | 
34 | ;;; <set-ast>        ::= (set <id> <ast>)
35 | ;;; <seq-ast>        ::= (seq <ast> <ast> ...)
36 | 
37 | 
38 | 


--------------------------------------------------------------------------------
/readme~:
--------------------------------------------------------------------------------
 1 | Implemention of continuation passing interpreter for a call by value language
 2 | 
 3 | 
 4 | ;;; ==================================================================
 5 | ;;; Abstract Syntax for the STORE-PASSING/IMPLICIT ALLOCATION language
 6 | ;;; ==================================================================
 7 | 
 8 | 
 9 | 
10 | ;;; <ast> ::= <num-ast> |
11 | ;;;           <bool-ast> |
12 | ;;;           <id-ref-ast> |
13 | ;;;           <assume-ast> |
14 | ;;;           <ifte-ast>   |  
15 | ;;;           <rec-ast> |
16 | ;;;           <function-ast> |
17 | ;;;           <app-ast> |
18 | 
19 | ;;;           <abort-ast> |
20 | ;;;           <break-ast> |
21 | ;;;           <try-ast> |
22 | ;;;           <throw-ast> |
23 | ;;;           <letcc-ast>
24 | 
25 | ;;; <num-ast>        ::= (number <number>)
26 | ;;; <bool-ast>       ::= (boolean <boolean>)
27 | ;;; <function-ast>   ::= (function (<id> ... ) <ast>)
28 | ;;; <app-ast>        ::= (app  <ast>  <ast> ...)
29 | ;;; <assume-ast>     ::= (assume (<bind> ...) <ast>)
30 | ;;; <bind-ast>       ::= (<id> <ast>)
31 | ;;; <id-ref-ast>     ::= (id-ref <id>)
32 | ;;; <id>             ::= <symbol>
33 | ;;; <ifte-ast>       ::= (ifte <ast> <ast> <ast>)
34 | ;;; <recursive-ast>  ::= (recursive (<fbind> ...) <ast>)
35 | 
36 | ;;; <abort-ast>      ::= (abort <ast>)
37 | ;;; <break-ast>      ::= (break <ast>)
38 | ;;; <try-ast>        ::= (try <ast> <id> <ast>)
39 | ;;; <throw-ast>      ::= (throw <ast>)
40 | ;;; <letcc-ast>      ::= (letcc <id> <ast>)
41 | 
42 | 


--------------------------------------------------------------------------------
/code/top.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | ;;; ================================
 4 | ;;; Top-level setup for the language
 5 | ;;; ================================
 6 | 
 7 | (require "run.rkt")
 8 | (require "parser.rkt")
 9 | 
10 | (provide
11 |   go)
12 | 
13 | (define go
14 |   (lambda (e)
15 |     (run (parse e))))
16 | 
17 | ;;; Unit testing
18 | ;;; ============
19 | (require rackunit)
20 | 
21 | 
22 | (check-equal?
23 |   (go '(assume-rec ([f (function (n) (ifte (0? n) 1 (* n (f (- n 1)))))])
24 |          (f 3)))
25 |   6
26 |   "go-factorial")
27 | 
28 | 
29 | 
30 | (check-equal?
31 |   (go
32 |     '(assume-rec ([even? (function (n) (ifte (0? n) #t (odd? (- n 1))))]
33 |                   [odd?  (function (n) (ifte (0? n) #f (even? (- n 1))))])
34 |        (even? 3)))
35 |   #f
36 |   "go-even")
37 | 
38 | 
39 | 
40 | (check-equal?
41 |   (go
42 |     '(assume  ([! (function (n)
43 |                     (assume ([ans  1]
44 |                              [i  n])
45 |                       (assume-rec ([loop (function ()
46 |                                            (ifte
47 |                                              (eq? i 0)
48 |                                              ans
49 |                                              (seq
50 |                                                (set ans (* ans i))
51 |                                                (set i (- i 1))
52 |                                                (loop))))])
53 |                         (loop))))])
54 |        (! 3)))
55 |   6
56 |   "go-factorial-imperative")
57 | 
58 | 
59 | 
60 | 
61 | 
62 | 


--------------------------------------------------------------------------------
/tests/tests.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require "ast.rkt")
 3 | (require "init-store-env.rkt")
 4 | (require "semantic-domains.rkt")
 5 | (require "eval-ast.rkt")
 6 | (require "top.rkt")
 7 | (require "run.rkt")
 8 | (require rackunit)
 9 | (check-equal? (go '(assume-rec ([fact (function (n) (ifte (0? n) 1 (* n (fact (- n 1)))))])
10 |          (fact 4)))  24 "first testCase")
11 |     
12 | (check-equal? (go '(assume-rec ([fibo (function (n) (ifte (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))])
13 |          (fibo 3))) 3 "second testCase")
14 | 
15 | (check-equal? (go '(assume-rec ([f (function (n) (ifte (0? n) 1 (* n (f (- n 1)))))]
16 |                   [fib (function (n) (ifte (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))]
17 |                   [addfactfib (function (n) (+ (f n) (fib n)))])
18 |                   (addfactfib 3)))  9 "third testcase" )
19 | 
20 | (check-equal? (go '(assume ([fib (function (n) (* n n))]) 
21 |              (assume ([fib (function (n) (ifte (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))])
22 |                      (fib 3)))) 5 "fourth testcase")
23 | 
24 | (check-equal? (go '(assume ([fib (function (n) (* n n))]) 
25 |              (assume-rec ([fib (function (n) (ifte (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))])
26 |                      (fib 8)))) 34 "fifth testcase" ) 
27 | 
28 | 
29 | (check-equal?
30 | (run 
31 |  (assume-rec
32 |   (list
33 | (make-bind 'even?
34 | (function '(n)
35 | (ifte (app (id-ref '0?) (list (id-ref 'n)))
36 | (boolean #t)
37 | (app (id-ref 'odd?)
38 | (list (app (id-ref '-) (list (id-ref 'n) (number 1))))))
39 | ))
40 | 
41 | (make-bind 'odd?
42 | (function '(n)
43 | (ifte (app (id-ref '0?) (list (id-ref 'n)))
44 | (boolean #f)
45 | (app (id-ref 'even?)
46 | (list (app (id-ref '-) (list (id-ref 'n) (number 1))))))
47 | )))
48 | (app (id-ref 'even?) (list (number 3)))))
49 | #f
50 | "recursive-ast test")


--------------------------------------------------------------------------------
/code/run.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | ;;; ========================================
 4 | ;;; Run expression in init-env and new-store 
 5 | ;;; ========================================
 6 | 
 7 | (provide
 8 |   run)
 9 | 
10 | (require "ast.rkt")
11 | (require "init-store-env.rkt")
12 | (require "semantic-domains.rkt")
13 | (require "eval-ast.rkt")
14 | 
15 | ;;; run: ast? -> expressible-value?
16 | (define run
17 |   (lambda (ast)
18 |     (let-values ([(store val) (eval-ast ast *init-env* *init-store*)])
19 |         val)))
20 | 
21 | ;;; Unit testing
22 | ;;; ============
23 | 
24 | (require rackunit)
25 | 
26 | ;; (run (id-ref '0?))
27 |      
28 | 
29 | 
30 | (check-equal?
31 |   (run
32 |       (assume (list (make-bind 'a (number 5))
33 |                 (make-bind 'b (number 6)))
34 |         (app (id-ref '+)
35 |           (list (id-ref 'a) (id-ref 'b)))))
36 |   11 "run: assume-test")
37 | 
38 |   
39 | (check-equal?
40 |  (run
41 |   (function                 ; (function (x y z) (+ x (* y z)))
42 |    '(x y z)
43 |    (app (id-ref '+)
44 |         (list (id-ref 'x)
45 |               (app (id-ref '*)
46 |                    (list (id-ref 'y) (id-ref 'z)))))))
47 |  (closure '(x y z)
48 |    (app (id-ref '+)
49 |      (list (id-ref 'x)
50 |        (app (id-ref '*)
51 |          (list (id-ref 'y) (id-ref 'z)))))
52 |    *init-env*)
53 |  "run: function-test")
54 | 
55 | 
56 | ;;; (assume-rec ([even? (n) (if (0? n) #t (odd? (- n 1)))]
57 | ;;;             [odd?  (n) (if (0? n) #f (even? (- n 1)))])
58 | ;;;    (even? 3))
59 | 
60 | (check-equal?
61 |  (run
62 |   (assume-rec
63 |    (list
64 |     (make-bind 'even?
65 |                (function  '(n)
66 |                 (ifte (app (id-ref '0?) (list (id-ref 'n)))
67 |                       (boolean #t)
68 |                       (app (id-ref 'odd?)
69 |                            (list (app (id-ref '-)
70 |                                    (list (id-ref 'n) (number 1))))))))
71 | 
72 |     (make-bind 'odd?
73 |                (function '(n)
74 |                 (ifte (app (id-ref '0?) (list (id-ref 'n)))
75 |                       (boolean #f)
76 |                       (app (id-ref 'even?)
77 |                            (list (app (id-ref '-) (list (id-ref 'n) (number 1)))))))))
78 |    
79 |    (app (id-ref 'even?) (list (number 3)))))
80 |   #f
81 |   "run-assume-rec-test")
82 | 
83 | 
84 | 
85 | 
86 | 
87 | 
88 | 
89 | 
90 | 
91 | 
92 | 
93 | 


--------------------------------------------------------------------------------
/code/semantic-domains.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | ;;; =================================
  4 | ;;; Semantic Domains and Environments
  5 | ;;; =================================
  6 | 
  7 | (provide
  8 |   expressible-value?
  9 |   denotable-value?
 10 |   proc
 11 |   prim-proc
 12 |   closure
 13 |   proc?
 14 |   prim-proc?
 15 |   closure?
 16 |   rec-closure
 17 |   rec-closure?
 18 |   )
 19 | 
 20 | (require "env.rkt")
 21 | 
 22 | ;;; Expressible Values (types of values returned by
 23 | ;;; evaluating an ast)
 24 | 
 25 | ;;; ========================================
 26 | 
 27 | ;;; expressible-value ::=
 28 | ;;;    number | boolean | proc
 29 | 
 30 | ;;; Denotable Values (types of values denoted by
 31 | ;;; identifiers)
 32 | ;;; ============================================
 33 | 
 34 | ;;; denotable-value ::=  Ref(expressible-value)
 35 | ;;;
 36 | 
 37 | ;;; expressible-value? is the set of things that are the
 38 | ;;; results of evaluation of expressions (asts).
 39 | 
 40 | 
 41 | (require eopl/eopl)
 42 | (require "ast.rkt")
 43 | (require (prefix-in store: "store-list.rkt"))
 44 | (require "store-list.rkt")
 45 | ;;; Procedure ADT
 46 | ;;; ==============
 47 | 
 48 | (define-datatype proc proc? 
 49 |   [prim-proc (prim procedure?)
 50 |              (sig (list-of procedure?))]
 51 |   [closure  
 52 |    (formals (list-of symbol?)) 
 53 |    (body ast?) 
 54 |    (env env?)]
 55 |   [rec-closure
 56 |     (formals (list-of symbol?))
 57 |     (body ast?)])
 58 | 
 59 | 
 60 | 
 61 | ;;; Subtype Predicates
 62 | ;;; ==================
 63 | 
 64 | ;;; prim-proc? : proc? -> boolean?
 65 | (define prim-proc?
 66 |   (lambda (p)
 67 |     (cases proc p
 68 |       [prim-proc (prim sig) #t]
 69 |       [else #f])))
 70 | 
 71 | 
 72 | 
 73 | ;;; closure? : proc? -> boolean?
 74 | (define closure? 
 75 |   (lambda (p) 
 76 |     (cases proc p
 77 |       [closure (formal body env) #t]
 78 |       [else #f])))
 79 | 
 80 | 
 81 | ;;; rec-closure? : proc? -> boolean?
 82 | (define rec-closure? 
 83 |   (lambda (p)
 84 |     (cases proc p
 85 |       [rec-closure (formals body) #t]
 86 |       [else #f])))
 87 | 
 88 | 
 89 | ;;; expressible-value? : any/c -> boolean?
 90 | (define expressible-value? 
 91 |   (lambda(ex)
 92 |     (or (number? ex) 
 93 |         (boolean? ex) 
 94 |         (proc? ex))))
 95 | 
 96 | ;;; denotable-value? :any/c -> boolean?
 97 | (define denotable-value?
 98 |   (lambda(ex)
 99 |     (ref? ex)))
100 | 
101 | 
102 | 
103 | 


--------------------------------------------------------------------------------
/code/env.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | ;;; =================================
  4 | ;;; Semantic Domains and Environments
  5 | ;;; =================================
  6 | 
  7 | (provide
  8 |   env
  9 |   env?
 10 |   empty-env
 11 |   extended-env
 12 |   lookup-env  
 13 |   )
 14 | 
 15 | 
 16 | ;;; Expressible Values (types of values returned by
 17 | ;;; evaluating an ast)
 18 | 
 19 | 
 20 | (require eopl/eopl)
 21 | (require (only-in "store-list.rkt" [ref? store:ref?]))
 22 | (define-datatype env env?
 23 |   [empty-env]
 24 |   [extended-env
 25 |     (syms (list-of symbol?))
 26 |     (vals (list-of store:ref?))
 27 |     (outer-env env?)])
 28 | 
 29 | ;;; Subtype Predicates
 30 | ;;; ==================
 31 | 
 32 | ;;; empty-env? : env? -> boolean?
 33 | (define empty-env?
 34 |   (lambda (e)
 35 |     (cases env e
 36 |       [empty-env () #t]
 37 |       [else #f])))
 38 | 
 39 | ;;; extended-env? : env? -> boolean?
 40 | (define extended-env?
 41 |   (lambda (e)
 42 |     (cases env e
 43 |       [extended-env (syms vals outer-env) #t]
 44 |       [else #f])))
 45 | 
 46 | ;;; Returns the loction of the element in a list, -1 if the
 47 | ;;; element is absent.
 48 | 
 49 | ;;; list-index : [(listof any/c)  any/c] -> 
 50 | (define list-index
 51 |   (lambda (ls a)
 52 |     (letrec ([loop
 53 |                (lambda (ls ans)
 54 |                  (cond
 55 |                    [(null? ls) -1]
 56 |                    [(eq? (first ls) a) ans]
 57 |                    [#t (loop (rest ls) (+ 1 ans))]))])
 58 |       (loop ls 0))))
 59 | 
 60 | ;;; lookup-env: [env?  symbol?] -> any/c
 61 | ;;; lookup-env: throws "unbound identifier" error
 62 | (define lookup-env
 63 |   (lambda (e x)
 64 |     (cases env e
 65 |       [empty-env ()
 66 |         (error
 67 |           'lookup-env
 68 |           "unbound identifier ~a" x)]
 69 |       [extended-env (syms vals outer-env)
 70 |         (let ([j (list-index syms x)])
 71 |           (cond
 72 |             [(= j -1) (lookup-env outer-env x)]
 73 |             [#t (list-ref vals j)]))])))
 74 | 
 75 | 
 76 | ;;; Unit testing
 77 | ;;; ============
 78 | (require rackunit)
 79 | 
 80 | (check-pred env? (empty-env) "env?-empty-env")
 81 | (check-pred empty-env? (empty-env) "empty-env?-empty-env")
 82 | (check-exn exn? (lambda () (lookup-env (empty-env) 'a)) "lookup-empty-env-a")
 83 | 
 84 | (define e1
 85 |   (extended-env '(x y z) '(1 2 3) (empty-env)))
 86 | 
 87 | (check-pred env?  e1 "env?-extended-env")
 88 | (check-pred extended-env? e1 "extended-env?-extended-env")
 89 | 
 90 | (check-equal? 1 (lookup-env e1 'x) "lookup-e1-x")
 91 | (check-equal? 2 (lookup-env e1 'y) "lookup-e1-y")
 92 | (check-exn exn? (lambda () (lookup-env e1 'a)) "lookup-e1-a")
 93 | 
 94 | (define e2
 95 |   (extended-env '(w x) '(5 6) e1))
 96 | 
 97 | (check-equal? 5 (lookup-env e2 'w) "lookup-e2-w")
 98 | (check-equal? 6 (lookup-env e2 'x) "lookup-e2-x")
 99 | (check-equal? 2 (lookup-env e2 'y) "lookup-e2-y")
100 | (check-equal? 3 (lookup-env e2 'z) "lookup-e2-z")
101 | (check-exn exn? (lambda () (lookup-env e2 'a)) "lookup-e2-a")
102 | 
103 | 
104 | 
105 | 
106 | 


--------------------------------------------------------------------------------
/code/parser.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | ;;; =================================
  4 | ;;; Parser for the RECURSION language
  5 | ;;; =================================
  6 | 
  7 | ;;; Concrete Syntax
  8 | 
  9 | ;;; <exp> :=  <num> |
 10 | ;;;           <bool>
 11 | ;;;           <id> |
 12 | ;;;           (ifte <exp> <exp> <exp>) |
 13 | ;;;           (function (<id> ...) <exp) |
 14 | ;;;           (assume ([<id> <exp>] ...) <exp>) |
 15 | ;;;           (assume-rec ([<id> <exp>] ...) <exp>) |
 16 | ;;;           (set <id> <exp>) |
 17 | ;;;           (seq <exp> ...)  |
 18 | ;;;           (<exp> <exp> ...)
 19 | 
 20 | ;;; example concrete syntax
 21 | 
 22 | ;;; (assume-rec ([even? (function (n) (if (0? n) #t (odd? (sub1 n))))]
 23 | ;;;             [odd?  (function (n) (if (0? n) #f (even? (sub1 n))))])
 24 | ;;;    (even? 5))
 25 | 
 26 | (require racket/match)
 27 | 
 28 | (require "ast.rkt")
 29 | 
 30 | (provide
 31 |   parse)
 32 | 
 33 | (define *keywords*
 34 |   '(ifte function assume assume-rec seq set))
 35 | 
 36 | (define id?
 37 |   (lambda (x)
 38 |     (and
 39 |      (symbol? x)
 40 |      (not (memq x *keywords*)))))
 41 |          
 42 | 
 43 | (define parse
 44 |   (lambda (d)
 45 |     (match d
 46 |      [(? number? n) (number n)]
 47 |      [(? boolean? b) (boolean b)]
 48 |      [(? id? x) (id-ref x)]
 49 |      [(list 'ifte a b c)  (ifte (parse a) (parse b) (parse c))]
 50 | 
 51 |      [(list
 52 |        'function
 53 |        (list (? id? x) ...)
 54 |        body)
 55 |       (function x (parse body))]
 56 |      
 57 |      [(list 'assume
 58 |         (list (list (? id? x) e) ...) body)
 59 |       (let* ([a (map parse e)]
 60 |              [b (map make-bind x a)])
 61 |         (assume b (parse body)))]
 62 |      
 63 |      [(list 'assume-rec
 64 |         (list (list (? id? x) e) ...) body)
 65 |       (let* ([a (map parse e)]
 66 |              [b (map make-bind x a)])
 67 |         (assume-rec b (parse body)))]
 68 |      
 69 |      [(list 'set (? id? x) e)
 70 |       (set x (parse e))]
 71 |      
 72 |      [(list 'seq stmts ...)
 73 |       (seq (map parse stmts))]
 74 |      
 75 |      [(list rator rands ...)
 76 |       (let* ([rator (parse rator)]
 77 |              [rands (map parse rands)])
 78 |         (app rator rands))]
 79 |      [_ (error 'parse "don't know how to parse ~a" d)])))
 80 | 
 81 | 
 82 | 
 83 | ;;; Unit Testing
 84 | ;;; ============
 85 | (require rackunit)
 86 | 
 87 | 
 88 | (check-equal? (parse 4) (number 4) "parse-number")
 89 | (check-equal? (parse #t) (boolean #t) "parse-boolean")
 90 | (check-equal? (parse 'x) (id-ref 'x) "parse-id")
 91 | 
 92 | (check-equal?
 93 |  (parse '(ifte 3 4 8))
 94 |  (ifte (number 3) (number 4) (number 8))
 95 |  "parse-ifte")
 96 | 
 97 | 
 98 | (check-equal?
 99 |  (parse '(function (x y) 4))
100 |  (function '(x y) (number 4))
101 |  "parse-function")
102 | 
103 | 
104 | (check-equal?
105 |   (parse '(assume ([x 3]) 6))
106 |   (assume (list (make-bind 'x (number 3))) (number 6))
107 |   "parse-assume")
108 | 
109 | 
110 | (check-equal?
111 |   (parse '(assume-rec ([f (function (x y) x)]
112 |                        [g (function (m n) 5)])
113 |             9))
114 |   (assume-rec
115 |     (list
116 |       (make-bind 'f (function '(x y) (id-ref 'x)))
117 |       (make-bind 'g (function '(m n) (number 5))))
118 |     (number 9))
119 |   "parse-assume-rec")
120 | 
121 | 
122 | (check-equal?
123 |   (parse '(assume-rec () 9))
124 |   (assume-rec
125 |     (list)
126 |     (number 9))
127 |   "parse-empty-assume-rec")
128 | 
129 | (check-equal?
130 |   (parse '(x y))
131 |   (app (id-ref 'x)
132 |        (list (id-ref 'y)))
133 |   "parse-app")
134 | 
135 | (check-equal?
136 |   (parse '(set x 5))
137 |   (set 'x (number 5))
138 |   "parse-set")
139 | 
140 | (check-equal?
141 |    (parse '(seq (set x 5) x))
142 |    (seq (list (set 'x (number 5)) (id-ref 'x)))
143 |    "parse-seq")
144 | 
145 | 
146 | (check-exn exn? (lambda () (parse "hello")) "parse-string-error")
147 | (check-exn exn? (lambda () (parse '#(1 2))) "parse-vector-error")
148 | (check-exn exn? (lambda () (parse '(1 . 2)) "parse-cons-error"))
149 | (check-exn exn? (lambda () (parse '()) "parse-empty-error"))
150 | (check-exn exn? (lambda () (parse '(set 4 5))) "parse-set-error")
151 | 
152 | 
153 | 


--------------------------------------------------------------------------------
/code/ast.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | ;;; ==================================================================
  4 | ;;; Abstract Syntax for the STORE-PASSING/IMPLICIT ALLOCATION language
  5 | ;;; ==================================================================
  6 | 
  7 | 
  8 | 
  9 | ;;; <ast> ::= <num-ast> |
 10 | ;;;           <bool-ast> |
 11 | ;;;           <id-ref-ast> |
 12 | ;;;           <assume-ast> |
 13 | ;;;           <ifte-ast>   |  
 14 | ;;;           <rec-ast> |
 15 | ;;;           <function-ast> |
 16 | ;;;           <app-ast> |
 17 | 
 18 | ;;;           <set-ast> |
 19 | ;;;           <seq-ast>
 20 | 
 21 | ;;; <num-ast>        ::= (number <number>)
 22 | ;;; <bool-ast>       ::= (boolean <boolean>)
 23 | ;;; <function-ast>   ::= (function (<id> ... ) <ast>)
 24 | ;;; <app-ast>        ::= (app  <ast>  <ast> ...)
 25 | ;;; <assume-ast>     ::= (assume (<bind> ...) <ast>)
 26 | ;;; <bind-ast>       ::= (<id> <ast>)
 27 | ;;; <id-ref-ast>     ::= (id-ref <id>)
 28 | ;;; <id>             ::= <symbol>
 29 | ;;; <ifte-ast>       ::= (ifte <ast> <ast> <ast>)
 30 | ;;; <assume-rec-ast> ::= (assume-rec (<bind> ...) <ast>)
 31 | 
 32 | ;;; <set-ast>        ::= (set <id> <ast>)
 33 | ;;; <seq-ast>        ::= (seq <ast> <ast> ...)
 34 | 
 35 | 
 36 | (require eopl/eopl)
 37 | 
 38 | (provide
 39 |   ast
 40 |   ast?
 41 |   number
 42 |   boolean
 43 |   id-ref
 44 |   ifte
 45 |   assume
 46 |   assume-rec
 47 |   make-bind
 48 |   bind-id
 49 |   bind-ast
 50 |   function
 51 |   app
 52 |   set
 53 |   seq
 54 |   )
 55 | 
 56 | (define-datatype ast ast?
 57 |   [number (datum number?)]
 58 |   [boolean (datum boolean?)]
 59 |   [id-ref (sym id?)]
 60 |   [ifte (test ast?) (then ast?) (else-ast ast?)]
 61 |   [assume (binds  (list-of bind?)) (body ast?)]
 62 |   [assume-rec (binds (list-of bind?)) (body ast?)]
 63 |   [function (formals (list-of id?)) (body ast?)]
 64 |   [app (rator ast?) (rands (list-of ast?))]
 65 |   [set (lhs id?) (rhs ast?)]
 66 |   [seq (stmts (list-of ast?))])
 67 | 
 68 | (define-datatype bind bind?
 69 |   [make-bind (b-id id?) (b-ast ast?)])
 70 | 
 71 | ;;; bind-id : bind? -> id?
 72 | (define bind-id
 73 |   (lambda (b)
 74 |     (cases bind b
 75 |       [make-bind (b-id b-ast) b-id])))
 76 | 
 77 | ;;; bind-ast : bind? -> ast?
 78 | (define bind-ast
 79 |   (lambda (b)
 80 |     (cases bind b
 81 |       [make-bind (b-id b-ast) b-ast])))
 82 | 
 83 | (define-datatype fbind fbind?
 84 |   [make-fbind (fb-id id?)
 85 |               (fb-formals (list-of id?))
 86 |               (fb-body ast?)])
 87 | 
 88 | (define id? symbol?)
 89 | 
 90 | ;;; unit Testing
 91 | ;;; ============
 92 | 
 93 | ;;; Racket's unit testing framework
 94 | (require rackunit)
 95 | 
 96 | 
 97 | (define-simple-check
 98 |   (check-ast? thing)
 99 |   (ast? thing))
100 | 
101 | (check-ast? (number 5) "number-5 test")
102 | (check-ast? (boolean #t) "boolean-#t test")
103 | (check-ast? (id-ref 'x) "id-ref-x test")
104 | (check-ast? (function
105 |               '(x y z)
106 |               (app (id-ref '+)
107 |                 (list (id-ref 'x)
108 |                   (app (id-ref '*)
109 |                     (list (id-ref 'y) (id-ref 'z)))))) "function-test")
110 | 
111 | 
112 | (check-ast?
113 |   (app (id-ref '+)
114 |     (list (number 5) (number 6))) "app test")
115 | 
116 | 
117 | (check-ast?
118 |   (assume (list (make-bind 'x (number 5))
119 |             (make-bind 'y (number 6)))
120 |     (app (id-ref '+)
121 |       (list (id-ref 'x) (id-ref 'y)))) "assume-test")
122 | 
123 | 
124 | 
125 | ;;; A feasible concrete syntax for recursive:
126 | ;;; (recursive ([even? (n) (if (0? n) #t (odd? (- n 1)))]
127 | ;;;             [odd?  (n) (if (0? n) #f (even? (- n 1)))])
128 | ;;;    (even? 5))
129 | 
130 | (check-ast?
131 |   (assume-rec
132 |    (list
133 |     (make-bind 'even?
134 |       (make-function '(n)
135 |         (ifte (app (id-ref '0?) (list (id-ref 'n)))
136 |           (boolean #t)
137 |           (app (id-ref 'odd?)
138 |             (list (app (id-ref '-) (list (id-ref 'n) (number 1))))))))
139 | 
140 |     (make-bind 'odd?
141 |       (make-function '(n)
142 |         (ifte (app (id-ref '0?) (list (id-ref 'n)))
143 |           (boolean #f)
144 |           (app (id-ref 'even?)
145 |             (list (app (id-ref '-) (list (id-ref 'n) (number 1)))))))))
146 |    (app (id-ref 'even?) (list (number 3))))
147 |    "recursive-ast test")
148 | 
149 | 
150 | (check-ast?
151 |   (assume (list (make-bind 'x (number 5)))
152 |     (seq (list (set 'x (number 3))
153 |                (id-ref 'x)))))
154 | 
155 | 
156 | 
157 | 
158 | 


--------------------------------------------------------------------------------
/code/store-list.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | ;;; ==============================
  3 | ;;; List implementation of Stores
  4 | ;;; ==============================
  5 | 
  6 | ;;; A store is implemented as a list.
  7 | 
  8 | (require racket/match)
  9 | 
 10 | (provide
 11 |   store?
 12 |   ref?
 13 |   new-store
 14 |   new-ref
 15 |   new-refs
 16 |   deref
 17 |   setref
 18 |   setrefs
 19 |   )
 20 | 
 21 | ;;; nat? : any/c -> boolean?
 22 | (define nat?
 23 |   (lambda (n)
 24 |     (and (integer? n)
 25 |          (>= n 0))))
 26 | 
 27 | (define ref? nat?)
 28 | 
 29 | (define storable-value? any/c)
 30 | 
 31 | 
 32 | ;;; store? : any/c -> boolean?
 33 | (define store? list?)
 34 | 
 35 | 
 36 | ;;; new-store : () -> store?
 37 | (define new-store
 38 |   (lambda()
 39 |     '()))
 40 | 
 41 | 
 42 | ;;; store-length : store? -> nat?
 43 | (define store-length 
 44 |   (lambda(s)
 45 |     (length s)))
 46 | 
 47 | ;;; returns a new store with a new reference containing val
 48 | ;;; new-ref: [store? storable-value?] -> [store? ref?]
 49 | (define new-ref
 50 |   (lambda (s v)
 51 |     (list (cons v s) (length s))))
 52 | 
 53 | 
 54 | 
 55 | ;;; returns a new store with new references containing vals 
 56 | ;;; new-refs :
 57 | ;;; [store? (listof storable?)] -> [store? (listof ref?)]
 58 | (define new-refs
 59 |   (lambda (s vals) 
 60 |     (letrec
 61 |         ([loop 
 62 |              (lambda(s vals ls)
 63 |                (cond
 64 |                  [(null? vals) (values s ls)]
 65 |                  [else (let ([result1 (new-ref s (first vals))])
 66 |                          (loop (first result1) (rest vals) (append ls (rest result1))))]))])
 67 |       
 68 |          (loop s vals '()))))
 69 | 
 70 | 
 71 | 
 72 | ;;;  deref: [store?  ref?] -> storable-value?
 73 | ;;;  deref: "throws address out of bounds" error
 74 | (define deref
 75 |   (lambda (s r) 
 76 |     (let ([pos (- (sub1 (length s)) r)])
 77 |       (if (>= pos 0)
 78 |           (list-ref s pos)
 79 |           (error 'deref "throws address out of bounds")))))
 80 | 
 81 | 
 82 | ;;;  setref: [store?  ref? storable-value?] -> store?
 83 | ;;;  setref: "throws address out of bounds" error if
 84 | ;;;  reference  out of s's bounds.
 85 | (define setref
 86 |   (lambda (s r v) 
 87 |     (if (>= (length s) r) 
 88 |         (replace s  (- (length s) (add1 r)) v)
 89 |     ;(if (eq? (sub1 (length s)) r)
 90 |         ;(cons v (rest s))
 91 |         ;(cons (first s) (setref (rest s) r v)))
 92 |     (error 'setref "throws address out of bounds"))))
 93 | 
 94 | 
 95 | ;;;  setrefs: [store?  (listof ref?) (listof storable-value?)] -> store?
 96 | ;;;  setrefs: "throws address out of bounds" error if
 97 | ;;;  rs are out of the store s's  bounds. 
 98 | (define setrefs
 99 |   (lambda (s rs vs) 
100 |     (if (eq? (length rs) 0)
101 |         s
102 |     (setrefs (setref s (first rs) (first vs)) (rest rs) (rest vs)))))
103 | 
104 | 
105 | 
106 | 
107 | ;;; replace
108 | ;;; -------
109 | ;;; construct a list like ls except that ls contains v at
110 | ;;; index i
111 | 
112 | ;;; replace : ([ls : (listof any/c)]
113 | ;;;            [i : (</c (length ls))]
114 | ;;;            [v : any/c]) ->
115 | ;;;           (listof any/c)
116 | 
117 | (define replace
118 |   (lambda (ls i v) 
119 |     (if (eq? i 0)
120 |        (cons v (rest ls))
121 |        (cons (first ls) (replace (rest ls) (sub1 i) v)))))
122 | 
123 | 
124 | ;;; unit Testing
125 | ;;; ============
126 | 
127 | ;;; Racket's unit testing framework
128 | (require rackunit)
129 | 
130 | ;;; implementation tests
131 | ;;; --------------------
132 | 
133 | (define-simple-check (check-store? thing)
134 |   (store? thing))
135 | 
136 | (check-store? (new-store))
137 | 
138 | (check-equal? (store-length (new-store)) 0 "test:store-length-empty-store")
139 | (check-equal? (new-ref (new-store) 'a)  '((a) 0) "test:new-ref-empty-store")
140 | (check-equal? (first (new-ref (new-store) 'a))  '(a) "test:new-ref^1")
141 | (check-equal? (first (new-ref (first (new-ref (new-store) 'a)) 'b)) '(b a) "test:new-ref^2")
142 | (check-equal? (first (new-ref (first (new-ref (first (new-ref (new-store) 'a)) 'b)) 'c))
143 |               '(c b a) "test:new-ref^3")
144 | 
145 | (check-equal?
146 |  (match-let ([(list s r) (new-ref (new-store) 4)])
147 |     (new-ref s 8))
148 |  '((8 4) 1))
149 | 
150 | (check-equal?
151 |  (match-let ([(list s r1) (new-ref (new-store) 4)])
152 |     (match-let ([(list s r2) (new-ref s 8)])
153 |        (setref s r1 7)))
154 |  '(8 7))
155 | 
156 | 
157 | (check-equal?
158 |   (match-let ([(list s r1) (new-ref (new-store) 4)])
159 |     (match-let ([(list s r2) (new-ref s 8)])
160 |        (setref s r2 15)))
161 |   '(15 4))
162 | 
163 | (check-equal?
164 |   (match-let ([(list s r1) (new-ref (new-store) 4)])
165 |     (match-let ([(list s r2) (new-ref s 8)])
166 |       (setref s r2 (+ (deref s r1) (deref s r2)))))
167 |   '(12 4))
168 | 
169 | 
170 | ;;; API tests
171 | ;;; ---------
172 | (define s0 (new-store))
173 | (define ans (new-ref s0 'a))
174 | (define s1 (match-let ([(list s _) ans]) s))
175 | (define r1 (match-let ([(list _ r) ans]) r))
176 | 
177 | (check-equal? r1 0)
178 | (check-equal? (deref s1 0) 'a)
179 | (check-exn exn? (lambda ()
180 |                   (deref s1 1)))
181 | 
182 | (define s2 (setref s1 0 'b))
183 | (check-equal? (deref s2 0) 'b)
184 | (check-exn exn? (lambda () (setref s2 3 'c)))
185 | 
186 | 
187 | (check-equal?
188 |   (match-let ([(list s r) (new-ref (new-store) 4)])
189 |     (let ([s (setref s r 7)])
190 |       (deref s r)))
191 |   7)
192 | 
193 | 
194 | (check-equal?
195 |   (match-let ([(list s r) (new-ref (new-store) 4)])
196 |     (match-let ([(list s r) (new-ref s 8)])
197 |       (deref s 0)))
198 |   4)
199 | 
200 | (check-equal?
201 |   (match-let ([(list s r) (new-ref (new-store) 4)])
202 |     (match-let ([(list s r) (new-ref s 8)])
203 |       (deref s r)))
204 |   8)
205 | 
206 | 
207 |   
208 | 
209 | 
210 | 
211 | 


--------------------------------------------------------------------------------
/code/eval-ast.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | 
  3 | ;;; =============================================================
  4 | ;;; Evaluator for the STORE-PASSING/IMPLICIT-ALLOCATION  language
  5 | ;;; =============================================================
  6 |   
  7 | (provide
  8 |    eval-ast)
  9 | (require "ast.rkt")
 10 | (require "store-list.rkt")
 11 | (require "env.rkt")
 12 | (require "init-store-env.rkt")
 13 | (require "semantic-domains.rkt")
 14 | (require eopl/eopl)
 15 | 
 16 | 
 17 | ;;; answer? = store? expressible-value?
 18 | 
 19 | ;;; eval-ast : [ast? env? store?]-> answer?
 20 | ;;; eval-ast :  throws error
 21 | 
 22 | 
 23 | (define eval-ast
 24 |   (lambda (a env store)
 25 |     (cases ast a
 26 |       [number (datum) (values store datum)]
 27 |       [boolean (datum) (values store datum)]
 28 |       [id-ref (id)  (values store (deref store  (lookup-env env id)))]
 29 |       [ifte (test then else) 
 30 |             (let-values ([(new-store b) (eval-ast test env store)])
 31 |               (if (boolean? b)
 32 |                   (eval-ast  (if b then else) env new-store)
 33 |                   (error 'eval-asts "wrong answer")
 34 |                   ))]
 35 |       [function (formals body)
 36 |                 (values store (closure formals body env))]   
 37 |       [app (rator rand)
 38 |            (let*-values ([(new-store1 p) (eval-ast rator env store)]
 39 |                  [(new-store2 args) (eval-asts rand env new-store1)])
 40 |              (apply-proc p args new-store2 env))]
 41 |       [assume (binds body)
 42 |               (let*-values ([(ids) (map bind-id binds)]
 43 |                             [(asts) (map bind-ast binds)]
 44 |                             [(new-store1 vals) (eval-asts asts env store)])
 45 |                 (let-values ([(new-store2 reference) (new-refs new-store1 vals)])
 46 |                   (eval-ast body (extended-env ids reference env) new-store2)))]
 47 |      
 48 |       [assume-rec (binds body) 
 49 |            (let* ([ids (map bind-id binds)]
 50 |                  [asts (map bind-ast binds)]
 51 |                  [vals (map (lambda(x)
 52 |                          (cases ast x
 53 |                            [function (formals body) 
 54 |                                (rec-closure formals body)]
 55 |                            [else (error 'parse "uninitialized variable ~a" x)]
 56 |                           )
 57 |                          ) asts)])
 58 |              (let*-values ([(p q) (new-refs store vals)])
 59 |                       (let ([new-env (extended-env ids q env)])
 60 |                         (eval-ast body new-env p)
 61 |                        ))
 62 |               )]
 63 |       
 64 |       [set (lhs rhs)
 65 |            (let-values ([(new-store1 res) (eval-ast rhs env store)])          
 66 |              (if (symbol? lhs) (values (setref new-store1 (lookup-env env lhs) res) res) 
 67 |                  (error 'eval-ast "wrong input")))]
 68 |       [seq (stmts)
 69 |            (let-values ([(new-store res) (eval-asts stmts env store)])
 70 |              (values new-store (last res)))]
 71 |       [else (error 'eval-ast "wrong input")]
 72 |       )))
 73 | 
 74 | 
 75 | 
 76 |                            
 77 | ;;; eval-asts : [(listof ast?) env? store?] -> store? (listof expressible-value?)
 78 | 
 79 | (define eval-asts
 80 |   (lambda (asts env store)  
 81 |     (letrec
 82 |         ([loop (lambda (asts env store val)
 83 |                  (if (eq? (length asts) 0)
 84 |                      (values store val)
 85 |                      (let-values ([ (new-store result) (eval-ast (first asts) env store)])
 86 |                        (loop (rest asts) env new-store (append val (list result) )))))])
 87 |                   (loop asts env store '())  
 88 |                  )))
 89 |     
 90 |     ;(let-values ([(new-store res) (eval-ast (first asts) env store)])
 91 |      ; (if (> (length (rest asts)) 0)
 92 |      ;  (let-values ([(rest-store rest-res) (eval-asts (rest asts) env new-store)])
 93 |       ;   (values  rest-store  (append (list first) rest-res))) 
 94 |       ; (values new-store (list res))))))
 95 |   
 96 | 
 97 |       
 98 | 
 99 | ;;; apply-proc :
100 | ;;;  [proc? (list-of expressible-value?) store?]
101 | ;;;    -> answer?
102 | 
103 | (define apply-proc
104 |   (lambda (p args store env) 
105 |     (cases proc p
106 |       [prim-proc (prim sig)
107 |         (values store (apply-prim-proc prim sig args))]
108 |       
109 |       [closure (formals body env)
110 |         (apply-closure formals body env args store)]
111 |       [rec-closure(formals body)
112 |          (apply-closure formals body env args store)]
113 |       )))
114 | 
115 | 
116 | 
117 | ;;; apply-prim-proc :
118 | ;;;  [procedure? (listof procedure?)
119 | ;;;     (listof expressible-value?)] -> expressible-value?
120 | ;;;
121 | ;;; apply-prim-proc : throws error when number or type of
122 | ;;;     args do not match the signature of prim-proc
123 | 
124 | (define apply-prim-proc
125 |   (lambda (prim sig args) 
126 |     (cond
127 |       [(and (= (- (length sig) 1) (length args))  
128 |             (andmap match-arg-type (rest sig) args))
129 |        (apply prim args)
130 |        ]
131 |       [else (error 'apply-prim-proc "unable to handle some cases")]
132 |       )))
133 | 
134 | ;;; match-arg-type : [procedure? any/c] -> boolean?
135 | (define match-arg-type
136 |     (lambda (arg-type val)
137 |       (arg-type val)))
138 | 
139 | 
140 | ;;; apply-closure : [closure? (listof expressible-value?)]
141 | ;;;                  -> answer?
142 | 
143 | (define apply-closure
144 |   (lambda (formals body env args store) 
145 |     (let-values ([(new-store references)(new-refs  store args)])
146 |       (eval-ast body (extended-env formals references env) new-store))))
147 |       
148 |    ; ( let ([new-env (extended-env formal args env)])
149 |     ; (eval-ast body new-env new-store))))
150 | 
151 |                                         
152 |                        
153 |                      
154 | ;;; Unit testing
155 | ;;; ============
156 | 
157 | (require rackunit)
158 | 
159 | (define-simple-check
160 |   (check-eval-ast? ast env store expected label)
161 |   (let-values ([(store val) (eval-ast ast env store)])
162 |     (check-equal? val expected label)))
163 | 
164 | 
165 | (define s1-e1
166 |   (make-init-store-env '(x y z) '(1 2 3)))
167 | 
168 | (define s1 (first s1-e1))
169 | (define e1 (second s1-e1))
170 | 
171 | (check-eval-ast? (number 5)  e1  s1 5 "eval-ast: n5 test")
172 | (check-eval-ast? (boolean #t)  e1  s1 #t "eval-ast: bt test")
173 | (check-eval-ast? (id-ref 'x)  e1  s1 1 "eval-ast: id1 test")
174 | (check-eval-ast? (id-ref 'y) e1  s1 2 "eval-ast: y test")
175 | 
176 | 
177 | (check-eval-ast?
178 |   (assume (list (make-bind 'x (number 4)))
179 |     (id-ref 'x))
180 |   e1
181 |   s1
182 |   4
183 |   "eval-ast: new-ref1")
184 | 
185 | 
186 | (check-eval-ast?
187 |   (assume (list (make-bind 'x  (number 4)))
188 |     (assume (list (make-bind 'y  (id-ref 'x)))
189 |       (id-ref 'y)))
190 |   e1
191 |   s1
192 |   4
193 |   "eval-ast: new-ref2")
194 | 
195 | (check-eval-ast?
196 |   (assume (list (make-bind 'x  (number 4)))
197 |     (assume (list (make-bind 'ignore (set 'x (number 7))))
198 |       (id-ref 'x)))
199 |   e1
200 |   s1
201 |   7
202 |   "eval-ast: new-ref3")
203 | 
204 | 
205 | (check-eval-ast?
206 |   (assume (list (make-bind 'x  (number 4)))
207 |     (seq
208 |       (list 
209 |         (set 'x (number 7))
210 |         (id-ref 'x))))
211 |   e1
212 |   s1
213 |   7
214 |   "eval-ast: new-ref3")
215 | 
216 | ;; trying to set a non-reference
217 |     
218 |     (check-exn exn?
219 |       (lambda ()
220 |         (eval-ast 
221 |           (assume (list (make-bind 'x  (number 4)))
222 |             (set (number 7) (boolean #f)))
223 |           e1
224 |           s1)
225 |         "eval-ast: error-set"))
226 | 
227 | 
228 | 
229 | (check-exn exn?
230 |   (lambda ()
231 |     (eval-ast
232 |       (assume-rec (list (make-bind 'x) (id-ref 'x))
233 |         (id-ref 'x))
234 |       e1
235 |       s1
236 |       "eval-ast: uninitialized")))
237 | 
238 | 
239 | 


--------------------------------------------------------------------------------