Commits

remleduff  committed b8739a4

Add try/catch support

  • Participants
  • Parent commits 7f0cf54

Comments (0)

Files changed (4)

File src/clojure/analyzer.clj

   (def ^:dynamic *ns* 'user)
   (refer 'clojure.core :only '[namespaces *warn-on-undeclared*])) 
 
-(def specials '#{quote def fn* if do let* loop* recur new . reify gen-interface})
+(def specials '#{quote def fn* if do let* loop* throw try recur new . reify})
 
 (def ^:dynamic *recur-frames* nil)
 
        (set? form) (analyze-set env form name)
        :else {:op :constant :env env :form form}))))
 
+(defn analyze-block
+  "returns {:statements .. :ret ..}"
+  [env exprs]
+  (let [statements (disallowing-recur
+    (seq (map #(analyze (assoc env :context :statement ) %) (butlast exprs))))
+        ret (if (<= (count exprs) 1)
+      (analyze env (first exprs))
+      (analyze (assoc env :context (if (= :statement (:context env)) :statement :return )) (last exprs)))]
+    {:statements statements :ret ret}))
+
 ;; TODO: This could be children-keys that just returns the keys of the children, then walk would probably
 ;             be simple to implement in terms of that
 (defmulti children :op)
                 sym)))
 
           (get-in @namespaces [(-> env :ns :name ) :uses sym])
-          (var-fn env (get-in @namespaces [(-> env :ns :name ) :uses sym]) (name sym))
+          (var-fn env (get-in @namespaces [(-> env :ns :name) :uses sym]) (name sym))
 
           :else
-          (let [full-ns (if (core-name? env sym) 'clojure.core (-> env :ns :name ))]
+          (let [full-ns (if (core-name? env sym) 'clojure.core (-> env :ns :name))]
             (var-fn env full-ns sym)))]
     {:name nm})))
 
     (update-in [:then] f)
     (update-in [:else] f)))
 
+(defmethod parse 'throw
+  [op env [_ throw :as form] name]
+  (let [throw-expr (disallowing-recur (analyze (assoc env :context :expr) throw))]
+    {:env env :op :throw :form form
+     :throw throw-expr}))
+
+(defmethod children :throw
+  [{:keys [throw]}]
+  [throw])
+
+(defmethod walk :throw
+  [form f]
+  (update-in form [:throw] f))
+
+(defmethod parse 'try
+  [op env [_ & body :as form] name]
+  (let [catch? #(and (list? %) (= (first %) 'catch))
+        finally? #(and (list? %) (= (first %) 'finally))
+        [body tail] (split-with (complement #(or (catch? %) (finally? %))) body)
+        [cblocks [fblock]] (split-with catch? tail)
+        catchenv (update-in env [:context] #(if (= :expr %) :return %))
+        try (when body
+              (assoc (analyze-block (if (or cblocks fblock) catchenv env) body) :op :do))
+        catches (into [] 
+                  (map 
+                    (fn [[ _ type name & cb]] 
+                      (let [locals (:locals catchenv)
+                            locals (if name
+                                     (assoc locals name {:name name})
+                                     locals)]
+                      (assoc (analyze-block (assoc catchenv :locals locals) cb) :op :do :catch-type type :catch-local name)))
+                   cblocks))
+        finally (when (seq fblock)  
+                  (assoc (analyze-block (assoc env :context :statement) (rest fblock)) :op :do))]
+    (when name (assert (not (namespace name)) "Can't qualify symbol in catch"))
+    {:env env :op :try :form form
+     :try try
+     :finally finally
+     :name name
+     :catches catches}))
+
+(defmethod children :try
+  [{:keys [try catches finally]}]
+  (let [ret (conj catches try)]
+    (if finally
+      (cons finally ret)
+      ret)))
+
+(defmethod walk :try
+  [form f]
+  (let [form (-> form
+               (update-in [:try] f)  
+               (update-in [:catches] (walk-coll f)))]
+    (if-let [finally (:finally form)]
+      (assoc form :finally (f finally))
+      form)))
+
 (defmethod parse 'def
   [op env form name]
   (let [pfn (fn
-    ([_ sym] {:sym sym})
-    ([_ sym init] {:sym sym :init init})
-    ([_ sym doc init] {:sym sym :doc doc :init init}))
+              ([_ sym] {:sym sym})
+              ([_ sym init] {:sym sym :init init})
+              ([_ sym doc init] {:sym sym :doc doc :init init}))
         args (apply pfn form)
         sym (:sym args)]
     (assert (not (namespace sym)) "Can't def ns-qualified name")
     (assoc form :init (f init))
     form))
 
-(defn analyze-block
-  "returns {:statements .. :ret ..}"
-  [env exprs]
-  (let [statements (disallowing-recur
-    (seq (map #(analyze (assoc env :context :statement ) %) (butlast exprs))))
-        ret (if (<= (count exprs) 1)
-      (analyze env (first exprs))
-      (analyze (assoc env :context (if (= :statement (:context env)) :statement :return )) (last exprs)))]
-    {:statements statements :ret ret}))
-
 (defn- analyze-fn-method [env locals meth]
   (letfn [(uniqify [[p & r]]
             (when p

File src/clojure/java/compiler.clj

      (eval form)))
   ([form]
    (binding [*loader* (if *loader* *loader* (DynamicClassLoader.))]
-     (if (= (first form) 'do)
+     (if false #_(= (first form) 'do)
        ;; Special handling for do, pick it apart and eval the pieces
        (let [[op & statements] form]
          (when statements
         false-label (.newLabel *gen*)
         end-label (.newLabel *gen*)]
     (.visitLineNumber *gen* line (.mark *gen*))
+    ;; Emit test
     (emit-test test null-label false-label)
+    ;; True, emit then
     (emit then)
     (.goTo *gen* end-label)
 
     (.mark *gen* null-label)
     (asm-pop (expression-type test))
-
+    ;; False label, emit else
     (.mark *gen* false-label)
     (emit else)
 
     (.mark *gen* end-label)))
 
+(defmethod emit :throw 
+  [{:keys [throw env]}]  
+  (emit throw)
+  (.checkCast *gen* (asm-type java.lang.Throwable))
+  (.throwException *gen*))
+
+(defmethod emit :try
+  [{:keys [try catches finally]}]
+  (let [[start-try-label end-try-label ret-label finally-label] (repeatedly #(.newLabel *gen*))
+        catch-clauses (into [] 
+                        (for [clause catches] 
+                          (let [start-clause-label (.newLabel *gen*)
+                                end-clause-label (.newLabel *gen*)
+                                catch-type-name (-> clause :catch-type maybe-class .getName (.replace \. \/))]  
+                            (.visitTryCatchBlock *gen* start-try-label end-try-label start-clause-label catch-type-name)
+                            {:clause clause :start-clause-label start-clause-label :end-clause-label end-clause-label})))
+        return-type (expression-type try)
+        asm-return-type (asm-type return-type)
+        ret-local (next-local return-type)
+        catch-local-index (next-local java.lang.Object)]
+    (when finally
+      (.visitTryCatchBlock *gen* start-try-label end-try-label finally-label nil)) 
+    (.mark *gen* start-try-label)
+    (emit try)
+    ;; Store the result in ret-local
+    (.visitVarInsn *gen* (.getOpcode asm-return-type Opcodes/ISTORE) ret-local)
+    (.mark *gen* end-try-label)
+    (when finally
+      (emit finally))
+    (.goTo *gen* ret-label)
+    (doseq [{:keys [start-clause-label clause end-clause-label]} catch-clauses] 
+      (let [{:keys [catch-type catch-local]} clause]
+        (binding [*frame* (copy-frame)]
+          (when finally
+            (.visitTryCatchBlock *gen* start-clause-label end-clause-label finally-label nil))    
+          (.mark *gen* start-clause-label)  
+          ;; Make the exception that is on the stack available as the catch-local
+          (swap! *frame* assoc-in [:locals catch-local] {:index catch-local-index :type catch-type})
+          (.visitVarInsn *gen* (.getOpcode object-type Opcodes/ISTORE) catch-local-index)  
+          (emit clause)  
+          ;; Store the result back in ret-local
+          (.visitVarInsn *gen* (.getOpcode asm-return-type Opcodes/ISTORE) ret-local)  
+          (.mark *gen* end-clause-label)  
+          (when finally
+            (emit finally))
+          (.goTo *gen* ret-label)
+          (.visitLocalVariable 
+            *gen* (str catch-local) (.getDescriptor object-type) nil start-clause-label end-clause-label catch-local-index))))
+    ;; Finally for unhandled exceptions
+    (when finally
+      (.mark *gen* finally-label)
+      (let [temp (next-local java.lang.Object)]
+        ;; Save the exception that is on the stack
+        (.visitVarInsn *gen* (.getOpcode object-type Opcodes/ISTORE) temp)
+        (emit finally)
+        (.visitVarInsn *gen* (.getOpcode object-type Opcodes/ILOAD) temp)
+        (.throwException *gen*)))
+    (.mark *gen* ret-label)
+    (.visitVarInsn *gen* (.getOpcode asm-return-type Opcodes/ILOAD) ret-local)))
+
 (defmethod emit :def [{:keys [name form init env doc export] :as args}]
   (let [sym (second form)
         symbol (symbol (str *ns*) (str sym))

File src/clojure/java/compiler/ast.clj

         (assoc-in [:else :box] true))
       form)))
 
+(defmethod set-box :try
+  [form]
+  (if (:box form)
+    (walk-node #(assoc % :box true) form)
+    form))
+
 (defmethod set-box :fn
   [form]
   ;; TODO: this needs to check type hints, etc
                  :else nil))]
     (assoc form :type type)))
 
+(defmethod compute-type :try
+  [{:as form :keys [try catch finally]}]
+  ; TODO: Reconcile types, report prim/unboxed mismatches
+  (assoc form :type (expression-type try)))  
+
 (def process-frames (ast-processor [set-box]
                       [collect-constants collect-vars collect-callsites compute-type transform]))

File test/test/clojure/java/compiler.clj

   (is (= :success ((c/eval '(let [a :success] (reify clojure.lang.IFn (invoke [this] (let [a a] a))))))) "locals shadow captures correctly")
   (is (= :success ((c/eval '(reify clojure.lang.IFn (invoke [this a] (let [a :success] a)))) :failure)) "locals shadow args")
   (is (= :success ((c/eval '(reify clojure.lang.IFn (invoke [this a] (let [a a] a)))) :success)) "locals shadow args correctly"))
+
+(deftest exceptions
+  (is (= :success (c/eval '(try :success))))
+  (is (= :success (c/eval '(try :success (catch java.lang.Exception e :failure)))))
+  (is (= :success (c/eval '(try :success (finally :failure)))))
+  (is (= :success (c/eval '(try :success (catch java.lang.Exception e :failure) (finally :failure)))))
+  (is (= :success (c/eval '(try (/ 1 0) :failure (catch Throwable e :success) (finally :failure))))))