added condp, with input from Stuart Sierra and Meikel Brandmeyer

1 files changed, 41 insertions, 0 deletions

diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj
index cf19ec54..0b58b4ff 100644
--- a/src/clj/clojure/core.clj
+++ b/src/clj/clojure/core.clj
@@ -3612,6 +3612,47 @@
           (swap! mem assoc args ret)
           ret)))))
 
+(defmacro condp
+  "Takes a binary predicate, an expression, and a set of clauses.
+  Each clause can take the form of either:
+  
+  test-expr result-expr
+
+  test-expr :>> result-fn
+
+  Note :>> is an ordinary keyword.
+
+  For each clause, (pred test-expr expr) is evaluated. If it returns
+  logical true, the clause is a match. If a binary clause matches, the
+  result-expr is returned, if a ternary clause matches, its result-fn,
+  which must be a unary function, is called with the result of the
+  predicate as its argument, the result of that call being the return
+  value of condp. A single default expression can follow the clauses,
+  and its value will be returned if no clause matches. If no default
+  expression is provided and no clause matches, an
+  IllegalArgumentException is thrown."
+
+  [pred expr & clauses]
+  (let [gpred (gensym "pred__")
+        gexpr (gensym "expr__")
+        emit (fn emit [pred expr args]
+               (let [[[a b c :as clause] more] 
+                       (split-at (if (= :>> (second args)) 3 2) args)
+                       n (count clause)]
+                 (cond 
+                  (= 0 n) `(throw (IllegalArgumentException. "No matching clause"))
+                  (= 1 n) a
+                  (= 2 n) `(if (~pred ~a ~expr) 
+                             ~b 
+                             ~(emit pred expr more))
+                  :else `(if-let [p# (~pred ~a ~expr)] 
+                           (~c p#) 
+                           ~(emit pred expr more)))))
+        gres (gensym "res__")]
+    `(let [~gpred ~pred
+           ~gexpr ~expr]
+       ~(emit gpred gexpr clauses))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; helper files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (load "core_proxy")