Skip to content

Commit

Permalink
implemented compilation for special forms
Browse files Browse the repository at this point in the history
  • Loading branch information
@athos
athos committed Apr 28, 2012
1 parent 7054000 commit 7d7a9e2
Show file tree
Hide file tree
Showing 2 changed files with 259 additions and 11 deletions.
109 changes: 99 additions & 10 deletions src/syntactic_closure/core.clj
View file
Expand Up @@ -89,7 +89,8 @@
;; compilers for special forms
;;
(def ^:private %specials
'#{def if let* fn* quote do loop* recur var})
'#{def if let* fn* quote do loop* recur var set! new . letfn* clojure.core/import*
try throw monitor-enter monitor-exit deftype* case* reify*})

(defn- special? [op]
(%specials op))
Expand Down Expand Up @@ -120,16 +121,27 @@
inits (map second bindings')
env' (env/extend-environment env names)]
`(let* ~(vec (interleave (compile-exprs env' names)
(compile-exprs env' inits)))
(compile-exprs env inits)))
~@(compile-exprs env' body))))

;; FIXME:
;; Forms like (fn* foo [arg ...] body ...) are not supported.
(defmethod compile-special 'fn* [env exp]
(let [[_ args & body] exp
env' (env/extend-environment env args)]
`(fn* ~(compile env' args)
~@(compile-exprs env' body))))
(let [[_ maybe-name & body] exp
name (if (symbol? maybe-name) maybe-name nil)
maybe-args (if name (first body) maybe-name)]
(if (vector? maybe-args)
(let [args maybe-args
body (if name (rest body) body)
env' (env/extend-environment env (if name (cons name args) args))]
`(fn* ~@(and name [(compile env' name)])
~(compile env' args)
~@(compile-exprs env' body)))
(let [body (if name body (cons maybe-name body))
env' (if name (env/extend-environment env [name]) env)]
`(fn* ~@(and name [(compile env' name)])
~@(for [[args & body] body
:let [env'' (env/extend-environment env' args)]]
`(~(compile env'' args)
~@(compile-exprs env'' body))))))))

(defmethod compile-special 'quote [env exp]
exp)
Expand All @@ -145,17 +157,94 @@
inits (map second bindings')
env' (env/extend-environment env names)]
`(loop* ~(vec (interleave (compile-exprs env' names)
(compile-exprs env' inits)))
(compile-exprs env inits)))
~@(compile-exprs env' body))))

(defmethod compile-special 'recur [env exp]
(let [[_ & args] exp]
`(recur ~@(compile-exprs env args))))

(defmethod compile-special 'var [env exp]
exp)
(let [[_ exp'] exp]
`(var ~(compile env exp'))))

(defmethod compile-special 'set! [env exp]
(let [[_ var val] exp]
`(set! ~(compile env var)
~(compile env val))))

(defmethod compile-special 'new [env exp]
(let [[_ class & args] exp]
`(new ~(compile env class)
~@(compile-exprs env args))))

(defmethod compile-special '. [env exp]
(let [[_ x method-or-field & args] exp]
`(. ~(compile env x)
~method-or-field
~@(compile-exprs env args))))

(defmethod compile-special 'letfn* [env exp]
(let [[_ fns & body] exp
fns' (partition 2 fns)
fnames (map first fns')
fexprs (map second fns')
env' (env/extend-environment env fnames)]
`(letfn* ~(vec (mapcat (fn [[fname fexpr]]
[(compile env' fname)
(compile env' fexpr)])
(map vector fnames fexprs)))
~@(compile-exprs env' body))))

(defmethod compile-special 'clojure.core/import* [env exp]
exp)

(defmethod compile-special 'try [env exp]
(let [[_ & body] exp
[exprs rest] (split-with #(not (and (seq? %) (= (first %) 'catch))) body)
[catch-clauses finally-clause]
(split-with #(not (and (seq? %) (= (first %) 'finally))) rest)]
`(try ~@(compile-exprs env exprs)
~@(for [[_ class ename & body] catch-clauses
:let [env' (env/extend-environment env [ename])]]
`(catch ~(compile env class) ~(compile env' ename)
~@(compile-exprs env' body)))
~@(if (empty? finally-clause)
nil
(let [[_ & body] (first finally-clause)]
`((finally ~@(compile-exprs env body))))))))

(defmethod compile-special 'throw [env exp]
(let [[_ exp'] exp]
`(throw ~(compile env exp'))))

(defmethod compile-special 'monitor-enter [env exp]
(let [[_ exp'] exp]
`(monitor-enter ~(compile env exp'))))

(defmethod compile-special 'monitor-exit [env exp]
(let [[_ exp'] exp]
`(monitor-exit ~(compile env exp'))))

(defmethod compile-special 'deftype* [env exp]
(let [[_ tag class fields implements interfaces & methods] exp
env' (env/make-environment (:ns-name env) {})]
`(deftype* ~tag ~class ~fields :implements ~interfaces
~@(for [[name args & body] methods
:let [env'' (env/extend-environment env' args)]]
`(~name ~(vec (compile-exprs env'' args))
~@(compile-exprs env'' body))))))

(defmethod compile-special 'case* [env exp]
(let [[_ x & rest] exp]
`(case* ~(compile env x)
~@rest)))

(defmethod compile-special 'reify* [env exp]
(let [[_ interfaces & methods] exp]
`(reify*
~(vec (compile-exprs env interfaces))
~@(for [[name args & body] methods
:let [env' (env/extend-environment env args)]]
`(~name ~(vec (compile-exprs env' args))
~@(compile-exprs env' body))))))
161 changes: 160 additions & 1 deletion test/syntactic_closure/test/core.clj
View file
@@ -1,6 +1,6 @@
(ns syntactic-closure.test.core
(:refer-clojure :exclude [compile])
(:use [clojure.test :only [deftest is]])
(:use [clojure.test :only [deftest is are]])
(:require [syntactic-closure.core :as core]
[syntactic-closure.environment :as env]))

Expand Down Expand Up @@ -28,3 +28,162 @@
(is (= (core/compile env '(Calendar/getInstance)) '(java.util.Calendar/getInstance)))
(is (= (core/compile env '(. x method y)) '(. x_01 method y_02)))
(is (= (core/compile env '(.method x y)) '(.method x_01 y_02))))

(deftest compile-def
(are [expr expanded] (= (core/compile env expr) expanded)
'(def a x)
'(def a x_01)

'(def a (fn* [] a))
'(def a (fn* [] a))))

(deftest compile-if
(are [expr expanded] (= (core/compile env expr) expanded)
'(if (f 0) x y)
'(if (foo.baz/f 0) x_01 y_02)))

(deftest compile-let*
(let [[op [name val] [f x]] (core/compile env '(let* [x x] (f x)))]
(is (and (= op 'let*)
(= name x)
(not= name 'x_01)
(= val 'x_01)
(= f 'foo.baz/f)))))

(deftest compile-fn*
(let [[op [name] [f x]] (core/compile env '(fn* [x] (f x)))]
(is (and (= op 'fn*)
(= name x)
(not= name 'x)
(not= name 'x_01)
(= f 'foo.baz/f))))
(let [[op [[name] [f x]]] (core/compile env '(fn* ([x] (f x))))]
(is (and (= op 'fn*)
(= name x)
(not= name 'x)
(not= name 'x_01)
(= f 'foo.baz/f))))
(let [[op fname [name] [f x]] (core/compile env '(fn* f [x] (f x)))]
(is (and (= op 'fn*)
(= fname f)
(not= f 'f)
(not= f 'foo.baz/f)
(= name x)
(not= name 'x)
(not= name 'x_01))))
(let [[op fname [[name] [f x]]] (core/compile env '(fn* f ([x] (f x))))]
(is (and (= op 'fn*)
(= fname f)
(not= f 'f)
(not= f 'foo.baz/f)
(= name x)
(not= name 'x)
(not= name 'x_01)))))

(deftest compile-quote
(is (= (core/compile env '(quote (def f x))) '(quote (def f x)))))

(deftest compile-do
(is (= (core/compile env '(do (f x) y)) '(do (foo.baz/f x_01) y_02))))

(deftest compile-loop*
(let [[_ [name val] [f x]] (core/compile env '(loop* [x x] (f x)))]
(is (and (= name x)
(= val 'x_01)
(= f 'foo.baz/f)))))

(deftest compile-recur
(is (= (core/compile env '(recur (f x))) '(recur (foo.baz/f x_01)))))

(deftest compile-var
(is (= (core/compile env '(var f)) '(var foo.baz/f))))

(deftest compile-set!
(is (= (core/compile env '(set! y (f x))) '(set! y_02 (foo.baz/f x_01)))))

(deftest compile-letfn*
(let [[op [f1 [fn1 f2 [x1] [f3 [g4 x2]]], g1 [fn2 g2 [x3] [g3 [f4 x4]]]] [f5 [g5 x]]]
(core/compile env '(letfn* [f (fn* f [x] (f (g x))), g (fn* g [x] (g (f x)))] (f (g x))))]
(is (and (= op 'letfn*)
(= fn1 fn2 'fn*)
(= f1 f4 f5)
(not= f1 'f)
(not= f1 'foo.baz/f)
(= f2 f3)
(= g1 g4 g5)
(not= g1 'g)
(= g2 g3)
(= x1 x2)
(not= x1 'x)
(not= x1 'x_01)
(= x3 x4)
(not= x3 'x)
(not= x3 'x_01)
(= x 'x_01)))))

(deftest compile-try
(let [[op1 [f1 x] [f2 y] [op2 class name [f3 e]] [op3 [f4 x']]]
(core/compile env
'(try (f x) (f y) (catch Exception x (f x)) (finally (f x))))]
(is (and (= op1 'try)
(= op2 'catch)
(= op3 'finally)
(= f1 f2 f3 f4 'foo.baz/f)
(= x x' 'x_01)
(= y 'y_02)
(= class 'java.lang.Exception)
(= name e)
(not= name 'x)
(not= name 'x_01)))))

(deftest compile-throw
(is (= (core/compile env '(throw (new Exception x)))
'(throw (new java.lang.Exception x_01)))))

(deftest compile-monitor-enter
(is (= (core/compile env '(monitor-enter x))
'(monitor-enter x_01))))

(deftest compile-monitor-exit
(is (= (core/compile env '(monitor-exit x))
'(monitor-exit x_01))))

(deftest compile-deftype*
(let [[op tag class [x1] implements [interface] [invoke [t] [f x2]]]
(core/compile env
'(deftype* Foo foo.Foo [x] :implements [clojure.lang.IFn]
(invoke [this] (f x))))]
(println `(~op ~tag ~class [~x1] ~implements [~interface]
(~invoke [~t] (~f ~x2))))
(is (and (= op 'deftype*)
(= tag 'Foo)
(= class 'foo.Foo)
(= x1 x2 'x)
(= implements :implements)
(= interface 'clojure.lang.IFn)
(= invoke 'invoke)
(not= t 'this)
(= f 'foo.baz/f)))))

(deftest compile-case*
;; nothing to be tested so far
)

(deftest compile-reify*
(let [[op [i] [f1 [t1] [f2 x2]] [f3 [t2 x3] [f4 x4]]]
(core/compile env
'(reify*
[clojure.lang.IFn]
(invoke [this] (f x))
(invoke [this x] (f x))))]
(is (and (= op 'reify*)
(= i 'clojure.lang.IFn)
(= f1 f3 'invoke)
(not= t1 'this)
(= f2 'foo.baz/f)
(= x2 'x_01)
(not= t2 'this)
(= x3 x4)
(not= x3 'x)
(not= x3 'x_01)
(= f4 'foo.baz/f)))))

0 comments on commit 7d7a9e2

Please sign in to comment.