Permalink
Browse files

explicit ref lang

  • Loading branch information...
1 parent 7287b08 commit d15e2dcaa3ea56d07ed0c654b5e9cf1edd35b559 @ananthakumaran committed May 6, 2012
Showing with 765 additions and 0 deletions.
  1. +225 −0 src/eopl/core/explicit_ref_lang.clj
  2. +512 −0 src/eopl/core/explicit_ref_lang_parser.clj
  3. +28 −0 src/eopl/core/link_ref.clj
@@ -0,0 +1,225 @@
+(ns eopl.core.explicit-ref-lang
+ (:use eopl.core.define-datatype)
+ (:use eopl.core.env)
+ (:use eopl.core.explicit-ref-lang-parser)
+ (:use eopl.core.link-ref)
+ (:use clojure.set)
+ (:use clojure.test))
+
+(defn expval->num [val]
+ (cases expval val
+ (num-val (num) num)
+ (else (throw (Exception. (str "invalid number " val))))))
+
+(defn expval->bool [val]
+ (cases expval val
+ (bool-val (bool) bool)
+ (else (throw (Exception. (str "invalid bool " val))))))
+
+(defn expval->list [val]
+ (cases expval val
+ (list-val (lst) lst)
+ (else (throw (Exception. (str "invalid list " val))))))
+
+(defn expval->proc [val]
+ (cases expval val
+ (proc-val (proc) proc)
+ (else (throw (Exception. (str "invalid proc " val))))))
+
+(defn expval->ref [val]
+ (cases expval val
+ (ref-val (ref) ref)
+ (else (throw (Exception. (str "invalid ref " val))))))
+
+(defn expval->val [val]
+ (cases expval val
+ (num-val (num) num)
+ (bool-val (bool) bool)
+ (list-val (lst)
+ (map #(expval->val %1) lst))
+ (ref-val (ref) ref)))
+
+(declare value-of)
+
+(defn apply-procedure [p args]
+ (cases proc p
+ (procedure (vars body saved-env)
+ (let [new-env (reduce
+ (fn [new-env [var arg]]
+ (extend-env new-env var arg))
+ saved-env
+ (map (fn [x y] [x y]) vars args))]
+ (value-of body new-env)))))
+
+(defn num-val-of-exp [op env & exps]
+ (num-val
+ (apply op (map #(expval->num (value-of %1 env))
+ exps))))
+
+(defn bool-val-of-exp [op env & exps]
+ (bool-val
+ (apply op (map #(expval->num (value-of %1 env))
+ exps))))
+
+(defn value-of [exp env]
+ (cases expression exp
+ (const-exp (num) (num-val num))
+ (diff-exp (exp1 exp2)
+ (num-val-of-exp - env exp1 exp2))
+ (add-exp (exp1 exp2)
+ (num-val-of-exp + env exp1 exp2))
+ (mul-exp (exp1 exp2)
+ (num-val-of-exp * env exp1 exp2))
+ (div-exp (exp1 exp2)
+ (num-val-of-exp quot env exp1 exp2))
+ (minus-exp (exp)
+ (num-val-of-exp - env exp))
+ (cons-exp (exp1 exp2)
+ (list-val
+ (cons (value-of exp1 env)
+ (expval->list (value-of exp2 env)))))
+ (car-exp (exp1)
+ (let [lst (expval->list (value-of exp1 env))]
+ (if (empty? lst)
+ (list-val '())
+ (first lst))))
+
+ (cdr-exp (exp1)
+ (let [lst (expval->list (value-of exp1 env))]
+ (if (empty? lst)
+ (list-val '())
+ (list-val (next lst)))))
+
+ (emptylist-exp () (list-val '()))
+
+ (equal?-exp (exp1 exp2)
+ (bool-val-of-exp = env exp1 exp2))
+ (less?-exp (exp1 exp2)
+ (bool-val-of-exp < env exp1 exp2))
+ (greater?-exp (exp1 exp2)
+ (bool-val-of-exp > env exp1 exp2))
+
+ (null?-exp (exp1)
+ (bool-val (empty? (expval->list (value-of exp1 env)))))
+ (zero?-exp (exp1)
+ (bool-val (zero? (expval->num (value-of exp1 env)))))
+ (true-exp () (bool-val true))
+ (false-exp () (bool-val false))
+
+ (list-exp (args)
+ (list-val (map #(value-of %1 env) args)))
+
+ (print-exp (exp)
+ (do (print (expval->val (value-of exp env)))
+ (num-val 1)))
+
+ (newref-exp (exp)
+ (ref-val (newref (value-of exp env))))
+
+ (de-ref-exp (exp)
+ (de-ref (expval->ref (value-of exp env))))
+
+ (setref-exp (ref-exp value-exp)
+ (do
+ (setref! (expval->ref (value-of ref-exp env))
+ (value-of value-exp env))
+ (num-val 23)))
+
+ (begin-exp (exps)
+ (reduce (fn [last-val exp]
+ (value-of exp env))
+ nil
+ exps))
+
+ (if-exp (exp1 exp2 exp3)
+ (if (expval->bool (value-of exp1 env))
+ (value-of exp2 env)
+ (value-of exp3 env)))
+
+ (proc-exp (vars body)
+ (proc-val (procedure vars body env)))
+
+ (letproc-exp (name vars proc-body body)
+ (let [new-env (extend-env env name (proc-val (procedure vars proc-body env)))]
+ (value-of body new-env)))
+
+ (call-exp (rator rands)
+ (let [proc (expval->proc (value-of rator env))
+ args (map
+ #(value-of %1 env)
+ rands)]
+ (apply-procedure proc args)))
+ (var-exp (var) (apply-env env var))
+ (let-exp (body bindings)
+ (value-of body
+ (reduce (fn [new-env bind]
+ (cases binding bind
+ (binding-exp (var exp)
+ (extend-env new-env var (value-of exp env)))))
+ env
+ bindings)))
+ (let*-exp (body bindings)
+ (value-of body
+ (reduce (fn [new-env bind]
+ (cases binding bind
+ (binding-exp (var exp)
+ (extend-env new-env var (value-of exp new-env)))))
+ env
+ bindings)))
+
+ (letrec-exp (body proc-bindings)
+ (let [pbs (into {} (map (fn [pb]
+ (cases proc-binding pb
+ (proc-binding-exp (name vars body)
+ [name [name vars body]])))
+ proc-bindings))]
+ (value-of body
+ (extend-env-rec
+ env
+ (fn [name new-env]
+ (let [[name vars body] (get pbs name)]
+ (proc-val (procedure vars body new-env))))
+ (keys pbs)))))
+
+ (unpack-exp (body vars value)
+ (value-of body
+ (reduce (fn [new-env [var val]]
+ (extend-env new-env var val))
+ env
+ (map (fn [var val]
+ [var val])
+ vars
+ (expval->list (value-of value env))))))
+
+ (cond-exp (conditions)
+ (or (first (keep (fn [cond]
+ (cases condition cond
+ (clause-exp (predicate consequence)
+ (if (expval->bool (value-of predicate env))
+ (value-of consequence env)))))
+ conditions))
+ (throw (Exception. (str "unhandled condition " conditions)))))
+ (else (throw (Exception. (str "unkonwn exp " exp))))))
+
+(defn value-of-program [pgm]
+ (cases program pgm
+ (a-program (exp1)
+ (value-of exp1 (empty-env)))))
+
+
+(defn run [program]
+ (initialize-store!)
+ (value-of-program (parse program)))
+
+(defn result [program]
+ (expval->val (run program)))
+
+(deftest proc-test
+ (is (= (result "let x = newref(newref(0))
+ in begin
+ setref(de-ref(x), 11);
+ de-ref(de-ref(x))
+ end")
+ 11)))
+
+(run-tests)
Oops, something went wrong.

0 comments on commit d15e2dc

Please sign in to comment.