Merge branch 'master' into new

5 files changed, 338 insertions, 39 deletions

diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj
index 1cd7b167..aa22ba9c 100644
--- a/src/clj/clojure/core.clj
+++ b/src/clj/clojure/core.clj
@@ -115,6 +115,11 @@
 
 (def
  #^{:arglists '([x])
+    :doc "Return true if x is a Character"}
+ char? (fn char? [x] (instance? Character x)))
+
+(def
+ #^{:arglists '([x])
     :doc "Return true if x is a String"}
  string? (fn string? [x] (instance? String x)))
 
@@ -225,7 +230,16 @@
               fdecl (if (map? (last fdecl))
                       (butlast fdecl)
                       fdecl)
-              m (conj {:arglists (list 'quote (sigs fdecl))} m)]
+              m (conj {:arglists (list 'quote (sigs fdecl))} m)
+              m (let [inline (:inline m)
+                      ifn (first inline)
+                      iname (second inline)]
+                  ;; same as: (if (and (= 'fn ifn) (not (symbol? iname))) ...)
+                  (if (if (clojure.lang.Util/equiv 'fn ifn)
+                        (if (instance? clojure.lang.Symbol iname) false true))
+                    ;; inserts the same fn name to the inline fn if it does not have one
+                    (assoc m :inline (cons ifn (cons name (next inline))))
+                    m))]
           (list 'def (with-meta name (conj (if (meta name) (meta name) {}) m))
                 (cons `fn (cons name fdecl))))))
                 ;(cons `fn fdecl)))))
@@ -267,24 +281,30 @@
   "Returns a new hash set with supplied keys."
   ([] #{})
   ([& keys]
-   (. clojure.lang.PersistentHashSet (create keys))))
+   (clojure.lang.PersistentHashSet/create keys)))
 
 (defn sorted-map
   "keyval => key val
   Returns a new sorted map with supplied mappings."
   ([& keyvals]
-   (. clojure.lang.PersistentTreeMap (create keyvals))))
-
-(defn sorted-set
-  "Returns a new sorted set with supplied keys."
-  ([& keys]
-   (. clojure.lang.PersistentTreeSet (create keys))))
+   (clojure.lang.PersistentTreeMap/create keyvals)))
 
 (defn sorted-map-by
   "keyval => key val
   Returns a new sorted map with supplied mappings, using the supplied comparator."
   ([comparator & keyvals]
-   (. clojure.lang.PersistentTreeMap (create comparator keyvals))))
+   (clojure.lang.PersistentTreeMap/create comparator keyvals)))
+
+(defn sorted-set
+  "Returns a new sorted set with supplied keys."
+  ([& keys]
+   (clojure.lang.PersistentTreeSet/create keys)))
+
+(defn sorted-set-by
+  "Returns a new sorted set with supplied keys, using the supplied comparator."
+  ([comparator & keys]
+   (clojure.lang.PersistentTreeSet/create comparator keys)))
+
  
 ;;;;;;;;;;;;;;;;;;;;
 (def
@@ -1065,8 +1085,9 @@
   second item in the first form, making a list of it if it is not a
   list already. If there are more forms, inserts the first form as the
   second item in second form, etc."
+  ([x] x)
   ([x form] (if (seq? form)
-              `(~(first form) ~x ~@(next form))
+              (with-meta `(~(first form) ~x ~@(next form)) (meta form))
               (list form x)))
   ([x form & more] `(-> (-> ~x ~form) ~@more)))
 
@@ -1076,7 +1097,7 @@
   list already. If there are more forms, inserts the first form as the
   last item in second form, etc."
   ([x form] (if (seq? form)
-              `(~(first form) ~@(next form)  ~x)
+              (with-meta `(~(first form) ~@(next form)  ~x) (meta form))
               (list form x)))
   ([x form & more] `(->> (->> ~x ~form) ~@more)))
 
@@ -1125,7 +1146,7 @@
 (defmacro defmethod
   "Creates and installs a new method of multimethod associated with dispatch-value. "
   [multifn dispatch-val & fn-tail]
-  `(. ~multifn addMethod ~dispatch-val (fn ~@fn-tail)))
+  `(. ~(with-meta multifn {:tag 'clojure.lang.MultiFn}) addMethod ~dispatch-val (fn ~@fn-tail)))
 
 (defn remove-method
   "Removes the method of multimethod associated	with dispatch-value."
@@ -1244,6 +1265,42 @@
          (finally
            (pop-thread-bindings))))))
 
+(defn with-bindings*
+  "Takes a map of Var/value pairs. Installs for the given Vars the associated
+  values as thread-local bindings. Then calls f with the supplied arguments.
+  Pops the installed bindings after f returned. Returns whatever f returns."
+  [binding-map f & args]
+  (push-thread-bindings binding-map)
+  (try
+    (apply f args)
+    (finally
+      (pop-thread-bindings))))
+
+(defmacro with-bindings
+  "Takes a map of Var/value pairs. Installs for the given Vars the associated
+  values as thread-local bindings. The executes body. Pops the installed
+  bindings after body was evaluated. Returns the value of body."
+  [binding-map & body]
+  `(with-bindings* ~binding-map (fn [] ~@body)))
+
+(defn bound-fn*
+  "Returns a function, which will install the same bindings in effect as in
+  the thread at the time bound-fn* was called and then call f with any given
+  arguments. This may be used to define a helper function which runs on a
+  different thread, but needs the same bindings in place."
+  [f]
+  (let [bindings (get-thread-bindings)]
+    (fn [& args]
+      (apply with-bindings* bindings f args))))
+
+(defmacro bound-fn
+  "Returns a function defined by the given fntail, which will install the
+  same bindings in effect as in the thread at the time bound-fn was called.
+  This may be used to define a helper function which runs on a different
+  thread, but needs the same bindings in place."
+  [& fntail]
+  `(bound-fn* (fn ~@fntail)))
+
 (defn find-var
   "Returns the global var named by the namespace-qualified symbol, or
   nil if no var with that name."
@@ -1671,7 +1728,7 @@
 (defn some
   "Returns the first logical true value of (pred x) for any x in coll,
   else nil.  One common idiom is to use a set as pred, for example
-  this will return true if :fred is in the sequence, otherwise nil:
+  this will return :fred if :fred is in the sequence, otherwise nil:
   (some #{:fred} coll)"
   [pred coll]
     (when (seq coll)
@@ -1913,10 +1970,9 @@
   "Returns the lines of text from rdr as a lazy sequence of strings.
   rdr must implement java.io.BufferedReader."
   [#^java.io.BufferedReader rdr]
-  (lazy-seq
-   (let [line  (. rdr (readLine))]
-     (when line
-       (cons line (line-seq rdr))))))
+  (let [line  (. rdr (readLine))]
+    (when line
+      (lazy-seq (cons line (line-seq rdr))))))
 
 (defn comparator
   "Returns an implementation of java.util.Comparator based upon pred."
@@ -3161,11 +3217,10 @@
   using java.util.regex.Matcher.find(), each such match processed with
   re-groups."
   [#^java.util.regex.Pattern re s]
-    (let [m (re-matcher re s)]
-      ((fn step []
-         (lazy-seq
-          (when (. m (find))
-            (cons (re-groups m) (step))))))))
+  (let [m (re-matcher re s)]
+    ((fn step []
+       (when (. m (find))
+         (lazy-seq (cons (re-groups m) (step))))))))
 
 (defn re-matches
   "Returns the match, if any, of string to pattern, using
@@ -3456,7 +3511,7 @@
   (let [[pre-args [args expr]] (split-with (comp not vector?) decl)]
     `(do
        (defn ~name ~@pre-args ~args ~(apply (eval (list `fn args expr)) args))
-       (alter-meta! (var ~name) assoc :inline (fn ~args ~expr))
+       (alter-meta! (var ~name) assoc :inline (fn ~name ~args ~expr))
        (var ~name))))
 
 (defn empty
@@ -3497,6 +3552,34 @@
   ([size-or-seq] (. clojure.lang.Numbers float_array size-or-seq))
   ([size init-val-or-seq] (. clojure.lang.Numbers float_array size init-val-or-seq)))
 
+(defn boolean-array
+  "Creates an array of booleans"
+  {:inline (fn [& args] `(. clojure.lang.Numbers boolean_array ~@args))
+   :inline-arities #{1 2}}
+  ([size-or-seq] (. clojure.lang.Numbers boolean_array size-or-seq))
+  ([size init-val-or-seq] (. clojure.lang.Numbers boolean_array size init-val-or-seq)))
+
+(defn byte-array
+  "Creates an array of bytes"
+  {:inline (fn [& args] `(. clojure.lang.Numbers byte_array ~@args))
+   :inline-arities #{1 2}}
+  ([size-or-seq] (. clojure.lang.Numbers byte_array size-or-seq))
+  ([size init-val-or-seq] (. clojure.lang.Numbers byte_array size init-val-or-seq)))
+
+(defn char-array
+  "Creates an array of chars"
+  {:inline (fn [& args] `(. clojure.lang.Numbers char_array ~@args))
+   :inline-arities #{1 2}}
+  ([size-or-seq] (. clojure.lang.Numbers char_array size-or-seq))
+  ([size init-val-or-seq] (. clojure.lang.Numbers char_array size init-val-or-seq)))
+
+(defn short-array
+  "Creates an array of shorts"
+  {:inline (fn [& args] `(. clojure.lang.Numbers short_array ~@args))
+   :inline-arities #{1 2}}
+  ([size-or-seq] (. clojure.lang.Numbers short_array size-or-seq))
+  ([size init-val-or-seq] (. clojure.lang.Numbers short_array size init-val-or-seq)))
+
 (defn double-array
   "Creates an array of doubles"
   {:inline (fn [& args] `(. clojure.lang.Numbers double_array ~@args))
@@ -3512,12 +3595,28 @@
   ([size init-val-or-seq] (. clojure.lang.Numbers int_array size init-val-or-seq)))
 
 (defn long-array
-  "Creates an array of ints"
+  "Creates an array of longs"
   {:inline (fn [& args] `(. clojure.lang.Numbers long_array ~@args))
    :inline-arities #{1 2}}
   ([size-or-seq] (. clojure.lang.Numbers long_array size-or-seq))
   ([size init-val-or-seq] (. clojure.lang.Numbers long_array size init-val-or-seq)))
 
+(definline booleans
+  "Casts to boolean[]"
+  [xs] `(. clojure.lang.Numbers booleans ~xs))
+
+(definline bytes
+  "Casts to bytes[]"
+  [xs] `(. clojure.lang.Numbers bytes ~xs))
+
+(definline chars
+  "Casts to chars[]"
+  [xs] `(. clojure.lang.Numbers chars ~xs))
+
+(definline shorts
+  "Casts to shorts[]"
+  [xs] `(. clojure.lang.Numbers shorts ~xs))
+
 (definline floats
   "Casts to float[]"
   [xs] `(. clojure.lang.Numbers floats ~xs))
@@ -3754,9 +3853,8 @@
           row-struct (apply create-struct keys)
           row-values (fn [] (map (fn [#^Integer i] (. rs (getObject i))) idxs))
           rows (fn thisfn []
-                   (lazy-seq
-                    (when (. rs (next))
-                      (cons (apply struct row-struct (row-values)) (thisfn)))))]
+                 (when (. rs (next))
+                   (lazy-seq (cons (apply struct row-struct (row-values)) (thisfn)))))]
       (rows)))
 
 (defn iterator-seq
diff --git a/src/clj/clojure/main.clj b/src/clj/clojure/main.clj
index 633c21e9..8c2e9449 100644
--- a/src/clj/clojure/main.clj
+++ b/src/clj/clojure/main.clj
@@ -9,6 +9,7 @@
 ;; Originally contributed by Stephen C. Gilardi
 
 (ns clojure.main
+  (:refer-clojure :exclude [with-bindings])
   (:import (clojure.lang Compiler Compiler$CompilerException
                          LineNumberingPushbackReader RT)))
 
diff --git a/src/clj/clojure/test.clj b/src/clj/clojure/test.clj
index 5e432899..bdebc44a 100644
--- a/src/clj/clojure/test.clj
+++ b/src/clj/clojure/test.clj
@@ -797,14 +797,14 @@ Chas Emerick, Allen Rohner, and Stuart Halloway",
   When *load-tests* is false, deftest is ignored."
   [name & body]
   (when *load-tests*
-    `(def ~(with-meta name {:test `(fn [] ~@body)})
+    `(def ~(vary-meta name assoc :test `(fn [] ~@body))
           (fn [] (test-var (var ~name))))))
 
 (defmacro deftest-
   "Like deftest but creates a private var."
   [name & body]
   (when *load-tests*
-    `(def ~(with-meta name {:test `(fn [] ~@body), :private true})
+    `(def ~(vary-meta name assoc :test `(fn [] ~@body) :private true)
           (fn [] (test-var (var ~name))))))
 
 
@@ -826,9 +826,13 @@ Chas Emerick, Allen Rohner, and Stuart Halloway",
   "Adds elements in coll to the current namespace metadata as the
   value of key."
   [key coll]
-  (alter-meta! *ns* assoc key (concat (key (meta *ns*)) coll)))
+  (alter-meta! *ns* assoc key coll))
 
-(defmulti use-fixtures (fn [fixture-type & args] fixture-type))
+(defmulti use-fixtures
+  "Wrap test runs in a fixture function to perform setup and
+  teardown. Using a fixture-type of :each wraps every test
+  individually, while:once wraps the whole run in a single function."
+  (fn [fixture-type & args] fixture-type))
 
 (defmethod use-fixtures :each [fixture-type & args]
   (add-ns-meta ::each-fixtures args))
diff --git a/src/clj/clojure/test/junit.clj b/src/clj/clojure/test/junit.clj
new file mode 100644
index 00000000..c42887eb
--- /dev/null
+++ b/src/clj/clojure/test/junit.clj
@@ -0,0 +1,193 @@
+;   Copyright (c) Rich Hickey. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+;; test/junit.clj: Extension to clojure.test for JUnit-compatible XML output
+
+;; by Jason Sankey
+;; June 2009
+
+;; DOCUMENTATION
+;;
+;; This is an extension to clojure.test that adds support for
+;; JUnit-compatible XML output.
+;;
+;; JUnit (http://junit.org/) is the most popular unit-testing library
+;; for Java.  As such, tool support for JUnit output formats is
+;; common.  By producing compatible output from tests, this tool
+;; support can be exploited.
+;;
+;; To use, wrap any calls to clojure.test/run-tests in the
+;; with-junit-output macro, like this:
+;;
+;;   (use 'clojure.test)
+;;   (use 'clojure.contrib.test.junit)
+;;
+;;   (with-junit-output
+;;     (run-tests 'my.cool.library))
+;;
+;; To write the output to a file, rebind clojure.test/*test-out* to
+;; your own PrintWriter (perhaps opened using
+;; clojure.contrib.duck-streams/writer).
+
+(ns clojure.test.junit
+  (:require [clojure.stacktrace :as stack]
+            [clojure.test :as t]))
+
+;; copied from clojure.contrib.lazy-xml
+(def #^{:private true}
+     escape-xml-map
+     (zipmap "'<>\"&" (map #(str \& % \;) '[apos lt gt quot amp])))
+(defn- escape-xml [text]
+  (apply str (map #(escape-xml-map % %) text)))
+
+(def *var-context*)
+(def *depth*)
+
+(defn indent
+  []
+  (dotimes [n (* *depth* 4)] (print " ")))
+
+(defn start-element
+  [tag pretty & [attrs]]
+  (if pretty (indent))
+  (print (str "<" tag))
+  (if (seq attrs)
+    (doseq [[key value] attrs]
+      (print (str " " (name key) "=\"" (escape-xml value) "\""))))
+  (print ">")
+  (if pretty (println))
+  (set! *depth* (inc *depth*)))
+
+(defn element-content
+  [content]
+  (print (escape-xml content)))
+
+(defn finish-element
+  [tag pretty]
+  (set! *depth* (dec *depth*))
+  (if pretty (indent))
+  (print (str "</" tag ">"))
+  (if pretty (println)))
+
+(defn test-name
+  [vars]
+  (apply str (interpose "."
+                        (reverse (map #(:name (meta %)) vars)))))
+
+(defn package-class
+  [name]
+  (let [i (.lastIndexOf name ".")]
+    (if (< i 0)
+      [nil name]
+      [(.substring name 0 i) (.substring name (+ i 1))])))
+
+(defn start-case
+  [name classname]
+  (start-element 'testcase true {:name name :classname classname}))
+
+(defn finish-case
+  []
+  (finish-element 'testcase true))
+
+(defn suite-attrs
+  [package classname]
+  (let [attrs {:name classname}]
+    (if package
+      (assoc attrs :package package)
+      attrs)))
+
+(defn start-suite
+  [name]
+  (let [[package classname] (package-class name)]
+    (start-element 'testsuite true (suite-attrs package classname))))
+
+(defn finish-suite
+  []
+  (finish-element 'testsuite true))
+
+(defn message-el
+  [tag message expected-str actual-str]
+  (indent)
+  (start-element tag false (if message {:message message} {}))
+  (element-content
+   (let [[file line] (t/file-position 5)
+         detail (apply str (interpose
+                            "\n"
+                            [(str "expected: " expected-str)
+                             (str "  actual: " actual-str)
+                             (str "      at: " file ":" line)]))]
+     (if message (str message "\n" detail) detail)))
+  (finish-element tag false)
+  (println))
+
+(defn failure-el
+  [message expected actual]
+  (message-el 'failure message (pr-str expected) (pr-str actual)))
+
+(defn error-el
+  [message expected actual]
+  (message-el 'error
+              message
+              (pr-str expected)
+              (if (instance? Throwable actual)
+                (with-out-str (stack/print-cause-trace actual t/*stack-trace-depth*))
+                (prn actual))))
+
+;; This multimethod will override test-is/report
+(defmulti junit-report :type)
+
+(defmethod junit-report :begin-test-ns [m]
+  (t/with-test-out
+   (start-suite (name (ns-name (:ns m))))))
+
+(defmethod junit-report :end-test-ns [_]
+  (t/with-test-out
+   (finish-suite)))
+
+(defmethod junit-report :begin-test-var [m]
+  (t/with-test-out
+   (let [var (:var m)]
+     (binding [*var-context* (conj *var-context* var)]
+       (start-case (test-name *var-context*) (name (ns-name (:ns (meta var)))))))))
+
+(defmethod junit-report :end-test-var [m]
+  (t/with-test-out
+   (finish-case)))
+
+(defmethod junit-report :pass [m]
+  (t/with-test-out
+   (t/inc-report-counter :pass)))
+
+(defmethod junit-report :fail [m]
+  (t/with-test-out
+   (t/inc-report-counter :fail)
+   (failure-el (:message m)
+               (:expected m)
+               (:actual m))))
+
+(defmethod junit-report :error [m]
+  (t/with-test-out
+   (t/inc-report-counter :error)
+   (error-el (:message m)
+             (:expected m)
+             (:actual m))))
+
+(defmethod junit-report :default [_])
+
+(defmacro with-junit-output
+  "Execute body with modified test-is reporting functions that write
+  JUnit-compatible XML output."
+  [& body]
+  `(binding [t/report junit-report
+             *var-context* (list)
+             *depth* 1]
+     (println "<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
+     (println "<testsuites>")
+     (let [result# ~@body]
+       (println "</testsuites>")
+       result#)))
diff --git a/src/clj/clojure/zip.clj b/src/clj/clojure/zip.clj
index 00cc3be5..7423513f 100644
--- a/src/clj/clojure/zip.clj
+++ b/src/clj/clojure/zip.clj
@@ -66,7 +66,9 @@
 (defn children
   "Returns a seq of the children of node at loc, which must be a branch"
   [loc]
-    ((:zip/children ^loc) (node loc)))
+    (if (branch? loc)
+      ((:zip/children ^loc) (node loc))
+      (throw (Exception. "called children on a leaf node"))))
 
 (defn make-node
   "Returns a new branch node, given an existing node and new
@@ -94,13 +96,14 @@
   "Returns the loc of the leftmost child of the node at this loc, or
   nil if no children"
   [loc]
-    (let [[node path] loc
-          [c & cnext :as cs] (children loc)]
-      (when cs
-        (with-meta [c {:l [] 
-                       :pnodes (if path (conj (:pnodes path) node) [node]) 
-                       :ppath path 
-                       :r cnext}] ^loc))))
+    (when (branch? loc)
+      (let [[node path] loc
+            [c & cnext :as cs] (children loc)]
+        (when cs
+          (with-meta [c {:l [] 
+                         :pnodes (if path (conj (:pnodes path) node) [node]) 
+                         :ppath path 
+                         :r cnext}] ^loc)))))
 
 (defn up
   "Returns the loc of the parent of the node at this loc, or nil if at