diff options
Diffstat (limited to 'etc/todo/scanners/clojure-libs.in.clj')
| -rw-r--r-- | etc/todo/scanners/clojure-libs.in.clj | 6820 |
1 files changed, 0 insertions, 6820 deletions
diff --git a/etc/todo/scanners/clojure-libs.in.clj b/etc/todo/scanners/clojure-libs.in.clj deleted file mode 100644 index f8a0044..0000000 --- a/etc/todo/scanners/clojure-libs.in.clj +++ /dev/null @@ -1,6820 +0,0 @@ -; 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. - -(ns clojure.core) - -(def unquote) -(def unquote-splicing) - -(def - #^{:arglists '([& items]) - :doc "Creates a new list containing the items."} - list (. clojure.lang.PersistentList creator)) - -(def - #^{:arglists '([x seq]) - :doc "Returns a new seq where x is the first element and seq is - the rest."} - - cons (fn* cons [x seq] (. clojure.lang.RT (cons x seq)))) - -;during bootstrap we don't have destructuring let, loop or fn, will redefine later -(def - #^{:macro true} - let (fn* let [& decl] (cons 'let* decl))) - -(def - #^{:macro true} - loop (fn* loop [& decl] (cons 'loop* decl))) - -(def - #^{:macro true} - fn (fn* fn [& decl] (cons 'fn* decl))) - -(def - #^{:arglists '([coll]) - :doc "Returns the first item in the collection. Calls seq on its - argument. If coll is nil, returns nil."} - first (fn first [coll] (. clojure.lang.RT (first coll)))) - -(def - #^{:arglists '([coll]) - :tag clojure.lang.ISeq - :doc "Returns a seq of the items after the first. Calls seq on its - argument. If there are no more items, returns nil."} - next (fn next [x] (. clojure.lang.RT (next x)))) - -(def - #^{:arglists '([coll]) - :tag clojure.lang.ISeq - :doc "Returns a possibly empty seq of the items after the first. Calls seq on its - argument."} - rest (fn rest [x] (. clojure.lang.RT (more x)))) - -(def - #^{:arglists '([coll x] [coll x & xs]) - :doc "conj[oin]. Returns a new collection with the xs - 'added'. (conj nil item) returns (item). The 'addition' may - happen at different 'places' depending on the concrete type."} - conj (fn conj - ([coll x] (. clojure.lang.RT (conj coll x))) - ([coll x & xs] - (if xs - (recur (conj coll x) (first xs) (next xs)) - (conj coll x))))) - -(def - #^{:doc "Same as (first (next x))" - :arglists '([x])} - second (fn second [x] (first (next x)))) - -(def - #^{:doc "Same as (first (first x))" - :arglists '([x])} - ffirst (fn ffirst [x] (first (first x)))) - -(def - #^{:doc "Same as (next (first x))" - :arglists '([x])} - nfirst (fn nfirst [x] (next (first x)))) - -(def - #^{:doc "Same as (first (next x))" - :arglists '([x])} - fnext (fn fnext [x] (first (next x)))) - -(def - #^{:doc "Same as (next (next x))" - :arglists '([x])} - nnext (fn nnext [x] (next (next x)))) - -(def - #^{:arglists '([coll]) - :doc "Returns a seq on the collection. If the collection is - empty, returns nil. (seq nil) returns nil. seq also works on - Strings, native Java arrays (of reference types) and any objects - that implement Iterable." - :tag clojure.lang.ISeq} - seq (fn seq [coll] (. clojure.lang.RT (seq coll)))) - -(def - #^{:arglists '([#^Class c x]) - :doc "Evaluates x and tests if it is an instance of the class - c. Returns true or false"} - instance? (fn instance? [#^Class c x] (. c (isInstance x)))) - -(def - #^{:arglists '([x]) - :doc "Return true if x implements ISeq"} - seq? (fn seq? [x] (instance? clojure.lang.ISeq x))) - -(def - #^{:arglists '([x]) - :doc "Return true if x is a String"} - string? (fn string? [x] (instance? String x))) - -(def - #^{:arglists '([x]) - :doc "Return true if x implements IPersistentMap"} - map? (fn map? [x] (instance? clojure.lang.IPersistentMap x))) - -(def - #^{:arglists '([x]) - :doc "Return true if x implements IPersistentVector "} - vector? (fn vector? [x] (instance? clojure.lang.IPersistentVector x))) - -(def - #^{:private true} - sigs - (fn [fdecl] - (if (seq? (first fdecl)) - (loop [ret [] fdecl fdecl] - (if fdecl - (recur (conj ret (first (first fdecl))) (next fdecl)) - (seq ret))) - (list (first fdecl))))) - -(def - #^{:arglists '([map key val] [map key val & kvs]) - :doc "assoc[iate]. When applied to a map, returns a new map of the - same (hashed/sorted) type, that contains the mapping of key(s) to - val(s). When applied to a vector, returns a new vector that - contains val at index. Note - index must be <= (count vector)."} - assoc - (fn assoc - ([map key val] (. clojure.lang.RT (assoc map key val))) - ([map key val & kvs] - (let [ret (assoc map key val)] - (if kvs - (recur ret (first kvs) (second kvs) (nnext kvs)) - ret))))) - -;;;;;;;;;;;;;;;;; metadata ;;;;;;;;;;;;;;;;;;;;;;;;;;; -(def - #^{:arglists '([obj]) - :doc "Returns the metadata of obj, returns nil if there is no metadata."} - meta (fn meta [x] - (if (instance? clojure.lang.IMeta x) - (. #^clojure.lang.IMeta x (meta))))) - -(def - #^{:arglists '([#^clojure.lang.IObj obj m]) - :doc "Returns an object of the same type and value as obj, with - map m as its metadata."} - with-meta (fn with-meta [#^clojure.lang.IObj x m] - (. x (withMeta m)))) - -(def - #^{:arglists '([coll]) - :doc "Return the last item in coll, in linear time"} - last (fn last [s] - (if (next s) - (recur (next s)) - (first s)))) - -(def - #^{:arglists '([coll]) - :doc "Return a seq of all but the last item in coll, in linear time"} - butlast (fn butlast [s] - (loop [ret [] s s] - (if (next s) - (recur (conj ret (first s)) (next s)) - (seq ret))))) - -(def - - #^{:doc "Same as (def name (fn [params* ] exprs*)) or (def - name (fn ([params* ] exprs*)+)) with any doc-string or attrs added - to the var metadata" - :arglists '([name doc-string? attr-map? [params*] body] - [name doc-string? attr-map? ([params*] body)+ attr-map?])} - defn (fn defn [name & fdecl] - (let [m (if (string? (first fdecl)) - {:doc (first fdecl)} - {}) - fdecl (if (string? (first fdecl)) - (next fdecl) - fdecl) - m (if (map? (first fdecl)) - (conj m (first fdecl)) - m) - fdecl (if (map? (first fdecl)) - (next fdecl) - fdecl) - fdecl (if (vector? (first fdecl)) - (list fdecl) - fdecl) - m (if (map? (last fdecl)) - (conj m (last fdecl)) - m) - fdecl (if (map? (last fdecl)) - (butlast fdecl) - fdecl) - m (conj {:arglists (list 'quote (sigs fdecl))} m)] - (list 'def (with-meta name (conj (if (meta name) (meta name) {}) m)) - (cons `fn fdecl))))) - -(. (var defn) (setMacro)) - -(defn cast - "Throws a ClassCastException if x is not a c, else returns x." - [#^Class c x] - (. c (cast x))) - -(defn to-array - "Returns an array of Objects containing the contents of coll, which - can be any Collection. Maps to java.util.Collection.toArray()." - {:tag "[Ljava.lang.Object;"} - [coll] (. clojure.lang.RT (toArray coll))) - -(defn vector - "Creates a new vector containing the args." - ([] []) - ([& args] - (. clojure.lang.LazilyPersistentVector (create args)))) - -(defn vec - "Creates a new vector containing the contents of coll." - ([coll] - (. clojure.lang.LazilyPersistentVector (createOwning (to-array coll))))) - -(defn hash-map - "keyval => key val - Returns a new hash map with supplied mappings." - ([] {}) - ([& keyvals] - (. clojure.lang.PersistentHashMap (create keyvals)))) - -(defn hash-set - "Returns a new hash set with supplied keys." - ([] #{}) - ([& 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)))) - -(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)))) - -;;;;;;;;;;;;;;;;;;;; -(def - - #^{:doc "Like defn, but the resulting function name is declared as a - macro and will be used as a macro by the compiler when it is - called." - :arglists '([name doc-string? attr-map? [params*] body] - [name doc-string? attr-map? ([params*] body)+ attr-map?])} - defmacro (fn [name & args] - (list 'do - (cons `defn (cons name args)) - (list '. (list 'var name) '(setMacro)) - (list 'var name)))) - -(. (var defmacro) (setMacro)) - -(defmacro when - "Evaluates test. If logical true, evaluates body in an implicit do." - [test & body] - (list 'if test (cons 'do body))) - -(defmacro when-not - "Evaluates test. If logical false, evaluates body in an implicit do." - [test & body] - (list 'if test nil (cons 'do body))) - -(defn nil? - "Returns true if x is nil, false otherwise." - {:tag Boolean} - [x] (identical? x nil)) - -(defn false? - "Returns true if x is the value false, false otherwise." - {:tag Boolean} - [x] (identical? x false)) - -(defn true? - "Returns true if x is the value true, false otherwise." - {:tag Boolean} - [x] (identical? x true)) - -(defn not - "Returns true if x is logical false, false otherwise." - {:tag Boolean} - [x] (if x false true)) - -(defn str - "With no args, returns the empty string. With one arg x, returns - x.toString(). (str nil) returns the empty string. With more than - one arg, returns the concatenation of the str values of the args." - {:tag String} - ([] "") - ([#^Object x] - (if (nil? x) "" (. x (toString)))) - ([x & ys] - ((fn [#^StringBuilder sb more] - (if more - (recur (. sb (append (str (first more)))) (next more)) - (str sb))) - (new StringBuilder #^String (str x)) ys))) - - -(defn symbol? - "Return true if x is a Symbol" - [x] (instance? clojure.lang.Symbol x)) - -(defn keyword? - "Return true if x is a Keyword" - [x] (instance? clojure.lang.Keyword x)) - -(defn symbol - "Returns a Symbol with the given namespace and name." - ([name] (if (symbol? name) name (. clojure.lang.Symbol (intern name)))) - ([ns name] (. clojure.lang.Symbol (intern ns name)))) - -(defn keyword - "Returns a Keyword with the given namespace and name. Do not use : - in the keyword strings, it will be added automatically." - ([name] (if (keyword? name) name (. clojure.lang.Keyword (intern nil name)))) - ([ns name] (. clojure.lang.Keyword (intern ns name)))) - -(defn gensym - "Returns a new symbol with a unique name. If a prefix string is - supplied, the name is prefix# where # is some unique number. If - prefix is not supplied, the prefix is 'G__'." - ([] (gensym "G__")) - ([prefix-string] (. clojure.lang.Symbol (intern (str prefix-string (str (. clojure.lang.RT (nextID)))))))) - -(defmacro cond - "Takes a set of test/expr pairs. It evaluates each test one at a - time. If a test returns logical true, cond evaluates and returns - the value of the corresponding expr and doesn't evaluate any of the - other tests or exprs. (cond) returns nil." - [& clauses] - (when clauses - (list 'if (first clauses) - (if (next clauses) - (second clauses) - (throw (IllegalArgumentException. - "cond requires an even number of forms"))) - (cons 'clojure.core/cond (next (next clauses)))))) - -(defn spread - {:private true} - [arglist] - (cond - (nil? arglist) nil - (nil? (next arglist)) (seq (first arglist)) - :else (cons (first arglist) (spread (next arglist))))) - -(defn apply - "Applies fn f to the argument list formed by prepending args to argseq." - {:arglists '([f args* argseq])} - [#^clojure.lang.IFn f & args] - (. f (applyTo (spread args)))) - -(defn vary-meta - "Returns an object of the same type and value as obj, with - (apply f (meta obj) args) as its metadata." - [obj f & args] - (with-meta obj (apply f (meta obj) args))) - -(defn list* - "Creates a new list containing the item prepended to more." - [item & more] - (spread (cons item more))) - -(defmacro lazy-seq - "Takes a body of expressions that returns an ISeq or nil, and yields - a Seqable object that will invoke the body only the first time seq - is called, and will cache the result and return it on all subsequent - seq calls." - [& body] - (list 'new 'clojure.lang.LazySeq (list* '#^{:once true} fn* [] body))) - -(defn concat - "Returns a lazy seq representing the concatenation of the elements in the supplied colls." - ([] (lazy-seq nil)) - ([x] (lazy-seq x)) - ([x y] - (lazy-seq - (let [s (seq x)] - (if s - (cons (first s) (concat (rest s) y)) - y)))) - ([x y & zs] - (let [cat (fn cat [xys zs] - (lazy-seq - (let [xys (seq xys)] - (if xys - (cons (first xys) (cat (rest xys) zs)) - (when zs - (cat (first zs) (next zs)))))))] - (cat (concat x y) zs)))) - -;;;;;;;;;;;;;;;;at this point all the support for syntax-quote exists;;;;;;;;;;;;;;;;;;;;;; - - -(defmacro delay - "Takes a body of expressions and yields a Delay object that will - invoke the body only the first time it is forced (with force), and - will cache the result and return it on all subsequent force - calls." - [& body] - (list 'new 'clojure.lang.Delay (list* `#^{:once true} fn* [] body))) - -(defn delay? - "returns true if x is a Delay created with delay" - [x] (instance? clojure.lang.Delay x)) - -(defn force - "If x is a Delay, returns the (possibly cached) value of its expression, else returns x" - [x] (. clojure.lang.Delay (force x))) - -(defmacro if-not - "Evaluates test. If logical false, evaluates and returns then expr, otherwise else expr, if supplied, else nil." - ([test then] `(if-not ~test ~then nil)) - ([test then else] - `(if (not ~test) ~then ~else))) - -(defn = - "Equality. Returns true if x equals y, false if not. Same as - Java x.equals(y) except it also works for nil, and compares - numbers and collections in a type-independent manner. Clojure's immutable data - structures define equals() (and thus =) as a value, not an identity, - comparison." - {:tag Boolean - :inline (fn [x y] `(. clojure.lang.Util equiv ~x ~y)) - :inline-arities #{2}} - ([x] true) - ([x y] (clojure.lang.Util/equiv x y)) - ([x y & more] - (if (= x y) - (if (next more) - (recur y (first more) (next more)) - (= y (first more))) - false))) - -(defn not= - "Same as (not (= obj1 obj2))" - {:tag Boolean} - ([x] false) - ([x y] (not (= x y))) - ([x y & more] - (not (apply = x y more)))) - - - -(defn compare - "Comparator. Returns 0 if x equals y, -1 if x is logically 'less - than' y, else 1. Same as Java x.compareTo(y) except it also works - for nil, and compares numbers and collections in a type-independent - manner. x must implement Comparable" - {:tag Integer - :inline (fn [x y] `(. clojure.lang.Util compare ~x ~y))} - [x y] (. clojure.lang.Util (compare x y))) - -(defmacro and - "Evaluates exprs one at a time, from left to right. If a form - returns logical false (nil or false), and returns that value and - doesn't evaluate any of the other expressions, otherwise it returns - the value of the last expr. (and) returns true." - ([] true) - ([x] x) - ([x & next] - `(let [and# ~x] - (if and# (and ~@next) and#)))) - -(defmacro or - "Evaluates exprs one at a time, from left to right. If a form - returns a logical true value, or returns that value and doesn't - evaluate any of the other expressions, otherwise it returns the - value of the last expression. (or) returns nil." - ([] nil) - ([x] x) - ([x & next] - `(let [or# ~x] - (if or# or# (or ~@next))))) - -;;;;;;;;;;;;;;;;;;; sequence fns ;;;;;;;;;;;;;;;;;;;;;;; -(defn reduce - "f should be a function of 2 arguments. If val is not supplied, - returns the result of applying f to the first 2 items in coll, then - applying f to that result and the 3rd item, etc. If coll contains no - items, f must accept no arguments as well, and reduce returns the - result of calling f with no arguments. If coll has only 1 item, it - is returned and f is not called. If val is supplied, returns the - result of applying f to val and the first item in coll, then - applying f to that result and the 2nd item, etc. If coll contains no - items, returns val and f is not called." - ([f coll] - (let [s (seq coll)] - (if s - (if (instance? clojure.lang.IReduce s) - (. #^clojure.lang.IReduce s (reduce f)) - (reduce f (first s) (next s))) - (f)))) - ([f val coll] - (let [s (seq coll)] - (if (instance? clojure.lang.IReduce s) - (. #^clojure.lang.IReduce s (reduce f val)) - ((fn [f val s] - (if s - (recur f (f val (first s)) (next s)) - val)) - f val s))))) - -(defn reverse - "Returns a seq of the items in coll in reverse order. Not lazy." - [coll] - (reduce conj () coll)) - -;;math stuff -(defn + - "Returns the sum of nums. (+) returns 0." - {:inline (fn [x y] `(. clojure.lang.Numbers (add ~x ~y))) - :inline-arities #{2}} - ([] 0) - ([x] (cast Number x)) - ([x y] (. clojure.lang.Numbers (add x y))) - ([x y & more] - (reduce + (+ x y) more))) - -(defn * - "Returns the product of nums. (*) returns 1." - {:inline (fn [x y] `(. clojure.lang.Numbers (multiply ~x ~y))) - :inline-arities #{2}} - ([] 1) - ([x] (cast Number x)) - ([x y] (. clojure.lang.Numbers (multiply x y))) - ([x y & more] - (reduce * (* x y) more))) - -(defn / - "If no denominators are supplied, returns 1/numerator, - else returns numerator divided by all of the denominators." - {:inline (fn [x y] `(. clojure.lang.Numbers (divide ~x ~y))) - :inline-arities #{2}} - ([x] (/ 1 x)) - ([x y] (. clojure.lang.Numbers (divide x y))) - ([x y & more] - (reduce / (/ x y) more))) - -(defn - - "If no ys are supplied, returns the negation of x, else subtracts - the ys from x and returns the result." - {:inline (fn [& args] `(. clojure.lang.Numbers (minus ~@args))) - :inline-arities #{1 2}} - ([x] (. clojure.lang.Numbers (minus x))) - ([x y] (. clojure.lang.Numbers (minus x y))) - ([x y & more] - (reduce - (- x y) more))) - -(defn < - "Returns non-nil if nums are in monotonically increasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (lt ~x ~y))) - :inline-arities #{2}} - ([x] true) - ([x y] (. clojure.lang.Numbers (lt x y))) - ([x y & more] - (if (< x y) - (if (next more) - (recur y (first more) (next more)) - (< y (first more))) - false))) - -(defn <= - "Returns non-nil if nums are in monotonically non-decreasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (lte ~x ~y))) - :inline-arities #{2}} - ([x] true) - ([x y] (. clojure.lang.Numbers (lte x y))) - ([x y & more] - (if (<= x y) - (if (next more) - (recur y (first more) (next more)) - (<= y (first more))) - false))) - -(defn > - "Returns non-nil if nums are in monotonically decreasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (gt ~x ~y))) - :inline-arities #{2}} - ([x] true) - ([x y] (. clojure.lang.Numbers (gt x y))) - ([x y & more] - (if (> x y) - (if (next more) - (recur y (first more) (next more)) - (> y (first more))) - false))) - -(defn >= - "Returns non-nil if nums are in monotonically non-increasing order, - otherwise false." - {:inline (fn [x y] `(. clojure.lang.Numbers (gte ~x ~y))) - :inline-arities #{2}} - ([x] true) - ([x y] (. clojure.lang.Numbers (gte x y))) - ([x y & more] - (if (>= x y) - (if (next more) - (recur y (first more) (next more)) - (>= y (first more))) - false))) - -(defn == - "Returns non-nil if nums all have the same value, otherwise false" - {:inline (fn [x y] `(. clojure.lang.Numbers (equiv ~x ~y))) - :inline-arities #{2}} - ([x] true) - ([x y] (. clojure.lang.Numbers (equiv x y))) - ([x y & more] - (if (== x y) - (if (next more) - (recur y (first more) (next more)) - (== y (first more))) - false))) - -(defn max - "Returns the greatest of the nums." - ([x] x) - ([x y] (if (> x y) x y)) - ([x y & more] - (reduce max (max x y) more))) - -(defn min - "Returns the least of the nums." - ([x] x) - ([x y] (if (< x y) x y)) - ([x y & more] - (reduce min (min x y) more))) - -(defn inc - "Returns a number one greater than num." - {:inline (fn [x] `(. clojure.lang.Numbers (inc ~x)))} - [x] (. clojure.lang.Numbers (inc x))) - -(defn dec - "Returns a number one less than num." - {:inline (fn [x] `(. clojure.lang.Numbers (dec ~x)))} - [x] (. clojure.lang.Numbers (dec x))) - -(defn unchecked-inc - "Returns a number one greater than x, an int or long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_inc ~x)))} - [x] (. clojure.lang.Numbers (unchecked_inc x))) - -(defn unchecked-dec - "Returns a number one less than x, an int or long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_dec ~x)))} - [x] (. clojure.lang.Numbers (unchecked_dec x))) - -(defn unchecked-negate - "Returns the negation of x, an int or long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x] `(. clojure.lang.Numbers (unchecked_negate ~x)))} - [x] (. clojure.lang.Numbers (unchecked_negate x))) - -(defn unchecked-add - "Returns the sum of x and y, both int or long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_add ~x ~y)))} - [x y] (. clojure.lang.Numbers (unchecked_add x y))) - -(defn unchecked-subtract - "Returns the difference of x and y, both int or long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_subtract ~x ~y)))} - [x y] (. clojure.lang.Numbers (unchecked_subtract x y))) - -(defn unchecked-multiply - "Returns the product of x and y, both int or long. - Note - uses a primitive operator subject to overflow." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_multiply ~x ~y)))} - [x y] (. clojure.lang.Numbers (unchecked_multiply x y))) - -(defn unchecked-divide - "Returns the division of x by y, both int or long. - Note - uses a primitive operator subject to truncation." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_divide ~x ~y)))} - [x y] (. clojure.lang.Numbers (unchecked_divide x y))) - -(defn unchecked-remainder - "Returns the remainder of division of x by y, both int or long. - Note - uses a primitive operator subject to truncation." - {:inline (fn [x y] `(. clojure.lang.Numbers (unchecked_remainder ~x ~y)))} - [x y] (. clojure.lang.Numbers (unchecked_remainder x y))) - -(defn pos? - "Returns true if num is greater than zero, else false" - {:tag Boolean - :inline (fn [x] `(. clojure.lang.Numbers (isPos ~x)))} - [x] (. clojure.lang.Numbers (isPos x))) - -(defn neg? - "Returns true if num is less than zero, else false" - {:tag Boolean - :inline (fn [x] `(. clojure.lang.Numbers (isNeg ~x)))} - [x] (. clojure.lang.Numbers (isNeg x))) - -(defn zero? - "Returns true if num is zero, else false" - {:tag Boolean - :inline (fn [x] `(. clojure.lang.Numbers (isZero ~x)))} - [x] (. clojure.lang.Numbers (isZero x))) - -(defn quot - "quot[ient] of dividing numerator by denominator." - [num div] - (. clojure.lang.Numbers (quotient num div))) - -(defn rem - "remainder of dividing numerator by denominator." - [num div] - (. clojure.lang.Numbers (remainder num div))) - -(defn rationalize - "returns the rational value of num" - [num] - (. clojure.lang.Numbers (rationalize num))) - -;;Bit ops - -(defn bit-not - "Bitwise complement" - {:inline (fn [x] `(. clojure.lang.Numbers (not ~x)))} - [x] (. clojure.lang.Numbers not x)) - - -(defn bit-and - "Bitwise and" - {:inline (fn [x y] `(. clojure.lang.Numbers (and ~x ~y)))} - [x y] (. clojure.lang.Numbers and x y)) - -(defn bit-or - "Bitwise or" - {:inline (fn [x y] `(. clojure.lang.Numbers (or ~x ~y)))} - [x y] (. clojure.lang.Numbers or x y)) - -(defn bit-xor - "Bitwise exclusive or" - {:inline (fn [x y] `(. clojure.lang.Numbers (xor ~x ~y)))} - [x y] (. clojure.lang.Numbers xor x y)) - -(defn bit-and-not - "Bitwise and with complement" - [x y] (. clojure.lang.Numbers andNot x y)) - - -(defn bit-clear - "Clear bit at index n" - [x n] (. clojure.lang.Numbers clearBit x n)) - -(defn bit-set - "Set bit at index n" - [x n] (. clojure.lang.Numbers setBit x n)) - -(defn bit-flip - "Flip bit at index n" - [x n] (. clojure.lang.Numbers flipBit x n)) - -(defn bit-test - "Test bit at index n" - [x n] (. clojure.lang.Numbers testBit x n)) - - -(defn bit-shift-left - "Bitwise shift left" - [x n] (. clojure.lang.Numbers shiftLeft x n)) - -(defn bit-shift-right - "Bitwise shift right" - [x n] (. clojure.lang.Numbers shiftRight x n)) - -(defn even? - "Returns true if n is even, throws an exception if n is not an integer" - [n] (zero? (bit-and n 1))) - -(defn odd? - "Returns true if n is odd, throws an exception if n is not an integer" - [n] (not (even? n))) - - -;; - -(defn complement - "Takes a fn f and returns a fn that takes the same arguments as f, - has the same effects, if any, and returns the opposite truth value." - [f] - (fn - ([] (not (f))) - ([x] (not (f x))) - ([x y] (not (f x y))) - ([x y & zs] (not (apply f x y zs))))) - -(defn constantly - "Returns a function that takes any number of arguments and returns x." - [x] (fn [& args] x)) - -(defn identity - "Returns its argument." - [x] x) - -;;Collection stuff - - - -(defn count - "Returns the number of items in the collection. (count nil) returns - 0. Also works on strings, arrays, and Java Collections and Maps" - [coll] (. clojure.lang.RT (count coll))) - -;;list stuff -(defn peek - "For a list or queue, same as first, for a vector, same as, but much - more efficient than, last. If the collection is empty, returns nil." - [coll] (. clojure.lang.RT (peek coll))) - -(defn pop - "For a list or queue, returns a new list/queue without the first - item, for a vector, returns a new vector without the last item. If - the collection is empty, throws an exception. Note - not the same - as next/butlast." - [coll] (. clojure.lang.RT (pop coll))) - -(defn nth - "Returns the value at the index. get returns nil if index out of - bounds, nth throws an exception unless not-found is supplied. nth - also works for strings, Java arrays, regex Matchers and Lists, and, - in O(n) time, for sequences." - ([coll index] (. clojure.lang.RT (nth coll index))) - ([coll index not-found] (. clojure.lang.RT (nth coll index not-found)))) - -;;map stuff - -(defn contains? - "Returns true if key is present in the given collection, otherwise - returns false. Note that for numerically indexed collections like - vectors and Java arrays, this tests if the numeric key is within the - range of indexes. 'contains?' operates constant or logarithmic time; - it will not perform a linear search for a value. See also 'some'." - [coll key] (. clojure.lang.RT (contains coll key))) - -(defn get - "Returns the value mapped to key, not-found or nil if key not present." - ([map key] - (. clojure.lang.RT (get map key))) - ([map key not-found] - (. clojure.lang.RT (get map key not-found)))) - -(defn dissoc - "dissoc[iate]. Returns a new map of the same (hashed/sorted) type, - that does not contain a mapping for key(s)." - ([map] map) - ([map key] - (. clojure.lang.RT (dissoc map key))) - ([map key & ks] - (let [ret (dissoc map key)] - (if ks - (recur ret (first ks) (next ks)) - ret)))) - -(defn disj - "disj[oin]. Returns a new set of the same (hashed/sorted) type, that - does not contain key(s)." - ([set] set) - ([#^clojure.lang.IPersistentSet set key] - (. set (disjoin key))) - ([set key & ks] - (let [ret (disj set key)] - (if ks - (recur ret (first ks) (next ks)) - ret)))) - -(defn find - "Returns the map entry for key, or nil if key not present." - [map key] (. clojure.lang.RT (find map key))) - -(defn select-keys - "Returns a map containing only those entries in map whose key is in keys" - [map keyseq] - (loop [ret {} keys (seq keyseq)] - (if keys - (let [entry (. clojure.lang.RT (find map (first keys)))] - (recur - (if entry - (conj ret entry) - ret) - (next keys))) - ret))) - -(defn keys - "Returns a sequence of the map's keys." - [map] (. clojure.lang.RT (keys map))) - -(defn vals - "Returns a sequence of the map's values." - [map] (. clojure.lang.RT (vals map))) - -(defn key - "Returns the key of the map entry." - [#^java.util.Map$Entry e] - (. e (getKey))) - -(defn val - "Returns the value in the map entry." - [#^java.util.Map$Entry e] - (. e (getValue))) - -(defn rseq - "Returns, in constant time, a seq of the items in rev (which - can be a vector or sorted-map), in reverse order. If rev is empty returns nil" - [#^clojure.lang.Reversible rev] - (. rev (rseq))) - -(defn name - "Returns the name String of a symbol or keyword." - {:tag String} - [#^clojure.lang.Named x] - (. x (getName))) - -(defn namespace - "Returns the namespace String of a symbol or keyword, or nil if not present." - {:tag String} - [#^clojure.lang.Named x] - (. x (getNamespace))) - -(defmacro locking - "Executes exprs in an implicit do, while holding the monitor of x. - Will release the monitor of x in all circumstances." - [x & body] - `(let [lockee# ~x] - (try - (monitor-enter lockee#) - ~@body - (finally - (monitor-exit lockee#))))) - -(defmacro .. - "form => fieldName-symbol or (instanceMethodName-symbol args*) - - Expands into a member access (.) of the first member on the first - argument, followed by the next member on the result, etc. For - instance: - - (.. System (getProperties) (get \"os.name\")) - - expands to: - - (. (. System (getProperties)) (get \"os.name\")) - - but is easier to write, read, and understand." - ([x form] `(. ~x ~form)) - ([x form & more] `(.. (. ~x ~form) ~@more))) - -(defmacro -> - "Threads the expr through the forms. Inserts x as the - 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 form] (if (seq? form) - `(~(first form) ~x ~@(next form)) - (list form x))) - ([x form & more] `(-> (-> ~x ~form) ~@more))) - -;;multimethods -(def global-hierarchy) - -(defmacro defmulti - "Creates a new multimethod with the associated dispatch function. - The docstring and attribute-map are optional. - - Options are key-value pairs and may be one of: - :default the default dispatch value, defaults to :default - :hierarchy the isa? hierarchy to use for dispatching - defaults to the global hierarchy" - {:arglists '([name docstring? attr-map? dispatch-fn & options])} - [mm-name & options] - (let [docstring (if (string? (first options)) - (first options) - nil) - options (if (string? (first options)) - (next options) - options) - m (if (map? (first options)) - (first options) - {}) - options (if (map? (first options)) - (next options) - options) - dispatch-fn (first options) - options (next options) - m (assoc m :tag 'clojure.lang.MultiFn) - m (if docstring - (assoc m :doc docstring) - m) - m (if (meta mm-name) - (conj (meta mm-name) m) - m)] - (when (= (count options) 1) - (throw (Exception. "The syntax for defmulti has changed. Example: (defmulti name dispatch-fn :default dispatch-value)"))) - (let [options (apply hash-map options) - default (get options :default :default) - hierarchy (get options :hierarchy #'global-hierarchy)] - `(def ~(with-meta mm-name m) - (new clojure.lang.MultiFn ~(name mm-name) ~dispatch-fn ~default ~hierarchy))))) - -(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))) - -(defn remove-method - "Removes the method of multimethod associated with dispatch-value." - [#^clojure.lang.MultiFn multifn dispatch-val] - (. multifn removeMethod dispatch-val)) - -(defn prefer-method - "Causes the multimethod to prefer matches of dispatch-val-x over dispatch-val-y when there is a conflict" - [#^clojure.lang.MultiFn multifn dispatch-val-x dispatch-val-y] - (. multifn preferMethod dispatch-val-x dispatch-val-y)) - -(defn methods - "Given a multimethod, returns a map of dispatch values -> dispatch fns" - [#^clojure.lang.MultiFn multifn] (.getMethodTable multifn)) - -(defn get-method - "Given a multimethod and a dispatch value, returns the dispatch fn - that would apply to that value, or nil if none apply and no default" - [#^clojure.lang.MultiFn multifn dispatch-val] (.getMethod multifn dispatch-val)) - -(defn prefers - "Given a multimethod, returns a map of preferred value -> set of other values" - [#^clojure.lang.MultiFn multifn] (.getPreferTable multifn)) - -;;;;;;;;; var stuff - -(defmacro #^{:private true} assert-args [fnname & pairs] - `(do (when-not ~(first pairs) - (throw (IllegalArgumentException. - ~(str fnname " requires " (second pairs))))) - ~(let [more (nnext pairs)] - (when more - (list* `assert-args fnname more))))) - -(defmacro if-let - "bindings => binding-form test - - If test is true, evaluates then with binding-form bound to the value of test, if not, yields else" - ([bindings then] - `(if-let ~bindings ~then nil)) - ([bindings then else & oldform] - (assert-args if-let - (and (vector? bindings) (nil? oldform)) "a vector for its binding" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [form (bindings 0) tst (bindings 1)] - `(let [temp# ~tst] - (if temp# - (let [~form temp#] - ~then) - ~else))))) - -(defmacro when-let - "bindings => binding-form test - - When test is true, evaluates body with binding-form bound to the value of test" - [bindings & body] - (assert-args when-let - (vector? bindings) "a vector for its binding" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [form (bindings 0) tst (bindings 1)] - `(let [temp# ~tst] - (when temp# - (let [~form temp#] - ~@body))))) - -(defmacro binding - "binding => var-symbol init-expr - - Creates new bindings for the (already-existing) vars, with the - supplied initial values, executes the exprs in an implicit do, then - re-establishes the bindings that existed before." - [bindings & body] - (assert-args binding - (vector? bindings) "a vector for its binding" - (even? (count bindings)) "an even number of forms in binding vector") - (let [var-ize (fn [var-vals] - (loop [ret [] vvs (seq var-vals)] - (if vvs - (recur (conj (conj ret `(var ~(first vvs))) (second vvs)) - (next (next vvs))) - (seq ret))))] - `(do - (. clojure.lang.Var (pushThreadBindings (hash-map ~@(var-ize bindings)))) - (try - ~@body - (finally - (. clojure.lang.Var (popThreadBindings))))))) - -(defn find-var - "Returns the global var named by the namespace-qualified symbol, or - nil if no var with that name." - [sym] (. clojure.lang.Var (find sym))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Refs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defn #^{:private true} - setup-reference [#^clojure.lang.ARef r options] - (let [opts (apply hash-map options)] - (when (:meta opts) - (.resetMeta r (:meta opts))) - (when (:validator opts) - (.setValidator r (:validator opts))) - r)) - -(defn agent - "Creates and returns an agent with an initial value of state and - zero or more options (in any order): - - :meta metadata-map - - :validator validate-fn - - If metadata-map is supplied, it will be come the metadata on the - agent. validate-fn must be nil or a side-effect-free fn of one - argument, which will be passed the intended new state on any state - change. If the new state is unacceptable, the validate-fn should - return false or throw an exception." - ([state] (new clojure.lang.Agent state)) - ([state & options] - (setup-reference (agent state) options))) - -(defn send - "Dispatch an action to an agent. Returns the agent immediately. - Subsequently, in a thread from a thread pool, the state of the agent - will be set to the value of: - - (apply action-fn state-of-agent args)" - [#^clojure.lang.Agent a f & args] - (. a (dispatch f args false))) - -(defn send-off - "Dispatch a potentially blocking action to an agent. Returns the - agent immediately. Subsequently, in a separate thread, the state of - the agent will be set to the value of: - - (apply action-fn state-of-agent args)" - [#^clojure.lang.Agent a f & args] - (. a (dispatch f args true))) - -(defn release-pending-sends - "Normally, actions sent directly or indirectly during another action - are held until the action completes (changes the agent's - state). This function can be used to dispatch any pending sent - actions immediately. This has no impact on actions sent during a - transaction, which are still held until commit. If no action is - occurring, does nothing. Returns the number of actions dispatched." - [] (clojure.lang.Agent/releasePendingSends)) - -(defn add-watch - "Experimental. - Adds a watch function to an agent/atom/var/ref reference. The watch - fn must be a fn of 4 args: a key, the reference, its old-state, its - new-state. Whenever the reference's state might have been changed, - any registered watches will have their functions called. The watch fn - will be called synchronously, on the agent's thread if an agent, - before any pending sends if agent or ref. Note that an atom's or - ref's state may have changed again prior to the fn call, so use - old/new-state rather than derefing the reference. Note also that watch - fns may be called from multiple threads simultaneously. Var watchers - are triggered only by root binding changes, not thread-local - set!s. Keys must be unique per reference, and can be used to remove - the watch with remove-watch, but are otherwise considered opaque by - the watch mechanism." - [#^clojure.lang.IRef reference key fn] (.addWatch reference key fn)) - -(defn remove-watch - "Experimental. - Removes a watch (set by add-watch) from a reference" - [#^clojure.lang.IRef reference key] - (.removeWatch reference key)) - -(defn add-watcher - "Experimental. - Adds a watcher to an agent/atom/var/ref reference. The watcher must - be an Agent, and the action a function of the agent's state and one - additional arg, the reference. Whenever the reference's state - changes, any registered watchers will have their actions - sent. send-type must be one of :send or :send-off. The actions will - be sent after the reference's state is changed. Var watchers are - triggered only by root binding changes, not thread-local set!s" - [#^clojure.lang.IRef reference send-type watcher-agent action-fn] - (add-watch reference watcher-agent - (fn [watcher-agent reference old-state new-state] - (when-not (identical? old-state new-state) - ((if (= send-type :send-off) send-off send) - watcher-agent action-fn reference))))) - -(defn remove-watcher - "Experimental. - Removes a watcher (set by add-watcher) from a reference" - [reference watcher-agent] - (remove-watch reference watcher-agent)) - -(defn agent-errors - "Returns a sequence of the exceptions thrown during asynchronous - actions of the agent." - [#^clojure.lang.Agent a] (. a (getErrors))) - -(defn clear-agent-errors - "Clears any exceptions thrown during asynchronous actions of the - agent, allowing subsequent actions to occur." - [#^clojure.lang.Agent a] (. a (clearErrors))) - -(defn shutdown-agents - "Initiates a shutdown of the thread pools that back the agent - system. Running actions will complete, but no new actions will be - accepted" - [] (. clojure.lang.Agent shutdown)) - -(defn ref - "Creates and returns a Ref with an initial value of x and zero or - more options (in any order): - - :meta metadata-map - - :validator validate-fn - - If metadata-map is supplied, it will be come the metadata on the - ref. validate-fn must be nil or a side-effect-free fn of one - argument, which will be passed the intended new state on any state - change. If the new state is unacceptable, the validate-fn should - return false or throw an exception. validate-fn will be called on - transaction commit, when all refs have their final values." - ([x] (new clojure.lang.Ref x)) - ([x & options] (setup-reference (ref x) options))) - -(defn deref - "Also reader macro: @ref/@agent/@var/@atom/@delay/@future. Within a transaction, - returns the in-transaction-value of ref, else returns the - most-recently-committed value of ref. When applied to a var, agent - or atom, returns its current state. When applied to a delay, forces - it if not already forced. When applied to a future, will block if - computation not complete" - [#^clojure.lang.IDeref ref] (.deref ref)) - -(defn atom - "Creates and returns an Atom with an initial value of x and zero or - more options (in any order): - - :meta metadata-map - - :validator validate-fn - - If metadata-map is supplied, it will be come the metadata on the - atom. validate-fn must be nil or a side-effect-free fn of one - argument, which will be passed the intended new state on any state - change. If the new state is unacceptable, the validate-fn should - return false or throw an exception." - ([x] (new clojure.lang.Atom x)) - ([x & options] (setup-reference (atom x) options))) - -(defn swap! - "Atomically swaps the value of atom to be: - (apply f current-value-of-atom args). Note that f may be called - multiple times, and thus should be free of side effects. Returns - the value that was swapped in." - ([#^clojure.lang.Atom atom f] (.swap atom f)) - ([#^clojure.lang.Atom atom f x] (.swap atom f x)) - ([#^clojure.lang.Atom atom f x y] (.swap atom f x y)) - ([#^clojure.lang.Atom atom f x y & args] (.swap atom f x y args))) - -(defn compare-and-set! - "Atomically sets the value of atom to newval if and only if the - current value of the atom is identical to oldval. Returns true if - set happened, else false" - [#^clojure.lang.Atom atom oldval newval] (.compareAndSet atom oldval newval)) - -(defn reset! - "Sets the value of atom to newval without regard for the - current value. Returns newval." - [#^clojure.lang.Atom atom newval] (.reset atom newval)) - -(defn set-validator! - "Sets the validator-fn for a var/ref/agent/atom. validator-fn must be nil or a - side-effect-free fn of one argument, which will be passed the intended - new state on any state change. If the new state is unacceptable, the - validator-fn should return false or throw an exception. If the current state (root - value if var) is not acceptable to the new validator, an exception - will be thrown and the validator will not be changed." - [#^clojure.lang.IRef iref validator-fn] (. iref (setValidator validator-fn))) - -(defn get-validator - "Gets the validator-fn for a var/ref/agent/atom." - [#^clojure.lang.IRef iref] (. iref (getValidator))) - -(defn alter-meta! - "Atomically sets the metadata for a namespace/var/ref/agent/atom to be: - - (apply f its-current-meta args) - - f must be free of side-effects" - [#^clojure.lang.IReference iref f & args] (.alterMeta iref f args)) - -(defn reset-meta! - "Atomically resets the metadata for a namespace/var/ref/agent/atom" - [#^clojure.lang.IReference iref metadata-map] (.resetMeta iref metadata-map)) - -(defn commute - "Must be called in a transaction. Sets the in-transaction-value of - ref to: - - (apply fun in-transaction-value-of-ref args) - - and returns the in-transaction-value of ref. - - At the commit point of the transaction, sets the value of ref to be: - - (apply fun most-recently-committed-value-of-ref args) - - Thus fun should be commutative, or, failing that, you must accept - last-one-in-wins behavior. commute allows for more concurrency than - ref-set." - - [#^clojure.lang.Ref ref fun & args] - (. ref (commute fun args))) - -(defn alter - "Must be called in a transaction. Sets the in-transaction-value of - ref to: - - (apply fun in-transaction-value-of-ref args) - - and returns the in-transaction-value of ref." - [#^clojure.lang.Ref ref fun & args] - (. ref (alter fun args))) - -(defn ref-set - "Must be called in a transaction. Sets the value of ref. - Returns val." - [#^clojure.lang.Ref ref val] - (. ref (set val))) - -(defn ensure - "Must be called in a transaction. Protects the ref from modification - by other transactions. Returns the in-transaction-value of - ref. Allows for more concurrency than (ref-set ref @ref)" - [#^clojure.lang.Ref ref] - (. ref (touch)) - (. ref (deref))) - -(defmacro sync - "transaction-flags => TBD, pass nil for now - - Runs the exprs (in an implicit do) in a transaction that encompasses - exprs and any nested calls. Starts a transaction if none is already - running on this thread. Any uncaught exception will abort the - transaction and flow out of sync. The exprs may be run more than - once, but any effects on Refs will be atomic." - [flags-ignored-for-now & body] - `(. clojure.lang.LockingTransaction - (runInTransaction (fn [] ~@body)))) - - -(defmacro io! - "If an io! block occurs in a transaction, throws an - IllegalStateException, else runs body in an implicit do. If the - first expression in body is a literal string, will use that as the - exception message." - [& body] - (let [message (when (string? (first body)) (first body)) - body (if message (next body) body)] - `(if (clojure.lang.LockingTransaction/isRunning) - (throw (new IllegalStateException ~(or message "I/O in transaction"))) - (do ~@body)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; fn stuff ;;;;;;;;;;;;;;;; - - -(defn comp - "Takes a set of functions and returns a fn that is the composition - of those fns. The returned fn takes a variable number of args, - applies the rightmost of fns to the args, the next - fn (right-to-left) to the result, etc." - [& fs] - (let [fs (reverse fs)] - (fn [& args] - (loop [ret (apply (first fs) args) fs (next fs)] - (if fs - (recur ((first fs) ret) (next fs)) - ret))))) - -(defn partial - "Takes a function f and fewer than the normal arguments to f, and - returns a fn that takes a variable number of additional args. When - called, the returned function calls f with args + additional args." - ([f arg1] - (fn [& args] (apply f arg1 args))) - ([f arg1 arg2] - (fn [& args] (apply f arg1 arg2 args))) - ([f arg1 arg2 arg3] - (fn [& args] (apply f arg1 arg2 arg3 args))) - ([f arg1 arg2 arg3 & more] - (fn [& args] (apply f arg1 arg2 arg3 (concat more args))))) - -;;;;;;;;;;;;;;;;;;; sequence fns ;;;;;;;;;;;;;;;;;;;;;;; -(defn stream? - "Returns true if x is an instance of Stream" - [x] (instance? clojure.lang.Stream x)) - - -(defn sequence - "Coerces coll to a (possibly empty) sequence, if it is not already - one. Will not force a lazy seq. (sequence nil) yields ()" - [coll] - (cond - (seq? coll) coll - (stream? coll) (.sequence #^clojure.lang.Stream coll) - :else (or (seq coll) ()))) - -(defn every? - "Returns true if (pred x) is logical true for every x in coll, else - false." - {:tag Boolean} - [pred coll] - (if (seq coll) - (and (pred (first coll)) - (recur pred (next coll))) - true)) - -(def - #^{:tag Boolean - :doc "Returns false if (pred x) is logical true for every x in - coll, else true." - :arglists '([pred coll])} - not-every? (comp not every?)) - -(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: - (some #{:fred} coll)" - [pred coll] - (when (seq coll) - (or (pred (first coll)) (recur pred (next coll))))) - -(def - #^{:tag Boolean - :doc "Returns false if (pred x) is logical true for any x in coll, - else true." - :arglists '([pred coll])} - not-any? (comp not some)) - -(defn map - "Returns a lazy sequence consisting of the result of applying f to the - set of first items of each coll, followed by applying f to the set - of second items in each coll, until any one of the colls is - exhausted. Any remaining items in other colls are ignored. Function - f should accept number-of-colls arguments." - ([f coll] - (lazy-seq - (when-let [s (seq coll)] - (cons (f (first s)) (map f (rest s)))))) - ([f c1 c2] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2)] - (when (and s1 s2) - (cons (f (first s1) (first s2)) - (map f (rest s1) (rest s2))))))) - ([f c1 c2 c3] - (lazy-seq - (let [s1 (seq c1) s2 (seq c2) s3 (seq c3)] - (when (and s1 s2 s3) - (cons (f (first s1) (first s2) (first s3)) - (map f (rest s1) (rest s2) (rest s3))))))) - ([f c1 c2 c3 & colls] - (let [step (fn step [cs] - (lazy-seq - (let [ss (map seq cs)] - (when (every? identity ss) - (cons (map first ss) (step (map rest ss)))))))] - (map #(apply f %) (step (conj colls c3 c2 c1)))))) - -(defn mapcat - "Returns the result of applying concat to the result of applying map - to f and colls. Thus function f should return a collection." - [f & colls] - (apply concat (apply map f colls))) - -(defn filter - "Returns a lazy sequence of the items in coll for which - (pred item) returns true. pred must be free of side-effects." - [pred coll] - (let [step (fn [p c] - (when-let [s (seq c)] - (if (p (first s)) - (cons (first s) (filter p (rest s))) - (recur p (rest s)))))] - (lazy-seq (step pred coll)))) - - -(defn remove - "Returns a lazy sequence of the items in coll for which - (pred item) returns false. pred must be free of side-effects." - [pred coll] - (filter (complement pred) coll)) - -(defn take - "Returns a lazy sequence of the first n items in coll, or all items if - there are fewer than n." - [n coll] - (lazy-seq - (when (pos? n) - (when-let [s (seq coll)] - (cons (first s) (take (dec n) (rest s))))))) - -(defn take-while - "Returns a lazy sequence of successive items from coll while - (pred item) returns true. pred must be free of side-effects." - [pred coll] - (lazy-seq - (when-let [s (seq coll)] - (when (pred (first s)) - (cons (first s) (take-while pred (rest s))))))) - -(defn drop - "Returns a lazy sequence of all but the first n items in coll." - [n coll] - (let [step (fn [n coll] - (let [s (seq coll)] - (if (and (pos? n) s) - (recur (dec n) (rest s)) - s)))] - (lazy-seq (step n coll)))) - -(defn drop-last - "Return a lazy sequence of all but the last n (default 1) items in coll" - ([s] (drop-last 1 s)) - ([n s] (map (fn [x _] x) s (drop n s)))) - -(defn drop-while - "Returns a lazy sequence of the items in coll starting from the first - item for which (pred item) returns nil." - [pred coll] - (let [step (fn [pred coll] - (let [s (seq coll)] - (if (and s (pred (first s))) - (recur pred (rest s)) - s)))] - (lazy-seq (step pred coll)))) - -(defn cycle - "Returns a lazy (infinite!) sequence of repetitions of the items in coll." - [coll] (lazy-seq - (when-let [s (seq coll)] - (concat s (cycle s))))) - -(defn split-at - "Returns a vector of [(take n coll) (drop n coll)]" - [n coll] - [(take n coll) (drop n coll)]) - -(defn split-with - "Returns a vector of [(take-while pred coll) (drop-while pred coll)]" - [pred coll] - [(take-while pred coll) (drop-while pred coll)]) - -(defn repeat - "Returns a lazy (infinite!, or length n if supplied) sequence of xs." - ([x] (lazy-seq (cons x (repeat x)))) - ([n x] (take n (repeat x)))) - -(defn replicate - "Returns a lazy seq of n xs." - [n x] (take n (repeat x))) - -(defn iterate - "Returns a lazy sequence of x, (f x), (f (f x)) etc. f must be free of side-effects" - [f x] (cons x (lazy-seq (iterate f (f x))))) - -(defn range - "Returns a lazy seq of nums from start (inclusive) to end - (exclusive), by step, where start defaults to 0 and step to 1." - ([end] (if (and (> end 0) (<= end (. Integer MAX_VALUE))) - (new clojure.lang.Range 0 end) - (take end (iterate inc 0)))) - ([start end] (if (and (< start end) - (>= start (. Integer MIN_VALUE)) - (<= end (. Integer MAX_VALUE))) - (new clojure.lang.Range start end) - (take (- end start) (iterate inc start)))) - ([start end step] - (take-while (partial (if (pos? step) > <) end) (iterate (partial + step) start)))) - -(defn merge - "Returns a map that consists of the rest of the maps conj-ed onto - the first. If a key occurs in more than one map, the mapping from - the latter (left-to-right) will be the mapping in the result." - [& maps] - (when (some identity maps) - (reduce #(conj (or %1 {}) %2) maps))) - -(defn merge-with - "Returns a map that consists of the rest of the maps conj-ed onto - the first. If a key occurs in more than one map, the mapping(s) - from the latter (left-to-right) will be combined with the mapping in - the result by calling (f val-in-result val-in-latter)." - [f & maps] - (when (some identity maps) - (let [merge-entry (fn [m e] - (let [k (key e) v (val e)] - (if (contains? m k) - (assoc m k (f (m k) v)) - (assoc m k v)))) - merge2 (fn [m1 m2] - (reduce merge-entry (or m1 {}) (seq m2)))] - (reduce merge2 maps)))) - - - -(defn zipmap - "Returns a map with the keys mapped to the corresponding vals." - [keys vals] - (loop [map {} - ks (seq keys) - vs (seq vals)] - (if (and ks vs) - (recur (assoc map (first ks) (first vs)) - (next ks) - (next vs)) - map))) - -(defn line-seq - "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)))))) - -(defn comparator - "Returns an implementation of java.util.Comparator based upon pred." - [pred] - (fn [x y] - (cond (pred x y) -1 (pred y x) 1 :else 0))) - -(defn sort - "Returns a sorted sequence of the items in coll. If no comparator is - supplied, uses compare. comparator must - implement java.util.Comparator." - ([coll] - (sort compare coll)) - ([#^java.util.Comparator comp coll] - (if (seq coll) - (let [a (to-array coll)] - (. java.util.Arrays (sort a comp)) - (seq a)) - ()))) - -(defn sort-by - "Returns a sorted sequence of the items in coll, where the sort - order is determined by comparing (keyfn item). If no comparator is - supplied, uses compare. comparator must - implement java.util.Comparator." - ([keyfn coll] - (sort-by keyfn compare coll)) - ([keyfn #^java.util.Comparator comp coll] - (sort (fn [x y] (. comp (compare (keyfn x) (keyfn y)))) coll))) - -(defn partition - "Returns a lazy sequence of lists of n items each, at offsets step - apart. If step is not supplied, defaults to n, i.e. the partitions - do not overlap." - ([n coll] - (partition n n coll)) - ([n step coll] - (lazy-seq - (when-let [s (seq coll)] - (let [p (take n s)] - (when (= n (count p)) - (cons p (partition n step (drop step s))))))))) - -;; evaluation - -(defn eval - "Evaluates the form data structure (not text!) and returns the result." - [form] (. clojure.lang.Compiler (eval form))) - -(defmacro doseq - "Repeatedly executes body (presumably for side-effects) with - bindings and filtering as provided by \"for\". Does not retain - the head of the sequence. Returns nil." - [seq-exprs & body] - (assert-args doseq - (vector? seq-exprs) "a vector for its binding" - (even? (count seq-exprs)) "an even number of forms in binding vector") - (let [step (fn step [recform exprs] - (if-not exprs - [true `(do ~@body)] - (let [k (first exprs) - v (second exprs) - seqsym (when-not (keyword? k) (gensym)) - recform (if (keyword? k) recform `(recur (next ~seqsym))) - steppair (step recform (nnext exprs)) - needrec (steppair 0) - subform (steppair 1)] - (cond - (= k :let) [needrec `(let ~v ~subform)] - (= k :while) [false `(when ~v - ~subform - ~@(when needrec [recform]))] - (= k :when) [false `(if ~v - (do - ~subform - ~@(when needrec [recform])) - ~recform)] - :else [true `(loop [~seqsym (seq ~v)] - (when ~seqsym - (let [~k (first ~seqsym)] - ~subform - ~@(when needrec [recform]))))]))))] - (nth (step nil (seq seq-exprs)) 1))) - -(defn dorun - "When lazy sequences are produced via functions that have side - effects, any effects other than those needed to produce the first - element in the seq do not occur until the seq is consumed. dorun can - be used to force any effects. Walks through the successive nexts of - the seq, does not retain the head and returns nil." - ([coll] - (when (seq coll) - (recur (next coll)))) - ([n coll] - (when (and (seq coll) (pos? n)) - (recur (dec n) (next coll))))) - -(defn doall - "When lazy sequences are produced via functions that have side - effects, any effects other than those needed to produce the first - element in the seq do not occur until the seq is consumed. doall can - be used to force any effects. Walks through the successive nexts of - the seq, retains the head and returns it, thus causing the entire - seq to reside in memory at one time." - ([coll] - (dorun coll) - coll) - ([n coll] - (dorun n coll) - coll)) - -(defn await - "Blocks the current thread (indefinitely!) until all actions - dispatched thus far, from this thread or agent, to the agent(s) have - occurred." - [& agents] - (io! "await in transaction" - (when *agent* - (throw (new Exception "Can't await in agent action"))) - (let [latch (new java.util.concurrent.CountDownLatch (count agents)) - count-down (fn [agent] (. latch (countDown)) agent)] - (doseq [agent agents] - (send agent count-down)) - (. latch (await))))) - -(defn await1 [#^clojure.lang.Agent a] - (when (pos? (.getQueueCount a)) - (await a)) - a) - -(defn await-for - "Blocks the current thread until all actions dispatched thus - far (from this thread or agent) to the agents have occurred, or the - timeout (in milliseconds) has elapsed. Returns nil if returning due - to timeout, non-nil otherwise." - [timeout-ms & agents] - (io! "await-for in transaction" - (when *agent* - (throw (new Exception "Can't await in agent action"))) - (let [latch (new java.util.concurrent.CountDownLatch (count agents)) - count-down (fn [agent] (. latch (countDown)) agent)] - (doseq [agent agents] - (send agent count-down)) - (. latch (await timeout-ms (. java.util.concurrent.TimeUnit MILLISECONDS)))))) - -(defmacro dotimes - "bindings => name n - - Repeatedly executes body (presumably for side-effects) with name - bound to integers from 0 through n-1." - [bindings & body] - (assert-args dotimes - (vector? bindings) "a vector for its binding" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [i (first bindings) - n (second bindings)] - `(let [n# (int ~n)] - (loop [~i (int 0)] - (when (< ~i n#) - ~@body - (recur (unchecked-inc ~i))))))) - -(defn import - "import-list => (package-symbol class-name-symbols*) - - For each name in class-name-symbols, adds a mapping from name to the - class named by package.name to the current namespace. Use :import in the ns - macro in preference to calling this directly." - [& import-symbols-or-lists] - (let [#^clojure.lang.Namespace ns *ns*] - (doseq [spec import-symbols-or-lists] - (if (symbol? spec) - (let [n (name spec) - dot (.lastIndexOf n (. clojure.lang.RT (intCast \.))) - c (symbol (.substring n (inc dot)))] - (. ns (importClass c (. clojure.lang.RT (classForName (name spec)))))) - (let [pkg (first spec) - classes (next spec)] - (doseq [c classes] - (. ns (importClass c (. clojure.lang.RT (classForName (str pkg "." c))))))))))) - - -(defn into-array - "Returns an array with components set to the values in aseq. The array's - component type is type if provided, or the type of the first value in - aseq if present, or Object. All values in aseq must be compatible with - the component type. Class objects for the primitive types can be obtained - using, e.g., Integer/TYPE." - ([aseq] - (clojure.lang.RT/seqToTypedArray (seq aseq))) - ([type aseq] - (clojure.lang.RT/seqToTypedArray type (seq aseq)))) - -(defn into - "Returns a new coll consisting of to-coll with all of the items of - from-coll conjoined." - [to from] - (let [ret to items (seq from)] - (if items - (recur (conj ret (first items)) (next items)) - ret))) - -(defn #^{:private true} - array [& items] - (into-array items)) - -(defn #^Class class - "Returns the Class of x" - [#^Object x] (if (nil? x) x (. x (getClass)))) - -(defn type - "Returns the :type metadata of x, or its Class if none" - [x] - (or (:type (meta x)) (class x))) - -(defn num - "Coerce to Number" - {:tag Number - :inline (fn [x] `(. clojure.lang.Numbers (num ~x)))} - [x] (. clojure.lang.Numbers (num x))) - -(defn int - "Coerce to int" - {:tag Integer - :inline (fn [x] `(. clojure.lang.RT (intCast ~x)))} - [x] (. clojure.lang.RT (intCast x))) - -(defn long - "Coerce to long" - {:tag Long - :inline (fn [x] `(. clojure.lang.RT (longCast ~x)))} - [#^Number x] (. x (longValue))) - -(defn float - "Coerce to float" - {:tag Float - :inline (fn [x] `(. clojure.lang.RT (floatCast ~x)))} - [#^Number x] (. x (floatValue))) - -(defn double - "Coerce to double" - {:tag Double - :inline (fn [x] `(. clojure.lang.RT (doubleCast ~x)))} - [#^Number x] (. x (doubleValue))) - -(defn short - "Coerce to short" - {:tag Short - :inline (fn [x] `(. clojure.lang.RT (shortCast ~x)))} - [#^Number x] (. x (shortValue))) - -(defn byte - "Coerce to byte" - {:tag Byte - :inline (fn [x] `(. clojure.lang.RT (byteCast ~x)))} - [#^Number x] (. x (byteValue))) - -(defn char - "Coerce to char" - {:tag Character - :inline (fn [x] `(. clojure.lang.RT (charCast ~x)))} - [x] (. clojure.lang.RT (charCast x))) - -(defn boolean - "Coerce to boolean" - {:tag Boolean - :inline (fn [x] `(. clojure.lang.RT (booleanCast ~x)))} - [x] (if x true false)) - -(defn number? - "Returns true if x is a Number" - [x] - (instance? Number x)) - -(defn integer? - "Returns true if n is an integer" - [n] - (or (instance? Integer n) - (instance? Long n) - (instance? BigInteger n) - (instance? Short n) - (instance? Byte n))) - -(defn mod - "Modulus of num and div. Truncates toward negative infinity." - [num div] - (let [m (rem num div)] - (if (or (zero? m) (pos? (* num div))) - m - (+ m div)))) - -(defn ratio? - "Returns true if n is a Ratio" - [n] (instance? clojure.lang.Ratio n)) - -(defn decimal? - "Returns true if n is a BigDecimal" - [n] (instance? BigDecimal n)) - -(defn float? - "Returns true if n is a floating point number" - [n] - (or (instance? Double n) - (instance? Float n))) - -(defn rational? [n] - "Returns true if n is a rational number" - (or (integer? n) (ratio? n) (decimal? n))) - -(defn bigint - "Coerce to BigInteger" - {:tag BigInteger} - [x] (cond - (instance? BigInteger x) x - (decimal? x) (.toBigInteger #^BigDecimal x) - (number? x) (BigInteger/valueOf (long x)) - :else (BigInteger. x))) - -(defn bigdec - "Coerce to BigDecimal" - {:tag BigDecimal} - [x] (cond - (decimal? x) x - (float? x) (. BigDecimal valueOf (double x)) - (ratio? x) (/ (BigDecimal. (.numerator x)) (.denominator x)) - (instance? BigInteger x) (BigDecimal. #^BigInteger x) - (number? x) (BigDecimal/valueOf (long x)) - :else (BigDecimal. x))) - -(def #^{:private true} print-initialized false) - -(defmulti print-method (fn [x writer] (type x))) -(defmulti print-dup (fn [x writer] (class x))) - -(defn pr-on - {:private true} - [x w] - (if *print-dup* - (print-dup x w) - (print-method x w)) - nil) - -(defn pr - "Prints the object(s) to the output stream that is the current value - of *out*. Prints the object(s), separated by spaces if there is - more than one. By default, pr and prn print in a way that objects - can be read by the reader" - ([] nil) - ([x] - (pr-on x *out*)) - ([x & more] - (pr x) - (. *out* (append \space)) - (apply pr more))) - -(defn newline - "Writes a newline to the output stream that is the current value of - *out*" - [] - (. *out* (append \newline)) - nil) - -(defn flush - "Flushes the output stream that is the current value of - *out*" - [] - (. *out* (flush)) - nil) - -(defn prn - "Same as pr followed by (newline). Observes *flush-on-newline*" - [& more] - (apply pr more) - (newline) - (when *flush-on-newline* - (flush))) - -(defn print - "Prints the object(s) to the output stream that is the current value - of *out*. print and println produce output for human consumption." - [& more] - (binding [*print-readably* nil] - (apply pr more))) - -(defn println - "Same as print followed by (newline)" - [& more] - (binding [*print-readably* nil] - (apply prn more))) - - -(defn read - "Reads the next object from stream, which must be an instance of - java.io.PushbackReader or some derivee. stream defaults to the - current value of *in* ." - ([] - (read *in*)) - ([stream] - (read stream true nil)) - ([stream eof-error? eof-value] - (read stream eof-error? eof-value false)) - ([stream eof-error? eof-value recursive?] - (. clojure.lang.LispReader (read stream (boolean eof-error?) eof-value recursive?)))) - -(defn read-line - "Reads the next line from stream that is the current value of *in* ." - [] - (if (instance? clojure.lang.LineNumberingPushbackReader *in*) - (.readLine #^clojure.lang.LineNumberingPushbackReader *in*) - (.readLine #^java.io.BufferedReader *in*))) - -(defn read-string - "Reads one object from the string s" - [s] (clojure.lang.RT/readString s)) - -(defn subvec - "Returns a persistent vector of the items in vector from - start (inclusive) to end (exclusive). If end is not supplied, - defaults to (count vector). This operation is O(1) and very fast, as - the resulting vector shares structure with the original and no - trimming is done." - ([v start] - (subvec v start (count v))) - ([v start end] - (. clojure.lang.RT (subvec v start end)))) - -(defmacro with-open - "bindings => [name init ...] - - Evaluates body in a try expression with names bound to the values - of the inits, and a finally clause that calls (.close name) on each - name in reverse order." - [bindings & body] - (assert-args with-open - (vector? bindings) "a vector for its binding" - (even? (count bindings)) "an even number of forms in binding vector") - (cond - (= (count bindings) 0) `(do ~@body) - (symbol? (bindings 0)) `(let ~(subvec bindings 0 2) - (try - (with-open ~(subvec bindings 2) ~@body) - (finally - (. ~(bindings 0) close)))) - :else (throw (IllegalArgumentException. - "with-open only allows Symbols in bindings")))) - -(defmacro doto - "Evaluates x then calls all of the methods and functions with the - value of x supplied at the from of the given arguments. The forms - are evaluated in order. Returns x. - - (doto (new java.util.HashMap) (.put \"a\" 1) (.put \"b\" 2))" - [x & forms] - (let [gx (gensym)] - `(let [~gx ~x] - ~@(map (fn [f] - (if (seq? f) - `(~(first f) ~gx ~@(next f)) - `(~f ~gx))) - forms) - ~gx))) - -(defmacro memfn - "Expands into code that creates a fn that expects to be passed an - object and any args and calls the named instance method on the - object passing the args. Use when you want to treat a Java method as - a first-class fn." - [name & args] - `(fn [target# ~@args] - (. target# (~name ~@args)))) - -(defmacro time - "Evaluates expr and prints the time it took. Returns the value of - expr." - [expr] - `(let [start# (. System (nanoTime)) - ret# ~expr] - (prn (str "Elapsed time: " (/ (double (- (. System (nanoTime)) start#)) 1000000.0) " msecs")) - ret#)) - - - -(import '(java.lang.reflect Array)) - -(defn alength - "Returns the length of the Java array. Works on arrays of all - types." - {:inline (fn [a] `(. clojure.lang.RT (alength ~a)))} - [array] (. clojure.lang.RT (alength array))) - -(defn aclone - "Returns a clone of the Java array. Works on arrays of known - types." - {:inline (fn [a] `(. clojure.lang.RT (aclone ~a)))} - [array] (. clojure.lang.RT (aclone array))) - -(defn aget - "Returns the value at the index/indices. Works on Java arrays of all - types." - {:inline (fn [a i] `(. clojure.lang.RT (aget ~a ~i))) - :inline-arities #{2}} - ([array idx] - (clojure.lang.Reflector/prepRet (. Array (get array idx)))) - ([array idx & idxs] - (apply aget (aget array idx) idxs))) - -(defn aset - "Sets the value at the index/indices. Works on Java arrays of - reference types. Returns val." - {:inline (fn [a i v] `(. clojure.lang.RT (aset ~a ~i ~v))) - :inline-arities #{3}} - ([array idx val] - (. Array (set array idx val)) - val) - ([array idx idx2 & idxv] - (apply aset (aget array idx) idx2 idxv))) - -(defmacro - #^{:private true} - def-aset [name method coerce] - `(defn ~name - {:arglists '([~'array ~'idx ~'val] [~'array ~'idx ~'idx2 & ~'idxv])} - ([array# idx# val#] - (. Array (~method array# idx# (~coerce val#))) - val#) - ([array# idx# idx2# & idxv#] - (apply ~name (aget array# idx#) idx2# idxv#)))) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of int. Returns val."} - aset-int setInt int) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of long. Returns val."} - aset-long setLong long) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of boolean. Returns val."} - aset-boolean setBoolean boolean) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of float. Returns val."} - aset-float setFloat float) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of double. Returns val."} - aset-double setDouble double) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of short. Returns val."} - aset-short setShort short) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of byte. Returns val."} - aset-byte setByte byte) - -(def-aset - #^{:doc "Sets the value at the index/indices. Works on arrays of char. Returns val."} - aset-char setChar char) - -(defn make-array - "Creates and returns an array of instances of the specified class of - the specified dimension(s). Note that a class object is required. - Class objects can be obtained by using their imported or - fully-qualified name. Class objects for the primitive types can be - obtained using, e.g., Integer/TYPE." - ([#^Class type len] - (. Array (newInstance type (int len)))) - ([#^Class type dim & more-dims] - (let [dims (cons dim more-dims) - #^"[I" dimarray (make-array (. Integer TYPE) (count dims))] - (dotimes [i (alength dimarray)] - (aset-int dimarray i (nth dims i))) - (. Array (newInstance type dimarray))))) - -(defn to-array-2d - "Returns a (potentially-ragged) 2-dimensional array of Objects - containing the contents of coll, which can be any Collection of any - Collection." - {:tag "[[Ljava.lang.Object;"} - [#^java.util.Collection coll] - (let [ret (make-array (. Class (forName "[Ljava.lang.Object;")) (. coll (size)))] - (loop [i 0 xs (seq coll)] - (when xs - (aset ret i (to-array (first xs))) - (recur (inc i) (next xs)))) - ret)) - -(defn macroexpand-1 - "If form represents a macro form, returns its expansion, - else returns form." - [form] - (. clojure.lang.Compiler (macroexpand1 form))) - -(defn macroexpand - "Repeatedly calls macroexpand-1 on form until it no longer - represents a macro form, then returns it. Note neither - macroexpand-1 nor macroexpand expand macros in subforms." - [form] - (let [ex (macroexpand-1 form)] - (if (identical? ex form) - form - (macroexpand ex)))) - -(defn create-struct - "Returns a structure basis object." - [& keys] - (. clojure.lang.PersistentStructMap (createSlotMap keys))) - -(defmacro defstruct - "Same as (def name (create-struct keys...))" - [name & keys] - `(def ~name (create-struct ~@keys))) - -(defn struct-map - "Returns a new structmap instance with the keys of the - structure-basis. keyvals may contain all, some or none of the basis - keys - where values are not supplied they will default to nil. - keyvals can also contain keys not in the basis." - [s & inits] - (. clojure.lang.PersistentStructMap (create s inits))) - -(defn struct - "Returns a new structmap instance with the keys of the - structure-basis. vals must be supplied for basis keys in order - - where values are not supplied they will default to nil." - [s & vals] - (. clojure.lang.PersistentStructMap (construct s vals))) - -(defn accessor - "Returns a fn that, given an instance of a structmap with the basis, - returns the value at the key. The key must be in the basis. The - returned function should be (slightly) more efficient than using - get, but such use of accessors should be limited to known - performance-critical areas." - [s key] - (. clojure.lang.PersistentStructMap (getAccessor s key))) - -(defn load-reader - "Sequentially read and evaluate the set of forms contained in the - stream/file" - [rdr] (. clojure.lang.Compiler (load rdr))) - -(defn load-string - "Sequentially read and evaluate the set of forms contained in the - string" - [s] - (let [rdr (-> (java.io.StringReader. s) - (clojure.lang.LineNumberingPushbackReader.))] - (load-reader rdr))) - -(defn set - "Returns a set of the distinct elements of coll." - [coll] (apply hash-set coll)) - -(defn #^{:private true} - filter-key [keyfn pred amap] - (loop [ret {} es (seq amap)] - (if es - (if (pred (keyfn (first es))) - (recur (assoc ret (key (first es)) (val (first es))) (next es)) - (recur ret (next es))) - ret))) - -(defn find-ns - "Returns the namespace named by the symbol or nil if it doesn't exist." - [sym] (clojure.lang.Namespace/find sym)) - -(defn create-ns - "Create a new namespace named by the symbol if one doesn't already - exist, returns it or the already-existing namespace of the same - name." - [sym] (clojure.lang.Namespace/findOrCreate sym)) - -(defn remove-ns - "Removes the namespace named by the symbol. Use with caution. - Cannot be used to remove the clojure namespace." - [sym] (clojure.lang.Namespace/remove sym)) - -(defn all-ns - "Returns a sequence of all namespaces." - [] (clojure.lang.Namespace/all)) - -(defn #^clojure.lang.Namespace the-ns - "If passed a namespace, returns it. Else, when passed a symbol, - returns the namespace named by it, throwing an exception if not - found." - [x] - (if (instance? clojure.lang.Namespace x) - x - (or (find-ns x) (throw (Exception. (str "No namespace: " x " found")))))) - -(defn ns-name - "Returns the name of the namespace, a symbol." - [ns] - (.getName (the-ns ns))) - -(defn ns-map - "Returns a map of all the mappings for the namespace." - [ns] - (.getMappings (the-ns ns))) - -(defn ns-unmap - "Removes the mappings for the symbol from the namespace." - [ns sym] - (.unmap (the-ns ns) sym)) - -;(defn export [syms] -; (doseq [sym syms] -; (.. *ns* (intern sym) (setExported true)))) - -(defn ns-publics - "Returns a map of the public intern mappings for the namespace." - [ns] - (let [ns (the-ns ns)] - (filter-key val (fn [#^clojure.lang.Var v] (and (instance? clojure.lang.Var v) - (= ns (.ns v)) - (.isPublic v))) - (ns-map ns)))) - -(defn ns-imports - "Returns a map of the import mappings for the namespace." - [ns] - (filter-key val (partial instance? Class) (ns-map ns))) - -(defn refer - "refers to all public vars of ns, subject to filters. - filters can include at most one each of: - - :exclude list-of-symbols - :only list-of-symbols - :rename map-of-fromsymbol-tosymbol - - For each public interned var in the namespace named by the symbol, - adds a mapping from the name of the var to the var to the current - namespace. Throws an exception if name is already mapped to - something else in the current namespace. Filters can be used to - select a subset, via inclusion or exclusion, or to provide a mapping - to a symbol different from the var's name, in order to prevent - clashes. Use :use in the ns macro in preference to calling this directly." - [ns-sym & filters] - (let [ns (or (find-ns ns-sym) (throw (new Exception (str "No namespace: " ns-sym)))) - fs (apply hash-map filters) - nspublics (ns-publics ns) - rename (or (:rename fs) {}) - exclude (set (:exclude fs)) - to-do (or (:only fs) (keys nspublics))] - (doseq [sym to-do] - (when-not (exclude sym) - (let [v (nspublics sym)] - (when-not v - (throw (new java.lang.IllegalAccessError (str sym " is not public")))) - (. *ns* (refer (or (rename sym) sym) v))))))) - -(defn ns-refers - "Returns a map of the refer mappings for the namespace." - [ns] - (let [ns (the-ns ns)] - (filter-key val (fn [#^clojure.lang.Var v] (and (instance? clojure.lang.Var v) - (not= ns (.ns v)))) - (ns-map ns)))) - -(defn ns-interns - "Returns a map of the intern mappings for the namespace." - [ns] - (let [ns (the-ns ns)] - (filter-key val (fn [#^clojure.lang.Var v] (and (instance? clojure.lang.Var v) - (= ns (.ns v)))) - (ns-map ns)))) - -(defn alias - "Add an alias in the current namespace to another - namespace. Arguments are two symbols: the alias to be used, and - the symbolic name of the target namespace. Use :as in the ns macro in preference - to calling this directly." - [alias namespace-sym] - (.addAlias *ns* alias (find-ns namespace-sym))) - -(defn ns-aliases - "Returns a map of the aliases for the namespace." - [ns] - (.getAliases (the-ns ns))) - -(defn ns-unalias - "Removes the alias for the symbol from the namespace." - [ns sym] - (.removeAlias (the-ns ns) sym)) - -(defn take-nth - "Returns a lazy seq of every nth item in coll." - [n coll] - (lazy-seq - (when-let [s (seq coll)] - (cons (first s) (take-nth n (drop n s)))))) - -(defn interleave - "Returns a lazy seq of the first item in each coll, then the second - etc." - [& colls] - (apply concat (apply map list colls))) - -(defn var-get - "Gets the value in the var object" - [#^clojure.lang.Var x] (. x (get))) - -(defn var-set - "Sets the value in the var object to val. The var must be - thread-locally bound." - [#^clojure.lang.Var x val] (. x (set val))) - -(defmacro with-local-vars - "varbinding=> symbol init-expr - - Executes the exprs in a context in which the symbols are bound to - vars with per-thread bindings to the init-exprs. The symbols refer - to the var objects themselves, and must be accessed with var-get and - var-set" - [name-vals-vec & body] - (assert-args with-local-vars - (vector? name-vals-vec) "a vector for its binding" - (even? (count name-vals-vec)) "an even number of forms in binding vector") - `(let [~@(interleave (take-nth 2 name-vals-vec) - (repeat '(. clojure.lang.Var (create))))] - (. clojure.lang.Var (pushThreadBindings (hash-map ~@name-vals-vec))) - (try - ~@body - (finally (. clojure.lang.Var (popThreadBindings)))))) - -(defn ns-resolve - "Returns the var or Class to which a symbol will be resolved in the - namespace, else nil. Note that if the symbol is fully qualified, - the var/Class to which it resolves need not be present in the - namespace." - [ns sym] - (clojure.lang.Compiler/maybeResolveIn (the-ns ns) sym)) - -(defn resolve - "same as (ns-resolve *ns* symbol)" - [sym] (ns-resolve *ns* sym)) - -(defn array-map - "Constructs an array-map." - ([] (. clojure.lang.PersistentArrayMap EMPTY)) - ([& keyvals] (new clojure.lang.PersistentArrayMap (to-array keyvals)))) - -(defn nthnext - "Returns the nth next of coll, (seq coll) when n is 0." - [coll n] - (loop [n n xs (seq coll)] - (if (and xs (pos? n)) - (recur (dec n) (next xs)) - xs))) - - -;redefine let and loop with destructuring -(defn destructure [bindings] - (let [bmap (apply array-map bindings) - pb (fn pb [bvec b v] - (let [pvec - (fn [bvec b val] - (let [gvec (gensym "vec__")] - (loop [ret (-> bvec (conj gvec) (conj val)) - n 0 - bs b - seen-rest? false] - (if (seq bs) - (let [firstb (first bs)] - (cond - (= firstb '&) (recur (pb ret (second bs) (list `nthnext gvec n)) - n - (nnext bs) - true) - (= firstb :as) (pb ret (second bs) gvec) - :else (if seen-rest? - (throw (new Exception "Unsupported binding form, only :as can follow & parameter")) - (recur (pb ret firstb (list `nth gvec n nil)) - (inc n) - (next bs) - seen-rest?)))) - ret)))) - pmap - (fn [bvec b v] - (let [gmap (or (:as b) (gensym "map__")) - defaults (:or b)] - (loop [ret (-> bvec (conj gmap) (conj v)) - bes (reduce - (fn [bes entry] - (reduce #(assoc %1 %2 ((val entry) %2)) - (dissoc bes (key entry)) - ((key entry) bes))) - (dissoc b :as :or) - {:keys #(keyword (str %)), :strs str, :syms #(list `quote %)})] - (if (seq bes) - (let [bb (key (first bes)) - bk (val (first bes)) - has-default (contains? defaults bb)] - (recur (pb ret bb (if has-default - (list `get gmap bk (defaults bb)) - (list `get gmap bk))) - (next bes))) - ret))))] - (cond - (symbol? b) (-> bvec (conj b) (conj v)) - (vector? b) (pvec bvec b v) - (map? b) (pmap bvec b v) - :else (throw (new Exception (str "Unsupported binding form: " b)))))) - process-entry (fn [bvec b] (pb bvec (key b) (val b)))] - (if (every? symbol? (keys bmap)) - bindings - (reduce process-entry [] bmap)))) - -(defmacro let - "Evaluates the exprs in a lexical context in which the symbols in - the binding-forms are bound to their respective init-exprs or parts - therein." - [bindings & body] - (assert-args let - (vector? bindings) "a vector for its binding" - (even? (count bindings)) "an even number of forms in binding vector") - `(let* ~(destructure bindings) ~@body)) - -;redefine fn with destructuring -(defmacro fn - "(fn name? [params* ] exprs*) - (fn name? ([params* ] exprs*)+) - - params => positional-params* , or positional-params* & next-param - positional-param => binding-form - next-param => binding-form - name => symbol - - Defines a function" - [& sigs] - (let [name (if (symbol? (first sigs)) (first sigs) nil) - sigs (if name (next sigs) sigs) - sigs (if (vector? (first sigs)) (list sigs) sigs) - psig (fn [sig] - (let [[params & body] sig] - (if (every? symbol? params) - sig - (loop [params params - new-params [] - lets []] - (if params - (if (symbol? (first params)) - (recur (next params) (conj new-params (first params)) lets) - (let [gparam (gensym "p__")] - (recur (next params) (conj new-params gparam) - (-> lets (conj (first params)) (conj gparam))))) - `(~new-params - (let ~lets - ~@body))))))) - new-sigs (map psig sigs)] - (with-meta - (if name - (list* 'fn* name new-sigs) - (cons 'fn* new-sigs)) - *macro-meta*))) - -(defmacro loop - "Evaluates the exprs in a lexical context in which the symbols in - the binding-forms are bound to their respective init-exprs or parts - therein. Acts as a recur target." - [bindings & body] - (assert-args loop - (vector? bindings) "a vector for its binding" - (even? (count bindings)) "an even number of forms in binding vector") - (let [db (destructure bindings)] - (if (= db bindings) - `(loop* ~bindings ~@body) - (let [vs (take-nth 2 (drop 1 bindings)) - bs (take-nth 2 bindings) - gs (map (fn [b] (if (symbol? b) b (gensym))) bs) - bfs (reduce (fn [ret [b v g]] - (if (symbol? b) - (conj ret g v) - (conj ret g v b g))) - [] (map vector bs vs gs))] - `(let ~bfs - (loop* ~(vec (interleave gs gs)) - (let ~(vec (interleave bs gs)) - ~@body))))))) - -(defmacro when-first - "bindings => x xs - - Same as (when (seq xs) (let [x (first xs)] body))" - [bindings & body] - (assert-args when-first - (vector? bindings) "a vector for its binding" - (= 2 (count bindings)) "exactly 2 forms in binding vector") - (let [[x xs] bindings] - `(when (seq ~xs) - (let [~x (first ~xs)] - ~@body)))) - -(defmacro lazy-cat - "Expands to code which yields a lazy sequence of the concatenation - of the supplied colls. Each coll expr is not evaluated until it is - needed. - - (lazy-cat xs ys zs) === (concat (lazy-seq xs) (lazy-seq ys) (lazy-seq zs))" - [& colls] - `(concat ~@(map #(list `lazy-seq %) colls))) - -(defmacro for - "List comprehension. Takes a vector of one or more - binding-form/collection-expr pairs, each followed by zero or more - modifiers, and yields a lazy sequence of evaluations of expr. - Collections are iterated in a nested fashion, rightmost fastest, - and nested coll-exprs can refer to bindings created in prior - binding-forms. Supported modifiers are: :let [binding-form expr ...], - :while test, :when test. - - (take 100 (for [x (range 100000000) y (range 1000000) :while (< y x)] [x y]))" - [seq-exprs body-expr] - (assert-args for - (vector? seq-exprs) "a vector for its binding" - (even? (count seq-exprs)) "an even number of forms in binding vector") - (let [to-groups (fn [seq-exprs] - (reduce (fn [groups [k v]] - (if (keyword? k) - (conj (pop groups) (conj (peek groups) [k v])) - (conj groups [k v]))) - [] (partition 2 seq-exprs))) - err (fn [& msg] (throw (IllegalArgumentException. (apply str msg)))) - emit-bind (fn emit-bind [[[bind expr & mod-pairs] - & [[_ next-expr] :as next-groups]]] - (let [giter (gensym "iter__") - gxs (gensym "s__") - do-mod (fn do-mod [[[k v :as pair] & etc]] - (cond - (= k :let) `(let ~v ~(do-mod etc)) - (= k :while) `(when ~v ~(do-mod etc)) - (= k :when) `(if ~v - ~(do-mod etc) - (recur (rest ~gxs))) - (keyword? k) (err "Invalid 'for' keyword " k) - next-groups - `(let [iterys# ~(emit-bind next-groups) - fs# (seq (iterys# ~next-expr))] - (if fs# - (concat fs# (~giter (rest ~gxs))) - (recur (rest ~gxs)))) - :else `(cons ~body-expr - (~giter (rest ~gxs)))))] - `(fn ~giter [~gxs] - (lazy-seq - (loop [~gxs ~gxs] - (when-first [~bind ~gxs] - ~(do-mod mod-pairs)))))))] - `(let [iter# ~(emit-bind (to-groups seq-exprs))] - (iter# ~(second seq-exprs))))) - -(defmacro comment - "Ignores body, yields nil" - [& body]) - -(defmacro with-out-str - "Evaluates exprs in a context in which *out* is bound to a fresh - StringWriter. Returns the string created by any nested printing - calls." - [& body] - `(let [s# (new java.io.StringWriter)] - (binding [*out* s#] - ~@body - (str s#)))) - -(defmacro with-in-str - "Evaluates body in a context in which *in* is bound to a fresh - StringReader initialized with the string s." - [s & body] - `(with-open [s# (-> (java.io.StringReader. ~s) clojure.lang.LineNumberingPushbackReader.)] - (binding [*in* s#] - ~@body))) - -(defn pr-str - "pr to a string, returning it" - {:tag String} - [& xs] - (with-out-str - (apply pr xs))) - -(defn prn-str - "prn to a string, returning it" - {:tag String} - [& xs] - (with-out-str - (apply prn xs))) - -(defn print-str - "print to a string, returning it" - {:tag String} - [& xs] - (with-out-str - (apply print xs))) - -(defn println-str - "println to a string, returning it" - {:tag String} - [& xs] - (with-out-str - (apply println xs))) - -(defmacro assert - "Evaluates expr and throws an exception if it does not evaluate to - logical true." - [x] - `(when-not ~x - (throw (new Exception (str "Assert failed: " (pr-str '~x)))))) - -(defn test - "test [v] finds fn at key :test in var metadata and calls it, - presuming failure will throw exception" - [v] - (let [f (:test ^v)] - (if f - (do (f) :ok) - :no-test))) - -(defn re-pattern - "Returns an instance of java.util.regex.Pattern, for use, e.g. in - re-matcher." - {:tag java.util.regex.Pattern} - [s] (if (instance? java.util.regex.Pattern s) - s - (. java.util.regex.Pattern (compile s)))) - -(defn re-matcher - "Returns an instance of java.util.regex.Matcher, for use, e.g. in - re-find." - {:tag java.util.regex.Matcher} - [#^java.util.regex.Pattern re s] - (. re (matcher s))) - -(defn re-groups - "Returns the groups from the most recent match/find. If there are no - nested groups, returns a string of the entire match. If there are - nested groups, returns a vector of the groups, the first element - being the entire match." - [#^java.util.regex.Matcher m] - (let [gc (. m (groupCount))] - (if (zero? gc) - (. m (group)) - (loop [ret [] c 0] - (if (<= c gc) - (recur (conj ret (. m (group c))) (inc c)) - ret))))) - -(defn re-seq - "Returns a lazy sequence of successive matches of pattern in string, - 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)))))))) - -(defn re-matches - "Returns the match, if any, of string to pattern, using - java.util.regex.Matcher.matches(). Uses re-groups to return the - groups." - [#^java.util.regex.Pattern re s] - (let [m (re-matcher re s)] - (when (. m (matches)) - (re-groups m)))) - - -(defn re-find - "Returns the next regex match, if any, of string to pattern, using - java.util.regex.Matcher.find(). Uses re-groups to return the - groups." - ([#^java.util.regex.Matcher m] - (when (. m (find)) - (re-groups m))) - ([#^java.util.regex.Pattern re s] - (let [m (re-matcher re s)] - (re-find m)))) - -(defn rand - "Returns a random floating point number between 0 (inclusive) and - n (default 1) (exclusive)." - ([] (. Math (random))) - ([n] (* n (rand)))) - -(defn rand-int - "Returns a random integer between 0 (inclusive) and n (exclusive)." - [n] (int (rand n))) - -(defmacro defn- - "same as defn, yielding non-public def" - [name & decls] - (list* `defn (with-meta name (assoc (meta name) :private true)) decls)) - -(defn print-doc [v] - (println "-------------------------") - (println (str (ns-name (:ns ^v)) "/" (:name ^v))) - (prn (:arglists ^v)) - (when (:macro ^v) - (println "Macro")) - (println " " (:doc ^v))) - -(defn find-doc - "Prints documentation for any var whose documentation or name - contains a match for re-string-or-pattern" - [re-string-or-pattern] - (let [re (re-pattern re-string-or-pattern)] - (doseq [ns (all-ns) - v (sort-by (comp :name meta) (vals (ns-interns ns))) - :when (and (:doc ^v) - (or (re-find (re-matcher re (:doc ^v))) - (re-find (re-matcher re (str (:name ^v))))))] - (print-doc v)))) - -(defn special-form-anchor - "Returns the anchor tag on http://clojure.org/special_forms for the - special form x, or nil" - [x] - (#{'. 'def 'do 'fn 'if 'let 'loop 'monitor-enter 'monitor-exit 'new - 'quote 'recur 'set! 'throw 'try 'var} x)) - -(defn syntax-symbol-anchor - "Returns the anchor tag on http://clojure.org/special_forms for the - special form that uses syntax symbol x, or nil" - [x] - ({'& 'fn 'catch 'try 'finally 'try} x)) - -(defn print-special-doc - [name type anchor] - (println "-------------------------") - (println name) - (println type) - (println (str " Please see http://clojure.org/special_forms#" anchor))) - -(defn print-namespace-doc - "Print the documentation string of a Namespace." - [nspace] - (println "-------------------------") - (println (str (ns-name nspace))) - (println " " (:doc ^nspace))) - -(defmacro doc - "Prints documentation for a var or special form given its name" - [name] - (cond - (special-form-anchor `~name) - `(print-special-doc '~name "Special Form" (special-form-anchor '~name)) - (syntax-symbol-anchor `~name) - `(print-special-doc '~name "Syntax Symbol" (syntax-symbol-anchor '~name)) - :else - (let [nspace (find-ns name)] - (if nspace - `(print-namespace-doc ~nspace) - `(print-doc (var ~name)))))) - - (defn tree-seq - "Returns a lazy sequence of the nodes in a tree, via a depth-first walk. - branch? must be a fn of one arg that returns true if passed a node - that can have children (but may not). children must be a fn of one - arg that returns a sequence of the children. Will only be called on - nodes for which branch? returns true. Root is the root node of the - tree." - [branch? children root] - (let [walk (fn walk [node] - (lazy-seq - (cons node - (when (branch? node) - (mapcat walk (children node))))))] - (walk root))) - -(defn file-seq - "A tree seq on java.io.Files" - [dir] - (tree-seq - (fn [#^java.io.File f] (. f (isDirectory))) - (fn [#^java.io.File d] (seq (. d (listFiles)))) - dir)) - -(defn xml-seq - "A tree seq on the xml elements as per xml/parse" - [root] - (tree-seq - (complement string?) - (comp seq :content) - root)) - -(defn special-symbol? - "Returns true if s names a special form" - [s] - (contains? (. clojure.lang.Compiler specials) s)) - -(defn var? - "Returns true if v is of type clojure.lang.Var" - [v] (instance? clojure.lang.Var v)) - -(defn slurp - "Reads the file named by f into a string and returns it." - [#^String f] - (with-open [r (new java.io.BufferedReader (new java.io.FileReader f))] - (let [sb (new StringBuilder)] - (loop [c (. r (read))] - (if (neg? c) - (str sb) - (do - (. sb (append (char c))) - (recur (. r (read))))))))) - -(defn subs - "Returns the substring of s beginning at start inclusive, and ending - at end (defaults to length of string), exclusive." - ([#^String s start] (. s (substring start))) - ([#^String s start end] (. s (substring start end)))) - -(defn max-key - "Returns the x for which (k x), a number, is greatest." - ([k x] x) - ([k x y] (if (> (k x) (k y)) x y)) - ([k x y & more] - (reduce #(max-key k %1 %2) (max-key k x y) more))) - -(defn min-key - "Returns the x for which (k x), a number, is least." - ([k x] x) - ([k x y] (if (< (k x) (k y)) x y)) - ([k x y & more] - (reduce #(min-key k %1 %2) (min-key k x y) more))) - -(defn distinct - "Returns a lazy sequence of the elements of coll with duplicates removed" - [coll] - (let [step (fn step [xs seen] - (lazy-seq - ((fn [[f :as xs] seen] - (when-let [s (seq xs)] - (if (contains? seen f) - (recur (rest s) seen) - (cons f (step (rest s) (conj seen f)))))) - xs seen)))] - (step coll #{}))) - - - -(defn replace - "Given a map of replacement pairs and a vector/collection, returns a - vector/seq with any elements = a key in smap replaced with the - corresponding val in smap" - [smap coll] - (if (vector? coll) - (reduce (fn [v i] - (if-let [e (find smap (nth v i))] - (assoc v i (val e)) - v)) - coll (range (count coll))) - (map #(if-let [e (find smap %)] (val e) %) coll))) - -(defmacro dosync - "Runs the exprs (in an implicit do) in a transaction that encompasses - exprs and any nested calls. Starts a transaction if none is already - running on this thread. Any uncaught exception will abort the - transaction and flow out of dosync. The exprs may be run more than - once, but any effects on Refs will be atomic." - [& exprs] - `(sync nil ~@exprs)) - -(defmacro with-precision - "Sets the precision and rounding mode to be used for BigDecimal operations. - - Usage: (with-precision 10 (/ 1M 3)) - or: (with-precision 10 :rounding HALF_DOWN (/ 1M 3)) - - The rounding mode is one of CEILING, FLOOR, HALF_UP, HALF_DOWN, - HALF_EVEN, UP, DOWN and UNNECESSARY; it defaults to HALF_UP." - [precision & exprs] - (let [[body rm] (if (= (first exprs) :rounding) - [(next (next exprs)) - `((. java.math.RoundingMode ~(second exprs)))] - [exprs nil])] - `(binding [*math-context* (java.math.MathContext. ~precision ~@rm)] - ~@body))) - -(defn bound-fn - {:private true} - [#^clojure.lang.Sorted sc test key] - (fn [e] - (test (.. sc comparator (compare (. sc entryKey e) key)) 0))) - -(defn subseq - "sc must be a sorted collection, test(s) one of <, <=, > or - >=. Returns a seq of those entries with keys ek for - which (test (.. sc comparator (compare ek key)) 0) is true" - ([#^clojure.lang.Sorted sc test key] - (let [include (bound-fn sc test key)] - (if (#{> >=} test) - (when-let [[e :as s] (. sc seqFrom key true)] - (if (include e) s (next s))) - (take-while include (. sc seq true))))) - ([#^clojure.lang.Sorted sc start-test start-key end-test end-key] - (when-let [[e :as s] (. sc seqFrom start-key true)] - (take-while (bound-fn sc end-test end-key) - (if ((bound-fn sc start-test start-key) e) s (next s)))))) - -(defn rsubseq - "sc must be a sorted collection, test(s) one of <, <=, > or - >=. Returns a reverse seq of those entries with keys ek for - which (test (.. sc comparator (compare ek key)) 0) is true" - ([#^clojure.lang.Sorted sc test key] - (let [include (bound-fn sc test key)] - (if (#{< <=} test) - (when-let [[e :as s] (. sc seqFrom key false)] - (if (include e) s (next s))) - (take-while include (. sc seq false))))) - ([#^clojure.lang.Sorted sc start-test start-key end-test end-key] - (when-let [[e :as s] (. sc seqFrom end-key false)] - (take-while (bound-fn sc start-test start-key) - (if ((bound-fn sc end-test end-key) e) s (next s)))))) - -(defn repeatedly - "Takes a function of no args, presumably with side effects, and returns an infinite - lazy sequence of calls to it" - [f] (lazy-seq (cons (f) (repeatedly f)))) - -(defn add-classpath - "Adds the url (String or URL object) to the classpath per URLClassLoader.addURL" - [url] (. clojure.lang.RT addURL url)) - - - -(defn hash - "Returns the hash code of its argument" - [x] (. clojure.lang.Util (hash x))) - -(defn interpose - "Returns a lazy seq of the elements of coll separated by sep" - [sep coll] (drop 1 (interleave (repeat sep) coll))) - -(defmacro definline - "Experimental - like defmacro, except defines a named function whose - body is the expansion, calls to which may be expanded inline as if - it were a macro. Cannot be used with variadic (&) args." - [name & decl] - (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)) - (var ~name)))) - -(defn empty - "Returns an empty collection of the same category as coll, or nil" - [coll] - (when (instance? clojure.lang.IPersistentCollection coll) - (.empty #^clojure.lang.IPersistentCollection coll))) - -(defmacro amap - "Maps an expression across an array a, using an index named idx, and - return value named ret, initialized to a clone of a, then setting each element of - ret to the evaluation of expr, returning the new array ret." - [a idx ret expr] - `(let [a# ~a - ~ret (aclone a#)] - (loop [~idx (int 0)] - (if (< ~idx (alength a#)) - (do - (aset ~ret ~idx ~expr) - (recur (unchecked-inc ~idx))) - ~ret)))) - -(defmacro areduce - "Reduces an expression across an array a, using an index named idx, - and return value named ret, initialized to init, setting ret to the evaluation of expr at - each step, returning ret." - [a idx ret init expr] - `(let [a# ~a] - (loop [~idx (int 0) ~ret ~init] - (if (< ~idx (alength a#)) - (recur (unchecked-inc ~idx) ~expr) - ~ret)))) - -(defn float-array - "Creates an array of floats" - {:inline (fn [& args] `(. clojure.lang.Numbers float_array ~@args)) - :inline-arities #{1 2}} - ([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 double-array - "Creates an array of doubles" - {:inline (fn [& args] `(. clojure.lang.Numbers double_array ~@args)) - :inline-arities #{1 2}} - ([size-or-seq] (. clojure.lang.Numbers double_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers double_array size init-val-or-seq))) - -(defn int-array - "Creates an array of ints" - {:inline (fn [& args] `(. clojure.lang.Numbers int_array ~@args)) - :inline-arities #{1 2}} - ([size-or-seq] (. clojure.lang.Numbers int_array size-or-seq)) - ([size init-val-or-seq] (. clojure.lang.Numbers int_array size init-val-or-seq))) - -(defn long-array - "Creates an array of ints" - {: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 floats - "Casts to float[]" - [xs] `(. clojure.lang.Numbers floats ~xs)) - -(definline ints - "Casts to int[]" - [xs] `(. clojure.lang.Numbers ints ~xs)) - -(definline doubles - "Casts to double[]" - [xs] `(. clojure.lang.Numbers doubles ~xs)) - -(definline longs - "Casts to long[]" - [xs] `(. clojure.lang.Numbers longs ~xs)) - -(import '(java.util.concurrent BlockingQueue LinkedBlockingQueue)) - -(defn seque - "Creates a queued seq on another (presumably lazy) seq s. The queued - seq will produce a concrete seq in the background, and can get up to - n items ahead of the consumer. n-or-q can be an integer n buffer - size, or an instance of java.util.concurrent BlockingQueue. Note - that reading from a seque can block if the reader gets ahead of the - producer." - ([s] (seque 100 s)) - ([n-or-q s] - (let [#^BlockingQueue q (if (instance? BlockingQueue n-or-q) - n-or-q - (LinkedBlockingQueue. (int n-or-q))) - NIL (Object.) ;nil sentinel since LBQ doesn't support nils - agt (agent (seq s)) - fill (fn [s] - (try - (loop [[x & xs :as s] s] - (if s - (if (.offer q (if (nil? x) NIL x)) - (recur xs) - s) - (.put q q))) ; q itself is eos sentinel - (catch Exception e - (.put q q) - (throw e)))) - drain (fn drain [] - (lazy-seq - (let [x (.take q)] - (if (identical? x q) ;q itself is eos sentinel - (do @agt nil) ;touch agent just to propagate errors - (do - (send-off agt fill) - (cons (if (identical? x NIL) nil x) (drain)))))))] - (send-off agt fill) - (drain)))) - -(defn class? - "Returns true if x is an instance of Class" - [x] (instance? Class x)) - -(defn alter-var-root - "Atomically alters the root binding of var v by applying f to its - current value plus any args" - [#^clojure.lang.Var v f & args] (.alterRoot v f args)) - -(defn make-hierarchy - "Creates a hierarchy object for use with derive, isa? etc." - [] {:parents {} :descendants {} :ancestors {}}) - -(def #^{:private true} - global-hierarchy (make-hierarchy)) - -(defn not-empty - "If coll is empty, returns nil, else coll" - [coll] (when (seq coll) coll)) - -(defn bases - "Returns the immediate superclass and direct interfaces of c, if any" - [#^Class c] - (let [i (.getInterfaces c) - s (.getSuperclass c)] - (not-empty - (if s (cons s i) i)))) - -(defn supers - "Returns the immediate and indirect superclasses and interfaces of c, if any" - [#^Class class] - (loop [ret (set (bases class)) cs ret] - (if (seq cs) - (let [c (first cs) bs (bases c)] - (recur (into ret bs) (into (disj cs c) bs))) - (not-empty ret)))) - -(defn isa? - "Returns true if (= child parent), or child is directly or indirectly derived from - parent, either via a Java type inheritance relationship or a - relationship established via derive. h must be a hierarchy obtained - from make-hierarchy, if not supplied defaults to the global - hierarchy" - ([child parent] (isa? global-hierarchy child parent)) - ([h child parent] - (or (= child parent) - (and (class? parent) (class? child) - (. #^Class parent isAssignableFrom child)) - (contains? ((:ancestors h) child) parent) - (and (class? child) (some #(contains? ((:ancestors h) %) parent) (supers child))) - (and (vector? parent) (vector? child) - (= (count parent) (count child)) - (loop [ret true i 0] - (if (or (not ret) (= i (count parent))) - ret - (recur (isa? h (child i) (parent i)) (inc i)))))))) - -(defn parents - "Returns the immediate parents of tag, either via a Java type - inheritance relationship or a relationship established via derive. h - must be a hierarchy obtained from make-hierarchy, if not supplied - defaults to the global hierarchy" - ([tag] (parents global-hierarchy tag)) - ([h tag] (not-empty - (let [tp (get (:parents h) tag)] - (if (class? tag) - (into (set (bases tag)) tp) - tp))))) - -(defn ancestors - "Returns the immediate and indirect parents of tag, either via a Java type - inheritance relationship or a relationship established via derive. h - must be a hierarchy obtained from make-hierarchy, if not supplied - defaults to the global hierarchy" - ([tag] (ancestors global-hierarchy tag)) - ([h tag] (not-empty - (let [ta (get (:ancestors h) tag)] - (if (class? tag) - (let [superclasses (set (supers tag))] - (reduce into superclasses - (cons ta - (map #(get (:ancestors h) %) superclasses)))) - ta))))) - -(defn descendants - "Returns the immediate and indirect children of tag, through a - relationship established via derive. h must be a hierarchy obtained - from make-hierarchy, if not supplied defaults to the global - hierarchy. Note: does not work on Java type inheritance - relationships." - ([tag] (descendants global-hierarchy tag)) - ([h tag] (if (class? tag) - (throw (java.lang.UnsupportedOperationException. "Can't get descendants of classes")) - (not-empty (get (:descendants h) tag))))) - -(defn derive - "Establishes a parent/child relationship between parent and - tag. Parent must be a namespace-qualified symbol or keyword and - child can be either a namespace-qualified symbol or keyword or a - class. h must be a hierarchy obtained from make-hierarchy, if not - supplied defaults to, and modifies, the global hierarchy." - ([tag parent] - (assert (namespace parent)) - (assert (or (class? tag) (and (instance? clojure.lang.Named tag) (namespace tag)))) - - (alter-var-root #'global-hierarchy derive tag parent) nil) - ([h tag parent] - (assert (not= tag parent)) - (assert (or (class? tag) (instance? clojure.lang.Named tag))) - (assert (instance? clojure.lang.Named parent)) - - (let [tp (:parents h) - td (:descendants h) - ta (:ancestors h) - tf (fn [m source sources target targets] - (reduce (fn [ret k] - (assoc ret k - (reduce conj (get targets k #{}) (cons target (targets target))))) - m (cons source (sources source))))] - (or - (when-not (contains? (tp tag) parent) - (when (contains? (ta tag) parent) - (throw (Exception. (print-str tag "already has" parent "as ancestor")))) - (when (contains? (ta parent) tag) - (throw (Exception. (print-str "Cyclic derivation:" parent "has" tag "as ancestor")))) - {:parents (assoc (:parents h) tag (conj (get tp tag #{}) parent)) - :ancestors (tf (:ancestors h) tag td parent ta) - :descendants (tf (:descendants h) parent ta tag td)}) - h)))) - -(defn underive - "Removes a parent/child relationship between parent and - tag. h must be a hierarchy obtained from make-hierarchy, if not - supplied defaults to, and modifies, the global hierarchy." - ([tag parent] (alter-var-root #'global-hierarchy underive tag parent) nil) - ([h tag parent] - (let [tp (:parents h) - td (:descendants h) - ta (:ancestors h) - tf (fn [m source sources target targets] - (reduce - (fn [ret k] - (assoc ret k - (reduce disj (get targets k) (cons target (targets target))))) - m (cons source (sources source))))] - (if (contains? (tp tag) parent) - {:parent (assoc (:parents h) tag (disj (get tp tag) parent)) - :ancestors (tf (:ancestors h) tag td parent ta) - :descendants (tf (:descendants h) parent ta tag td)} - h)))) - - -(defn distinct? - "Returns true if no two of the arguments are =" - {:tag Boolean} - ([x] true) - ([x y] (not (= x y))) - ([x y & more] - (if (not= x y) - (loop [s #{x y} [x & etc :as xs] more] - (if xs - (if (contains? s x) - false - (recur (conj s x) etc)) - true)) - false))) - -(defn resultset-seq - "Creates and returns a lazy sequence of structmaps corresponding to - the rows in the java.sql.ResultSet rs" - [#^java.sql.ResultSet rs] - (let [rsmeta (. rs (getMetaData)) - idxs (range 1 (inc (. rsmeta (getColumnCount)))) - keys (map (comp keyword #(.toLowerCase #^String %)) - (map (fn [i] (. rsmeta (getColumnLabel i))) idxs)) - check-keys - (or (apply distinct? keys) - (throw (Exception. "ResultSet must have unique column labels"))) - 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)))))] - (rows))) - -(defn iterator-seq - "Returns a seq on a java.util.Iterator. Note that most collections - providing iterators implement Iterable and thus support seq directly." - [iter] - (clojure.lang.IteratorSeq/create iter)) - -(defn enumeration-seq - "Returns a seq on a java.util.Enumeration" - [e] - (clojure.lang.EnumerationSeq/create e)) - -(defn format - "Formats a string using java.lang.String.format, see java.util.Formatter for format - string syntax" - {:tag String} - [fmt & args] - (String/format fmt (to-array args))) - -(defn printf - "Prints formatted output, as per format" - [fmt & args] - (print (apply format fmt args))) - -(def gen-class) - -(defmacro ns - "Sets *ns* to the namespace named by name (unevaluated), creating it - if needed. references can be zero or more of: (:refer-clojure ...) - (:require ...) (:use ...) (:import ...) (:load ...) (:gen-class) - with the syntax of refer-clojure/require/use/import/load/gen-class - respectively, except the arguments are unevaluated and need not be - quoted. (:gen-class ...), when supplied, defaults to :name - corresponding to the ns name, :main true, :impl-ns same as ns, and - :init-impl-ns true. All options of gen-class are - supported. The :gen-class directive is ignored when not - compiling. If :gen-class is not supplied, when compiled only an - nsname__init.class will be generated. If :refer-clojure is not used, a - default (refer 'clojure) is used. Use of ns is preferred to - individual calls to in-ns/require/use/import: - - (ns foo.bar - (:refer-clojure :exclude [ancestors printf]) - (:require (clojure.contrib sql sql.tests)) - (:use (my.lib this that)) - (:import (java.util Date Timer Random) - (java.sql Connection Statement)))" - - [name & references] - (let [process-reference - (fn [[kname & args]] - `(~(symbol "clojure.core" (clojure.core/name kname)) - ~@(map #(list 'quote %) args))) - docstring (when (string? (first references)) (first references)) - references (if docstring (next references) references) - name (if docstring - (with-meta name (assoc (meta name) - :doc docstring)) - name) - gen-class-clause (first (filter #(= :gen-class (first %)) references)) - gen-class-call - (when gen-class-clause - (list* `gen-class :name (.replace (str name) \- \_) :impl-ns name :main true (next gen-class-clause))) - references (remove #(= :gen-class (first %)) references)] - `(do - (clojure.core/in-ns '~name) - ~@(when gen-class-call (list gen-class-call)) - ~@(when (and (not= name 'clojure.core) (not-any? #(= :refer-clojure (first %)) references)) - `((clojure.core/refer '~'clojure.core))) - ~@(map process-reference references)))) - -(defmacro refer-clojure - "Same as (refer 'clojure.core <filters>)" - [& filters] - `(clojure.core/refer '~'clojure.core ~@filters)) - -(defmacro defonce - "defs name to have the root value of the expr iff the named var has no root value, - else expr is unevaluated" - [name expr] - `(let [v# (def ~name)] - (when-not (.hasRoot v#) - (def ~name ~expr)))) - -;;;;;;;;;;; require/use/load, contributed by Stephen C. Gilardi ;;;;;;;;;;;;;;;;;; - -(defonce - #^{:private true - :doc "A ref to a sorted set of symbols representing loaded libs"} - *loaded-libs* (ref (sorted-set))) - -(defonce - #^{:private true - :doc "the set of paths currently being loaded by this thread"} - *pending-paths* #{}) - -(defonce - #^{:private true :doc - "True while a verbose load is pending"} - *loading-verbosely* false) - -(defn- throw-if - "Throws an exception with a message if pred is true" - [pred fmt & args] - (when pred - (let [#^String message (apply format fmt args) - exception (Exception. message) - raw-trace (.getStackTrace exception) - boring? #(not= (.getMethodName #^StackTraceElement %) "doInvoke") - trace (into-array (drop 2 (drop-while boring? raw-trace)))] - (.setStackTrace exception trace) - (throw exception)))) - -(defn- libspec? - "Returns true if x is a libspec" - [x] - (or (symbol? x) - (and (vector? x) - (or - (nil? (second x)) - (keyword? (second x)))))) - -(defn- prependss - "Prepends a symbol or a seq to coll" - [x coll] - (if (symbol? x) - (cons x coll) - (concat x coll))) - -(defn- root-resource - "Returns the root directory path for a lib" - {:tag String} - [lib] - (str \/ - (.. (name lib) - (replace \- \_) - (replace \. \/)))) - -(defn- root-directory - "Returns the root resource path for a lib" - [lib] - (let [d (root-resource lib)] - (subs d 0 (.lastIndexOf d "/")))) - -(def load) - -(defn- load-one - "Loads a lib given its name. If need-ns, ensures that the associated - namespace exists after loading. If require, records the load so any - duplicate loads can be skipped." - [lib need-ns require] - (load (root-resource lib)) - (throw-if (and need-ns (not (find-ns lib))) - "namespace '%s' not found after loading '%s'" - lib (root-resource lib)) - (when require - (dosync - (commute *loaded-libs* conj lib)))) - -(defn- load-all - "Loads a lib given its name and forces a load of any libs it directly or - indirectly loads. If need-ns, ensures that the associated namespace - exists after loading. If require, records the load so any duplicate loads - can be skipped." - [lib need-ns require] - (dosync - (commute *loaded-libs* #(reduce conj %1 %2) - (binding [*loaded-libs* (ref (sorted-set))] - (load-one lib need-ns require) - @*loaded-libs*)))) - -(defn- load-lib - "Loads a lib with options" - [prefix lib & options] - (throw-if (and prefix (pos? (.indexOf (name lib) (int \.)))) - "lib names inside prefix lists must not contain periods") - (let [lib (if prefix (symbol (str prefix \. lib)) lib) - opts (apply hash-map options) - {:keys [as reload reload-all require use verbose]} opts - loaded (contains? @*loaded-libs* lib) - load (cond reload-all - load-all - (or reload (not require) (not loaded)) - load-one) - need-ns (or as use) - filter-opts (select-keys opts '(:exclude :only :rename))] - (binding [*loading-verbosely* (or *loading-verbosely* verbose)] - (if load - (load lib need-ns require) - (throw-if (and need-ns (not (find-ns lib))) - "namespace '%s' not found" lib)) - (when (and need-ns *loading-verbosely*) - (printf "(clojure.core/in-ns '%s)\n" (ns-name *ns*))) - (when as - (when *loading-verbosely* - (printf "(clojure.core/alias '%s '%s)\n" as lib)) - (alias as lib)) - (when use - (when *loading-verbosely* - (printf "(clojure.core/refer '%s" lib) - (doseq [opt filter-opts] - (printf " %s '%s" (key opt) (print-str (val opt)))) - (printf ")\n")) - (apply refer lib (mapcat seq filter-opts)))))) - -(defn- load-libs - "Loads libs, interpreting libspecs, prefix lists, and flags for - forwarding to load-lib" - [& args] - (let [flags (filter keyword? args) - opts (interleave flags (repeat true)) - args (filter (complement keyword?) args)] - (doseq [arg args] - (if (libspec? arg) - (apply load-lib nil (prependss arg opts)) - (let [[prefix & args] arg] - (throw-if (nil? prefix) "prefix cannot be nil") - (doseq [arg args] - (apply load-lib prefix (prependss arg opts)))))))) - -;; Public - -(defn require - "Loads libs, skipping any that are already loaded. Each argument is - either a libspec that identifies a lib, a prefix list that identifies - multiple libs whose names share a common prefix, or a flag that modifies - how all the identified libs are loaded. Use :require in the ns macro - in preference to calling this directly. - - Libs - - A 'lib' is a named set of resources in classpath whose contents define a - library of Clojure code. Lib names are symbols and each lib is associated - with a Clojure namespace and a Java package that share its name. A lib's - name also locates its root directory within classpath using Java's - package name to classpath-relative path mapping. All resources in a lib - should be contained in the directory structure under its root directory. - All definitions a lib makes should be in its associated namespace. - - 'require loads a lib by loading its root resource. The root resource path - is derived from the root directory path by repeating its last component - and appending '.clj'. For example, the lib 'x.y.z has root directory - <classpath>/x/y/z; root resource <classpath>/x/y/z/z.clj. The root - resource should contain code to create the lib's namespace and load any - additional lib resources. - - Libspecs - - A libspec is a lib name or a vector containing a lib name followed by - options expressed as sequential keywords and arguments. - - Recognized options: :as - :as takes a symbol as its argument and makes that symbol an alias to the - lib's namespace in the current namespace. - - Prefix Lists - - It's common for Clojure code to depend on several libs whose names have - the same prefix. When specifying libs, prefix lists can be used to reduce - repetition. A prefix list contains the shared prefix followed by libspecs - with the shared prefix removed from the lib names. After removing the - prefix, the names that remain must not contain any periods. - - Flags - - A flag is a keyword. - Recognized flags: :reload, :reload-all, :verbose - :reload forces loading of all the identified libs even if they are - already loaded - :reload-all implies :reload and also forces loading of all libs that the - identified libs directly or indirectly load via require or use - :verbose triggers printing information about each load, alias, and refer" - - [& args] - (apply load-libs :require args)) - -(defn use - "Like 'require, but also refers to each lib's namespace using - clojure.core/refer. Use :use in the ns macro in preference to calling - this directly. - - 'use accepts additional options in libspecs: :exclude, :only, :rename. - The arguments and semantics for :exclude, :only, and :rename are the same - as those documented for clojure.core/refer." - [& args] (apply load-libs :require :use args)) - -(defn loaded-libs - "Returns a sorted set of symbols naming the currently loaded libs" - [] @*loaded-libs*) - -(defn load - "Loads Clojure code from resources in classpath. A path is interpreted as - classpath-relative if it begins with a slash or relative to the root - directory for the current namespace otherwise." - [& paths] - (doseq [#^String path paths] - (let [#^String path (if (.startsWith path "/") - path - (str (root-directory (ns-name *ns*)) \/ path))] - (when *loading-verbosely* - (printf "(clojure.core/load \"%s\")\n" path) - (flush)) -; (throw-if (*pending-paths* path) -; "cannot load '%s' again while it is loading" -; path) - (when-not (*pending-paths* path) - (binding [*pending-paths* (conj *pending-paths* path)] - (clojure.lang.RT/load (.substring path 1))))))) - -(defn compile - "Compiles the namespace named by the symbol lib into a set of - classfiles. The source for the lib must be in a proper - classpath-relative directory. The output files will go into the - directory specified by *compile-path*, and that directory too must - be in the classpath." - [lib] - (binding [*compile-files* true] - (load-one lib true true)) - lib) - -;;;;;;;;;;;;; nested associative ops ;;;;;;;;;;; - -(defn get-in - "returns the value in a nested associative structure, where ks is a sequence of keys" - [m ks] - (reduce get m ks)) - -(defn assoc-in - "Associates a value in a nested associative structure, where ks is a - sequence of keys and v is the new value and returns a new nested structure. - If any levels do not exist, hash-maps will be created." - [m [k & ks] v] - (if ks - (assoc m k (assoc-in (get m k) ks v)) - (assoc m k v))) - -(defn update-in - "'Updates' a value in a nested associative structure, where ks is a - sequence of keys and f is a function that will take the old value - and any supplied args and return the new value, and returns a new - nested structure. If any levels do not exist, hash-maps will be - created." - ([m [k & ks] f & args] - (if ks - (assoc m k (apply update-in (get m k) ks f args)) - (assoc m k (apply f (get m k) args))))) - - -(defn empty? - "Returns true if coll has no items - same as (not (seq coll)). - Please use the idiom (seq x) rather than (not (empty? x))" - [coll] (not (seq coll))) - -(defn coll? - "Returns true if x implements IPersistentCollection" - [x] (instance? clojure.lang.IPersistentCollection x)) - -(defn list? - "Returns true if x implements IPersistentList" - [x] (instance? clojure.lang.IPersistentList x)) - -(defn set? - "Returns true if x implements IPersistentSet" - [x] (instance? clojure.lang.IPersistentSet x)) - -(defn ifn? - "Returns true if x implements IFn. Note that many data structures - (e.g. sets and maps) implement IFn" - [x] (instance? clojure.lang.IFn x)) - -(defn fn? - "Returns true if x implements Fn, i.e. is an object created via fn." - [x] (instance? clojure.lang.Fn x)) - - -(defn associative? - "Returns true if coll implements Associative" - [coll] (instance? clojure.lang.Associative coll)) - -(defn sequential? - "Returns true if coll implements Sequential" - [coll] (instance? clojure.lang.Sequential coll)) - -(defn sorted? - "Returns true if coll implements Sorted" - [coll] (instance? clojure.lang.Sorted coll)) - -(defn counted? - "Returns true if coll implements count in constant time" - [coll] (instance? clojure.lang.Counted coll)) - -(defn reversible? - "Returns true if coll implements Reversible" - [coll] (instance? clojure.lang.Reversible coll)) - -(def - #^{:doc "bound in a repl thread to the most recent value printed"} - *1) - -(def - #^{:doc "bound in a repl thread to the second most recent value printed"} - *2) - -(def - #^{:doc "bound in a repl thread to the third most recent value printed"} - *3) - -(def - #^{:doc "bound in a repl thread to the most recent exception caught by the repl"} - *e) - -(defmacro declare - "defs the supplied var names with no bindings, useful for making forward declarations." - [& names] `(do ~@(map #(list 'def %) names))) - -(defn trampoline - "trampoline can be used to convert algorithms requiring mutual - recursion without stack consumption. Calls f with supplied args, if - any. If f returns a fn, calls that fn with no arguments, and - continues to repeat, until the return value is not a fn, then - returns that non-fn value. Note that if you want to return a fn as a - final value, you must wrap it in some data structure and unpack it - after trampoline returns." - ([f] - (let [ret (f)] - (if (fn? ret) - (recur ret) - ret))) - ([f & args] - (trampoline #(apply f args)))) - -(defn intern - "Finds or creates a var named by the symbol name in the namespace - ns (which can be a symbol or a namespace), setting its root binding - to val if supplied. The namespace must exist. The var will adopt any - metadata from the name symbol. Returns the var." - ([ns #^clojure.lang.Symbol name] - (let [v (clojure.lang.Var/intern (the-ns ns) name)] - (when ^name (.setMeta v ^name)) - v)) - ([ns name val] - (let [v (clojure.lang.Var/intern (the-ns ns) name val)] - (when ^name (.setMeta v ^name)) - v))) - -(defmacro while - "Repeatedly executes body while test expression is true. Presumes - some side-effect will cause test to become false/nil. Returns nil" - [test & body] - `(loop [] - (when ~test - ~@body - (recur)))) - -(defn memoize - "Returns a memoized version of a referentially transparent function. The - memoized version of the function keeps a cache of the mapping from arguments - to results and, when calls with the same arguments are repeated often, has - higher performance at the expense of higher memory use." - [f] - (let [mem (atom {})] - (fn [& args] - (if-let [e (find @mem args)] - (val e) - (let [ret (apply f args)] - (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. (str "No matching clause: " ~expr))) - (= 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)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; var documentation ;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro add-doc {:private true} [name docstring] - `(alter-meta! (var ~name) assoc :doc ~docstring)) - -(add-doc *file* - "The path of the file being evaluated, as a String. - - Evaluates to nil when there is no file, eg. in the REPL.") - -(add-doc *command-line-args* - "A sequence of the supplied command line arguments, or nil if - none were supplied") - -(add-doc *warn-on-reflection* - "When set to true, the compiler will emit warnings when reflection is - needed to resolve Java method calls or field accesses. - - Defaults to false.") - -(add-doc *compile-path* - "Specifies the directory where 'compile' will write out .class - files. This directory must be in the classpath for 'compile' to - work. - - Defaults to \"classes\"") - -(add-doc *compile-files* - "Set to true when compiling files, false otherwise.") - -(add-doc *ns* - "A clojure.lang.Namespace object representing the current namespace.") - -(add-doc *in* - "A java.io.Reader object representing standard input for read operations. - - Defaults to System/in, wrapped in a LineNumberingPushbackReader") - -(add-doc *out* - "A java.io.Writer object representing standard output for print operations. - - Defaults to System/out") - -(add-doc *err* - "A java.io.Writer object representing standard error for print operations. - - Defaults to System/err, wrapped in a PrintWriter") - -(add-doc *flush-on-newline* - "When set to true, output will be flushed whenever a newline is printed. - - Defaults to true.") - -(add-doc *print-meta* - "If set to logical true, when printing an object, its metadata will also - be printed in a form that can be read back by the reader. - - Defaults to false.") - -(add-doc *print-dup* - "When set to logical true, objects will be printed in a way that preserves - their type when read in later. - - Defaults to false.") - -(add-doc *print-readably* - "When set to logical false, strings and characters will be printed with - non-alphanumeric characters converted to the appropriate escape sequences. - - Defaults to true") - -(add-doc *read-eval* - "When set to logical false, the EvalReader (#=(...)) is disabled in the - read/load in the thread-local binding. - Example: (binding [*read-eval* false] (read-string \"#=(eval (def x 3))\")) - - Defaults to true") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; helper files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(alter-meta! (find-ns 'clojure.core) assoc :doc "Fundamental library of the Clojure language") -(load "core_proxy") -(load "core_print") -(load "genclass") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; futures (needs proxy);;;;;;;;;;;;;;;;;; -(defn future-call - "Takes a function of no args and yields a future object that will - invoke the function in another thread, and will cache the result and - return it on all subsequent calls to deref/@. If the computation has - not yet finished, calls to deref/@ will block." - [#^Callable f] - (let [fut (.submit clojure.lang.Agent/soloExecutor f)] - (proxy [clojure.lang.IDeref java.util.concurrent.Future] [] - (deref [] (.get fut)) - (get ([] (.get fut)) - ([timeout unit] (.get fut timeout unit))) - (isCancelled [] (.isCancelled fut)) - (isDone [] (.isDone fut)) - (cancel [interrupt?] (.cancel fut interrupt?))))) - -(defmacro future - "Takes a body of expressions and yields a future object that will - invoke the body in another thread, and will cache the result and - return it on all subsequent calls to deref/@. If the computation has - not yet finished, calls to deref/@ will block." - [& body] `(future-call (fn [] ~@body))) - -(defn pmap - "Like map, except f is applied in parallel. Semi-lazy in that the - parallel computation stays ahead of the consumption, but doesn't - realize the entire result unless required. Only useful for - computationally intensive functions where the time of f dominates - the coordination overhead." - ([f coll] - (let [n (+ 2 (.. Runtime getRuntime availableProcessors)) - rets (map #(future (f %)) coll) - step (fn step [[x & xs :as vs] fs] - (lazy-seq - (if-let [s (seq fs)] - (cons (deref x) (step xs (rest s))) - (map deref vs))))] - (step rets (drop n rets)))) - ([f coll & colls] - (let [step (fn step [cs] - (lazy-seq - (let [ss (map seq cs)] - (when (every? identity ss) - (cons (map first ss) (step (map rest ss)))))))] - (pmap #(apply f %) (step (cons coll colls)))))) - -(defn pcalls - "Executes the no-arg fns in parallel, returning a lazy sequence of - their values" - [& fns] (pmap #(%) fns)) - -(defmacro pvalues - "Returns a lazy sequence of the values of the exprs, which are - evaluated in parallel" - [& exprs] - `(pcalls ~@(map #(list `fn [] %) exprs))) - -(defmacro letfn - "Takes a vector of function specs and a body, and generates a set of - bindings of functions to their names. All of the names are available - in all of the definitions of the functions, as well as the body. - - fnspec ==> (fname [params*] exprs) or (fname ([params*] exprs)+)" - [fnspecs & body] - `(letfn* ~(vec (interleave (map first fnspecs) - (map #(cons `fn %) fnspecs))) - ~@body)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; clojure version number ;;;;;;;;;;;;;;;;;;;;;; - -(let [version-stream (.getResourceAsStream (clojure.lang.RT/baseLoader) - "clojure/version.properties") - properties (doto (new java.util.Properties) (.load version-stream)) - prop (fn [k] (.getProperty properties (str "clojure.version." k))) - clojure-version {:major (Integer/valueOf (prop "major")) - :minor (Integer/valueOf (prop "minor")) - :incremental (Integer/valueOf (prop "incremental")) - :qualifier (prop "qualifier")}] - (def *clojure-version* - (if (not (= (prop "interim") "false")) - (clojure.lang.RT/assoc clojure-version :interim true) - clojure-version))) - -(add-doc *clojure-version* - "The version info for Clojure core, as a map containing :major :minor - :incremental and :qualifier keys. Feature releases may increment - :minor and/or :major, bugfix releases will increment :incremental. - Possible values of :qualifier include \"GA\", \"SNAPSHOT\", \"RC-x\" \"BETA-x\"") - -(defn - clojure-version - "Returns clojure version as a printable string." - [] - (str (:major *clojure-version*) - "." - (:minor *clojure-version*) - (when-let [i (:incremental *clojure-version*)] - (str "." i)) - (when-let [q (:qualifier *clojure-version*)] - (str "-" q)) - (when (:interim *clojure-version*) - "-SNAPSHOT"))) -; 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. - -(in-ns 'clojure.core) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; printing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import '(java.io Writer)) - -(def - #^{:doc "*print-length* controls how many items of each collection the - printer will print. If it is bound to logical false, there is no - limit. Otherwise, it must be bound to an integer indicating the maximum - number of items of each collection to print. If a collection contains - more items, the printer will print items up to the limit followed by - '...' to represent the remaining items. The root binding is nil - indicating no limit."} - *print-length* nil) - -(def - #^{:doc "*print-level* controls how many levels deep the printer will - print nested objects. If it is bound to logical false, there is no - limit. Otherwise, it must be bound to an integer indicating the maximum - level to print. Each argument to print is at level 0; if an argument is a - collection, its items are at level 1; and so on. If an object is a - collection and is at a level greater than or equal to the value bound to - *print-level*, the printer prints '#' to represent it. The root binding - is nil indicating no limit."} -*print-level* nil) - -(defn- print-sequential [#^String begin, print-one, #^String sep, #^String end, sequence, #^Writer w] - (binding [*print-level* (and (not *print-dup*) *print-level* (dec *print-level*))] - (if (and *print-level* (neg? *print-level*)) - (.write w "#") - (do - (.write w begin) - (when-let [xs (seq sequence)] - (if (and (not *print-dup*) *print-length*) - (loop [[x & xs] xs - print-length *print-length*] - (if (zero? print-length) - (.write w "...") - (do - (print-one x w) - (when xs - (.write w sep) - (recur xs (dec print-length)))))) - (loop [[x & xs] xs] - (print-one x w) - (when xs - (.write w sep) - (recur xs))))) - (.write w end))))) - -(defn- print-meta [o, #^Writer w] - (when-let [m (meta o)] - (when (and (pos? (count m)) - (or *print-dup* - (and *print-meta* *print-readably*))) - (.write w "#^") - (if (and (= (count m) 1) (:tag m)) - (pr-on (:tag m) w) - (pr-on m w)) - (.write w " ")))) - -(defmethod print-method :default [o, #^Writer w] - (print-method (vary-meta o #(dissoc % :type)) w)) - -(defmethod print-method nil [o, #^Writer w] - (.write w "nil")) - -(defmethod print-dup nil [o w] (print-method o w)) - -(defn print-ctor [o print-args #^Writer w] - (.write w "#=(") - (.write w (.getName #^Class (class o))) - (.write w ". ") - (print-args o w) - (.write w ")")) - -(defmethod print-method Object [o, #^Writer w] - (.write w "#<") - (.write w (.getSimpleName (class o))) - (.write w " ") - (.write w (str o)) - (.write w ">")) - -(defmethod print-method clojure.lang.Keyword [o, #^Writer w] - (.write w (str o))) - -(defmethod print-dup clojure.lang.Keyword [o w] (print-method o w)) - -(defmethod print-method Number [o, #^Writer w] - (.write w (str o))) - -(defmethod print-dup Number [o, #^Writer w] - (print-ctor o - (fn [o w] - (print-dup (str o) w)) - w)) - -(defmethod print-dup clojure.lang.Fn [o, #^Writer w] - (print-ctor o (fn [o w]) w)) - -(prefer-method print-dup clojure.lang.IPersistentCollection clojure.lang.Fn) -(prefer-method print-dup java.util.Map clojure.lang.Fn) -(prefer-method print-dup java.util.Collection clojure.lang.Fn) - -(defmethod print-method Boolean [o, #^Writer w] - (.write w (str o))) - -(defmethod print-dup Boolean [o w] (print-method o w)) - -(defn print-simple [o, #^Writer w] - (print-meta o w) - (.write w (str o))) - -(defmethod print-method clojure.lang.Symbol [o, #^Writer w] - (print-simple o w)) - -(defmethod print-dup clojure.lang.Symbol [o w] (print-method o w)) - -(defmethod print-method clojure.lang.Var [o, #^Writer w] - (print-simple o w)) - -(defmethod print-dup clojure.lang.Var [#^clojure.lang.Var o, #^Writer w] - (.write w (str "#=(var " (.name (.ns o)) "/" (.sym o) ")"))) - -(defmethod print-method clojure.lang.ISeq [o, #^Writer w] - (print-meta o w) - (print-sequential "(" pr-on " " ")" o w)) - -(defmethod print-dup clojure.lang.ISeq [o w] (print-method o w)) -(defmethod print-dup clojure.lang.IPersistentList [o w] (print-method o w)) -(prefer-method print-method clojure.lang.IPersistentList clojure.lang.ISeq) -(prefer-method print-dup clojure.lang.IPersistentList clojure.lang.ISeq) -(prefer-method print-method clojure.lang.ISeq clojure.lang.IPersistentCollection) -(prefer-method print-dup clojure.lang.ISeq clojure.lang.IPersistentCollection) -(prefer-method print-method clojure.lang.ISeq java.util.Collection) -(prefer-method print-dup clojure.lang.ISeq java.util.Collection) - -(defmethod print-method clojure.lang.IPersistentList [o, #^Writer w] - (print-meta o w) - (print-sequential "(" print-method " " ")" o w)) - - -(defmethod print-dup java.util.Collection [o, #^Writer w] - (print-ctor o #(print-sequential "[" print-dup " " "]" %1 %2) w)) - -(defmethod print-dup clojure.lang.IPersistentCollection [o, #^Writer w] - (print-meta o w) - (.write w "#=(") - (.write w (.getName #^Class (class o))) - (.write w "/create ") - (print-sequential "[" print-dup " " "]" o w) - (.write w ")")) - -(prefer-method print-dup clojure.lang.IPersistentCollection java.util.Collection) - -(def #^{:tag String - :doc "Returns escape string for char or nil if none"} - char-escape-string - {\newline "\\n" - \tab "\\t" - \return "\\r" - \" "\\\"" - \\ "\\\\" - \formfeed "\\f" - \backspace "\\b"}) - -(defmethod print-method String [#^String s, #^Writer w] - (if (or *print-dup* *print-readably*) - (do (.append w \") - (dotimes [n (count s)] - (let [c (.charAt s n) - e (char-escape-string c)] - (if e (.write w e) (.append w c)))) - (.append w \")) - (.write w s)) - nil) - -(defmethod print-dup String [s w] (print-method s w)) - -(defmethod print-method clojure.lang.IPersistentVector [v, #^Writer w] - (print-meta v w) - (print-sequential "[" pr-on " " "]" v w)) - -(defn- print-map [m print-one w] - (print-sequential - "{" - (fn [e #^Writer w] - (do (print-one (key e) w) (.append w \space) (print-one (val e) w))) - ", " - "}" - (seq m) w)) - -(defmethod print-method clojure.lang.IPersistentMap [m, #^Writer w] - (print-meta m w) - (print-map m pr-on w)) - -(defmethod print-dup java.util.Map [m, #^Writer w] - (print-ctor m #(print-map (seq %1) print-dup %2) w)) - -(defmethod print-dup clojure.lang.IPersistentMap [m, #^Writer w] - (print-meta m w) - (.write w "#=(") - (.write w (.getName (class m))) - (.write w "/create ") - (print-map m print-dup w) - (.write w ")")) - -(prefer-method print-dup clojure.lang.IPersistentCollection java.util.Map) - -(defmethod print-method clojure.lang.IPersistentSet [s, #^Writer w] - (print-meta s w) - (print-sequential "#{" pr-on " " "}" (seq s) w)) - -(def #^{:tag String - :doc "Returns name string for char or nil if none"} - char-name-string - {\newline "newline" - \tab "tab" - \space "space" - \backspace "backspace" - \formfeed "formfeed" - \return "return"}) - -(defmethod print-method java.lang.Character [#^Character c, #^Writer w] - (if (or *print-dup* *print-readably*) - (do (.append w \\) - (let [n (char-name-string c)] - (if n (.write w n) (.append w c)))) - (.append w c)) - nil) - -(defmethod print-dup java.lang.Character [c w] (print-method c w)) -(defmethod print-dup java.lang.Integer [o w] (print-method o w)) -(defmethod print-dup java.lang.Double [o w] (print-method o w)) -(defmethod print-dup clojure.lang.Ratio [o w] (print-method o w)) -(defmethod print-dup java.math.BigDecimal [o w] (print-method o w)) -(defmethod print-dup clojure.lang.PersistentHashMap [o w] (print-method o w)) -(defmethod print-dup clojure.lang.PersistentHashSet [o w] (print-method o w)) -(defmethod print-dup clojure.lang.PersistentVector [o w] (print-method o w)) -(defmethod print-dup clojure.lang.LazilyPersistentVector [o w] (print-method o w)) - -(def primitives-classnames - {Float/TYPE "Float/TYPE" - Integer/TYPE "Integer/TYPE" - Long/TYPE "Long/TYPE" - Boolean/TYPE "Boolean/TYPE" - Character/TYPE "Character/TYPE" - Double/TYPE "Double/TYPE" - Byte/TYPE "Byte/TYPE" - Short/TYPE "Short/TYPE"}) - -(defmethod print-method Class [#^Class c, #^Writer w] - (.write w (.getName c))) - -(defmethod print-dup Class [#^Class c, #^Writer w] - (cond - (.isPrimitive c) (do - (.write w "#=(identity ") - (.write w #^String (primitives-classnames c)) - (.write w ")")) - (.isArray c) (do - (.write w "#=(java.lang.Class/forName \"") - (.write w (.getName c)) - (.write w "\")")) - :else (do - (.write w "#=") - (.write w (.getName c))))) - -(defmethod print-method java.math.BigDecimal [b, #^Writer w] - (.write w (str b)) - (.write w "M")) - -(defmethod print-method java.util.regex.Pattern [p #^Writer w] - (.write w "#\"") - (loop [[#^Character c & r :as s] (seq (.pattern #^java.util.regex.Pattern p)) - qmode false] - (when s - (cond - (= c \\) (let [[#^Character c2 & r2] r] - (.append w \\) - (.append w c2) - (if qmode - (recur r2 (not= c2 \E)) - (recur r2 (= c2 \Q)))) - (= c \") (do - (if qmode - (.write w "\\E\\\"\\Q") - (.write w "\\\"")) - (recur r qmode)) - :else (do - (.append w c) - (recur r qmode))))) - (.append w \")) - -(defmethod print-dup java.util.regex.Pattern [p #^Writer w] (print-method p w)) - -(defmethod print-dup clojure.lang.Namespace [#^clojure.lang.Namespace n #^Writer w] - (.write w "#=(find-ns ") - (print-dup (.name n) w) - (.write w ")")) - -(defmethod print-method clojure.lang.IDeref [o #^Writer w] - (print-sequential (format "#<%s@%x: " - (.getSimpleName (class o)) - (System/identityHashCode o)) - pr-on, "", ">", (list @o), w)) - -(def #^{:private true} print-initialized true) -; 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. - -(in-ns 'clojure.core) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;; proxy ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(import - '(clojure.asm ClassWriter ClassVisitor Opcodes Type) - '(java.lang.reflect Modifier Constructor) - '(clojure.asm.commons Method GeneratorAdapter) - '(clojure.lang IProxy Reflector DynamicClassLoader IPersistentMap PersistentHashMap RT)) - -(defn method-sig [#^java.lang.reflect.Method meth] - [(. meth (getName)) (seq (. meth (getParameterTypes))) (. meth getReturnType)]) - -(defn- most-specific [rtypes] - (or (some (fn [t] (when (every? #(isa? t %) rtypes) t)) rtypes) - (throw (Exception. "Incompatible return types")))) - -(defn- group-by-sig [coll] - "takes a collection of [msig meth] and returns a seq of maps from return-types to meths." - (vals (reduce (fn [m [msig meth]] - (let [rtype (peek msig) - argsig (pop msig)] - (assoc m argsig (assoc (m argsig {}) rtype meth)))) - {} coll))) - -(defn proxy-name - {:tag String} - [#^Class super interfaces] - (apply str "clojure.proxy." - (.getName super) - (interleave (repeat "$") - (sort (map #(.getSimpleName #^Class %) interfaces))))) - -(defn- generate-proxy [#^Class super interfaces] - (let [cv (new ClassWriter (. ClassWriter COMPUTE_MAXS)) - cname (.replace (proxy-name super interfaces) \. \/) ;(str "clojure/lang/" (gensym "Proxy__")) - ctype (. Type (getObjectType cname)) - iname (fn [#^Class c] (.. Type (getType c) (getInternalName))) - fmap "__clojureFnMap" - totype (fn [#^Class c] (. Type (getType c))) - to-types (fn [cs] (if (pos? (count cs)) - (into-array (map totype cs)) - (make-array Type 0))) - super-type #^Type (totype super) - imap-type #^Type (totype IPersistentMap) - ifn-type (totype clojure.lang.IFn) - obj-type (totype Object) - sym-type (totype clojure.lang.Symbol) - rt-type (totype clojure.lang.RT) - ex-type (totype java.lang.UnsupportedOperationException) - gen-bridge - (fn [#^java.lang.reflect.Method meth #^java.lang.reflect.Method dest] - (let [pclasses (. meth (getParameterTypes)) - ptypes (to-types pclasses) - rtype #^Type (totype (. meth (getReturnType))) - m (new Method (. meth (getName)) rtype ptypes) - dtype (totype (.getDeclaringClass dest)) - dm (new Method (. dest (getName)) (totype (. dest (getReturnType))) (to-types (. dest (getParameterTypes)))) - gen (new GeneratorAdapter (bit-or (. Opcodes ACC_PUBLIC) (. Opcodes ACC_BRIDGE)) m nil nil cv)] - (. gen (visitCode)) - (. gen (loadThis)) - (dotimes [i (count ptypes)] - (. gen (loadArg i))) - (if (-> dest .getDeclaringClass .isInterface) - (. gen (invokeInterface dtype dm)) - (. gen (invokeVirtual dtype dm))) - (. gen (returnValue)) - (. gen (endMethod)))) - gen-method - (fn [#^java.lang.reflect.Method meth else-gen] - (let [pclasses (. meth (getParameterTypes)) - ptypes (to-types pclasses) - rtype #^Type (totype (. meth (getReturnType))) - m (new Method (. meth (getName)) rtype ptypes) - gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv) - else-label (. gen (newLabel)) - end-label (. gen (newLabel)) - decl-type (. Type (getType (. meth (getDeclaringClass))))] - (. gen (visitCode)) - (if (> (count pclasses) 18) - (else-gen gen m) - (do - (. gen (loadThis)) - (. gen (getField ctype fmap imap-type)) - - (. gen (push (. meth (getName)))) - ;lookup fn in map - (. gen (invokeStatic rt-type (. Method (getMethod "Object get(Object, Object)")))) - (. gen (dup)) - (. gen (ifNull else-label)) - ;if found - (.checkCast gen ifn-type) - (. gen (loadThis)) - ;box args - (dotimes [i (count ptypes)] - (. gen (loadArg i)) - (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) - ;call fn - (. gen (invokeInterface ifn-type (new Method "invoke" obj-type - (into-array (cons obj-type - (replicate (count ptypes) obj-type)))))) - ;unbox return - (. gen (unbox rtype)) - (when (= (. rtype (getSort)) (. Type VOID)) - (. gen (pop))) - (. gen (goTo end-label)) - - ;else call supplied alternative generator - (. gen (mark else-label)) - (. gen (pop)) - - (else-gen gen m) - - (. gen (mark end-label)))) - (. gen (returnValue)) - (. gen (endMethod))))] - - ;start class definition - (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER)) - cname nil (iname super) - (into-array (map iname (cons IProxy interfaces))))) - ;add field for fn mappings - (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_VOLATILE)) - fmap (. imap-type (getDescriptor)) nil nil)) - ;add ctors matching/calling super's - (doseq [#^Constructor ctor (. super (getDeclaredConstructors))] - (when-not (. Modifier (isPrivate (. ctor (getModifiers)))) - (let [ptypes (to-types (. ctor (getParameterTypes))) - m (new Method "<init>" (. Type VOID_TYPE) ptypes) - gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] - (. gen (visitCode)) - ;call super ctor - (. gen (loadThis)) - (. gen (dup)) - (. gen (loadArgs)) - (. gen (invokeConstructor super-type m)) - - (. gen (returnValue)) - (. gen (endMethod))))) - ;add IProxy methods - (let [m (. Method (getMethod "void __initClojureFnMappings(clojure.lang.IPersistentMap)")) - gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] - (. gen (visitCode)) - (. gen (loadThis)) - (. gen (loadArgs)) - (. gen (putField ctype fmap imap-type)) - - (. gen (returnValue)) - (. gen (endMethod))) - (let [m (. Method (getMethod "void __updateClojureFnMappings(clojure.lang.IPersistentMap)")) - gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] - (. gen (visitCode)) - (. gen (loadThis)) - (. gen (dup)) - (. gen (getField ctype fmap imap-type)) - (.checkCast gen (totype clojure.lang.IPersistentCollection)) - (. gen (loadArgs)) - (. gen (invokeInterface (totype clojure.lang.IPersistentCollection) - (. Method (getMethod "clojure.lang.IPersistentCollection cons(Object)")))) - (. gen (checkCast imap-type)) - (. gen (putField ctype fmap imap-type)) - - (. gen (returnValue)) - (. gen (endMethod))) - (let [m (. Method (getMethod "clojure.lang.IPersistentMap __getClojureFnMappings()")) - gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv)] - (. gen (visitCode)) - (. gen (loadThis)) - (. gen (getField ctype fmap imap-type)) - (. gen (returnValue)) - (. gen (endMethod))) - - ;calc set of supers' non-private instance methods - (let [[mm considered] - (loop [mm {} considered #{} c super] - (if c - (let [[mm considered] - (loop [mm mm - considered considered - meths (concat - (seq (. c (getDeclaredMethods))) - (seq (. c (getMethods))))] - (if (seq meths) - (let [#^java.lang.reflect.Method meth (first meths) - mods (. meth (getModifiers)) - mk (method-sig meth)] - (if (or (considered mk) - (not (or (Modifier/isPublic mods) (Modifier/isProtected mods))) - ;(. Modifier (isPrivate mods)) - (. Modifier (isStatic mods)) - (. Modifier (isFinal mods)) - (= "finalize" (.getName meth))) - (recur mm (conj considered mk) (next meths)) - (recur (assoc mm mk meth) (conj considered mk) (next meths)))) - [mm considered]))] - (recur mm considered (. c (getSuperclass)))) - [mm considered])) - ifaces-meths (into {} - (for [#^Class iface interfaces meth (. iface (getMethods)) - :let [msig (method-sig meth)] :when (not (considered msig))] - {msig meth})) - mgroups (group-by-sig (concat mm ifaces-meths)) - rtypes (map #(most-specific (keys %)) mgroups) - mb (map #(vector (%1 %2) (vals (dissoc %1 %2))) mgroups rtypes) - bridge? (reduce into #{} (map second mb)) - ifaces-meths (remove bridge? (vals ifaces-meths)) - mm (remove bridge? (vals mm))] - ;add methods matching supers', if no mapping -> call super - (doseq [[#^java.lang.reflect.Method dest bridges] mb - #^java.lang.reflect.Method meth bridges] - (gen-bridge meth dest)) - (doseq [#^java.lang.reflect.Method meth mm] - (gen-method meth - (fn [#^GeneratorAdapter gen #^Method m] - (. gen (loadThis)) - ;push args - (. gen (loadArgs)) - ;call super - (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) - (. super-type (getInternalName)) - (. m (getName)) - (. m (getDescriptor))))))) - - ;add methods matching interfaces', if no mapping -> throw - (doseq [#^java.lang.reflect.Method meth ifaces-meths] - (gen-method meth - (fn [#^GeneratorAdapter gen #^Method m] - (. gen (throwException ex-type (. m (getName)))))))) - - ;finish class def - (. cv (visitEnd)) - [cname (. cv toByteArray)])) - -(defn- get-super-and-interfaces [bases] - (if (. #^Class (first bases) (isInterface)) - [Object bases] - [(first bases) (next bases)])) - -(defn get-proxy-class - "Takes an optional single class followed by zero or more - interfaces. If not supplied class defaults to Object. Creates an - returns an instance of a proxy class derived from the supplied - classes. The resulting value is cached and used for any subsequent - requests for the same class set. Returns a Class object." - [& bases] - (let [[super interfaces] (get-super-and-interfaces bases) - pname (proxy-name super interfaces)] - (or (RT/loadClassForName pname) - (let [[cname bytecode] (generate-proxy super interfaces)] - (. (RT/getRootClassLoader) (defineClass pname bytecode)))))) - -(defn construct-proxy - "Takes a proxy class and any arguments for its superclass ctor and - creates and returns an instance of the proxy." - [c & ctor-args] - (. Reflector (invokeConstructor c (to-array ctor-args)))) - -(defn init-proxy - "Takes a proxy instance and a map of strings (which must - correspond to methods of the proxy superclass/superinterfaces) to - fns (which must take arguments matching the corresponding method, - plus an additional (explicit) first arg corresponding to this, and - sets the proxy's fn map." - [#^IProxy proxy mappings] - (. proxy (__initClojureFnMappings mappings))) - -(defn update-proxy - "Takes a proxy instance and a map of strings (which must - correspond to methods of the proxy superclass/superinterfaces) to - fns (which must take arguments matching the corresponding method, - plus an additional (explicit) first arg corresponding to this, and - updates (via assoc) the proxy's fn map. nil can be passed instead of - a fn, in which case the corresponding method will revert to the - default behavior. Note that this function can be used to update the - behavior of an existing instance without changing its identity." - [#^IProxy proxy mappings] - (. proxy (__updateClojureFnMappings mappings))) - -(defn proxy-mappings - "Takes a proxy instance and returns the proxy's fn map." - [#^IProxy proxy] - (. proxy (__getClojureFnMappings))) - -(defmacro proxy - "class-and-interfaces - a vector of class names - - args - a (possibly empty) vector of arguments to the superclass - constructor. - - f => (name [params*] body) or - (name ([params*] body) ([params+] body) ...) - - Expands to code which creates a instance of a proxy class that - implements the named class/interface(s) by calling the supplied - fns. A single class, if provided, must be first. If not provided it - defaults to Object. - - The interfaces names must be valid interface types. If a method fn - is not provided for a class method, the superclass methd will be - called. If a method fn is not provided for an interface method, an - UnsupportedOperationException will be thrown should it be - called. Method fns are closures and can capture the environment in - which proxy is called. Each method fn takes an additional implicit - first arg, which is bound to 'this. Note that while method fns can - be provided to override protected methods, they have no other access - to protected members, nor to super, as these capabilities cannot be - proxied." - [class-and-interfaces args & fs] - (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %)))) - class-and-interfaces) - [super interfaces] (get-super-and-interfaces bases) - compile-effect (when *compile-files* - (let [[cname bytecode] (generate-proxy super interfaces)] - (clojure.lang.Compiler/writeClassFile cname bytecode))) - pc-effect (apply get-proxy-class bases) - pname (proxy-name super interfaces)] - `(let [;pc# (get-proxy-class ~@class-and-interfaces) - p# (new ~(symbol pname) ~@args)] ;(construct-proxy pc# ~@args)] - (init-proxy p# - ~(loop [fmap {} fs fs] - (if fs - (let [[sym & meths] (first fs) - meths (if (vector? (first meths)) - (list meths) - meths) - meths (map (fn [[params & body]] - (cons (apply vector 'this params) body)) - meths)] - (if-not (contains? fmap (name sym)) - (recur (assoc fmap (name sym) (cons `fn meths)) (next fs)) - (throw (IllegalArgumentException. - (str "Method '" (name sym) "' redefined"))))) - fmap))) - p#))) - -(defn proxy-call-with-super [call this meth] - (let [m (proxy-mappings this)] - (update-proxy this (assoc m meth nil)) - (let [ret (call)] - (update-proxy this m) - ret))) - -(defmacro proxy-super - "Use to call a superclass method in the body of a proxy method. - Note, expansion captures 'this" - [meth & args] - `(proxy-call-with-super (fn [] (. ~'this ~meth ~@args)) ~'this ~(name meth))) - -(defn bean - "Takes a Java object and returns a read-only implementation of the - map abstraction based upon its JavaBean properties." - [#^Object x] - (let [c (. x (getClass)) - pmap (reduce (fn [m #^java.beans.PropertyDescriptor pd] - (let [name (. pd (getName)) - method (. pd (getReadMethod))] - (if (and method (zero? (alength (. method (getParameterTypes))))) - (assoc m (keyword name) (fn [] (clojure.lang.Reflector/prepRet (. method (invoke x nil))))) - m))) - {} - (seq (.. java.beans.Introspector - (getBeanInfo c) - (getPropertyDescriptors)))) - v (fn [k] ((pmap k))) - snapshot (fn [] - (reduce (fn [m e] - (assoc m (key e) ((val e)))) - {} (seq pmap)))] - (proxy [clojure.lang.APersistentMap] - [] - (containsKey [k] (contains? pmap k)) - (entryAt [k] (when (contains? pmap k) (new clojure.lang.MapEntry k (v k)))) - (valAt ([k] (v k)) - ([k default] (if (contains? pmap k) (v k) default))) - (cons [m] (conj (snapshot) m)) - (count [] (count pmap)) - (assoc [k v] (assoc (snapshot) k v)) - (without [k] (dissoc (snapshot) k)) - (seq [] ((fn thisfn [plseq] - (lazy-seq - (when-let [pseq (seq plseq)] - (cons (new clojure.lang.MapEntry (first pseq) (v (first pseq))) - (thisfn (rest pseq)))))) (keys pmap)))))) - - - -; 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. - -(in-ns 'clojure.core) - -(import '(java.lang.reflect Modifier Constructor) - '(clojure.asm ClassWriter ClassVisitor Opcodes Type) - '(clojure.asm.commons Method GeneratorAdapter) - '(clojure.lang IPersistentMap)) - -;(defn method-sig [#^java.lang.reflect.Method meth] -; [(. meth (getName)) (seq (. meth (getParameterTypes)))]) - -(defn- non-private-methods [#^Class c] - (loop [mm {} - considered #{} - c c] - (if c - (let [[mm considered] - (loop [mm mm - considered considered - meths (seq (concat - (seq (. c (getDeclaredMethods))) - (seq (. c (getMethods)))))] - (if meths - (let [#^java.lang.reflect.Method meth (first meths) - mods (. meth (getModifiers)) - mk (method-sig meth)] - (if (or (considered mk) - (not (or (Modifier/isPublic mods) (Modifier/isProtected mods))) - ;(. Modifier (isPrivate mods)) - (. Modifier (isStatic mods)) - (. Modifier (isFinal mods)) - (= "finalize" (.getName meth))) - (recur mm (conj considered mk) (next meths)) - (recur (assoc mm mk meth) (conj considered mk) (next meths)))) - [mm considered]))] - (recur mm considered (. c (getSuperclass)))) - mm))) - -(defn- ctor-sigs [#^Class super] - (for [#^Constructor ctor (. super (getDeclaredConstructors)) - :when (not (. Modifier (isPrivate (. ctor (getModifiers)))))] - (apply vector (. ctor (getParameterTypes))))) - -(defn- escape-class-name [#^Class c] - (.. (.getSimpleName c) - (replace "[]" "<>"))) - -(defn- overload-name [mname pclasses] - (if (seq pclasses) - (apply str mname (interleave (repeat \-) - (map escape-class-name pclasses))) - (str mname "-void"))) - -(defn- #^java.lang.reflect.Field find-field [#^Class c f] - (let [start-class c] - (loop [c c] - (if (= c Object) - (throw (new Exception (str "field, " f ", not defined in class, " start-class ", or its ancestors"))) - (let [dflds (.getDeclaredFields c) - rfld (first (filter #(= f (.getName #^java.lang.reflect.Field %)) dflds))] - (or rfld (recur (.getSuperclass c)))))))) - -;(distinct (map first(keys (mapcat non-private-methods [Object IPersistentMap])))) - -(def #^{:private true} prim->class - {'int Integer/TYPE - 'long Long/TYPE - 'float Float/TYPE - 'double Double/TYPE - 'void Void/TYPE - 'short Short/TYPE - 'boolean Boolean/TYPE - 'byte Byte/TYPE - 'char Character/TYPE}) - -(defn- #^Class the-class [x] - (cond - (class? x) x - (contains? prim->class x) (prim->class x) - :else (let [strx (str x)] - (clojure.lang.RT/classForName - (if (some #{\.} strx) - strx - (str "java.lang." strx)))))) - -(defn- generate-class [options-map] - (let [default-options {:prefix "-" :load-impl-ns true :impl-ns (ns-name *ns*)} - {:keys [name extends implements constructors methods main factory state init exposes - exposes-methods prefix load-impl-ns impl-ns post-init]} - (merge default-options options-map) - name (str name) - super (if extends (the-class extends) Object) - interfaces (map the-class implements) - supers (cons super interfaces) - ctor-sig-map (or constructors (zipmap (ctor-sigs super) (ctor-sigs super))) - cv (new ClassWriter (. ClassWriter COMPUTE_MAXS)) - cname (. name (replace "." "/")) - pkg-name name - impl-pkg-name (str impl-ns) - impl-cname (.. impl-pkg-name (replace "." "/") (replace \- \_)) - ctype (. Type (getObjectType cname)) - iname (fn [#^Class c] (.. Type (getType c) (getInternalName))) - totype (fn [#^Class c] (. Type (getType c))) - to-types (fn [cs] (if (pos? (count cs)) - (into-array (map totype cs)) - (make-array Type 0))) - obj-type #^Type (totype Object) - arg-types (fn [n] (if (pos? n) - (into-array (replicate n obj-type)) - (make-array Type 0))) - super-type #^Type (totype super) - init-name (str init) - post-init-name (str post-init) - factory-name (str factory) - state-name (str state) - main-name "main" - var-name (fn [s] (str s "__var")) - class-type (totype Class) - rt-type (totype clojure.lang.RT) - var-type #^Type (totype clojure.lang.Var) - ifn-type (totype clojure.lang.IFn) - iseq-type (totype clojure.lang.ISeq) - ex-type (totype java.lang.UnsupportedOperationException) - all-sigs (distinct (concat (map #(let[[m p] (key %)] {m [p]}) (mapcat non-private-methods supers)) - (map (fn [[m p]] {(str m) [p]}) methods))) - sigs-by-name (apply merge-with concat {} all-sigs) - overloads (into {} (filter (fn [[m s]] (next s)) sigs-by-name)) - var-fields (concat (when init [init-name]) - (when post-init [post-init-name]) - (when main [main-name]) - ;(when exposes-methods (map str (vals exposes-methods))) - (distinct (concat (keys sigs-by-name) - (mapcat (fn [[m s]] (map #(overload-name m (map the-class %)) s)) overloads) - (mapcat (comp (partial map str) vals val) exposes)))) - emit-get-var (fn [#^GeneratorAdapter gen v] - (let [false-label (. gen newLabel) - end-label (. gen newLabel)] - (. gen getStatic ctype (var-name v) var-type) - (. gen dup) - (. gen invokeVirtual var-type (. Method (getMethod "boolean isBound()"))) - (. gen ifZCmp (. GeneratorAdapter EQ) false-label) - (. gen invokeVirtual var-type (. Method (getMethod "Object get()"))) - (. gen goTo end-label) - (. gen mark false-label) - (. gen pop) - (. gen visitInsn (. Opcodes ACONST_NULL)) - (. gen mark end-label))) - emit-unsupported (fn [#^GeneratorAdapter gen #^Method m] - (. gen (throwException ex-type (str (. m (getName)) " (" - impl-pkg-name "/" prefix (.getName m) - " not defined?)")))) - emit-forwarding-method - (fn [mname pclasses rclass as-static else-gen] - (let [pclasses (map the-class pclasses) - rclass (the-class rclass) - ptypes (to-types pclasses) - rtype #^Type (totype rclass) - m (new Method mname rtype ptypes) - is-overload (seq (overloads mname)) - gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (if as-static (. Opcodes ACC_STATIC) 0)) - m nil nil cv) - found-label (. gen (newLabel)) - else-label (. gen (newLabel)) - end-label (. gen (newLabel))] - (. gen (visitCode)) - (if (> (count pclasses) 18) - (else-gen gen m) - (do - (when is-overload - (emit-get-var gen (overload-name mname pclasses)) - (. gen (dup)) - (. gen (ifNonNull found-label)) - (. gen (pop))) - (emit-get-var gen mname) - (. gen (dup)) - (. gen (ifNull else-label)) - (when is-overload - (. gen (mark found-label))) - ;if found - (.checkCast gen ifn-type) - (when-not as-static - (. gen (loadThis))) - ;box args - (dotimes [i (count ptypes)] - (. gen (loadArg i)) - (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) - ;call fn - (. gen (invokeInterface ifn-type (new Method "invoke" obj-type - (to-types (replicate (+ (count ptypes) - (if as-static 0 1)) - Object))))) - ;(into-array (cons obj-type - ; (replicate (count ptypes) obj-type)))))) - ;unbox return - (. gen (unbox rtype)) - (when (= (. rtype (getSort)) (. Type VOID)) - (. gen (pop))) - (. gen (goTo end-label)) - - ;else call supplied alternative generator - (. gen (mark else-label)) - (. gen (pop)) - - (else-gen gen m) - - (. gen (mark end-label)))) - (. gen (returnValue)) - (. gen (endMethod)))) - ] - ;start class definition - (. cv (visit (. Opcodes V1_5) (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_SUPER)) - cname nil (iname super) - (when-let [ifc (seq interfaces)] - (into-array (map iname ifc))))) - - ;static fields for vars - (doseq [v var-fields] - (. cv (visitField (+ (. Opcodes ACC_PRIVATE) (. Opcodes ACC_FINAL) (. Opcodes ACC_STATIC)) - (var-name v) - (. var-type getDescriptor) - nil nil))) - - ;instance field for state - (when state - (. cv (visitField (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_FINAL)) - state-name - (. obj-type getDescriptor) - nil nil))) - - ;static init to set up var fields and load init - (let [gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) - (. Method getMethod "void <clinit> ()") - nil nil cv)] - (. gen (visitCode)) - (doseq [v var-fields] - (. gen push impl-pkg-name) - (. gen push (str prefix v)) - (. gen (invokeStatic var-type (. Method (getMethod "clojure.lang.Var internPrivate(String,String)")))) - (. gen putStatic ctype (var-name v) var-type)) - - (when load-impl-ns - (. gen push "clojure.core") - (. gen push "load") - (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.Var var(String,String)")))) - (. gen push (str "/" impl-cname)) - (. gen (invokeInterface ifn-type (new Method "invoke" obj-type (to-types [Object])))) -; (. gen push (str (.replace impl-pkg-name \- \_) "__init")) -; (. gen (invokeStatic class-type (. Method (getMethod "Class forName(String)")))) - (. gen pop)) - - (. gen (returnValue)) - (. gen (endMethod))) - - ;ctors - (doseq [[pclasses super-pclasses] ctor-sig-map] - (let [pclasses (map the-class pclasses) - super-pclasses (map the-class super-pclasses) - ptypes (to-types pclasses) - super-ptypes (to-types super-pclasses) - m (new Method "<init>" (. Type VOID_TYPE) ptypes) - super-m (new Method "<init>" (. Type VOID_TYPE) super-ptypes) - gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) m nil nil cv) - no-init-label (. gen newLabel) - end-label (. gen newLabel) - no-post-init-label (. gen newLabel) - end-post-init-label (. gen newLabel) - nth-method (. Method (getMethod "Object nth(Object,int)")) - local (. gen newLocal obj-type)] - (. gen (visitCode)) - - (if init - (do - (emit-get-var gen init-name) - (. gen dup) - (. gen ifNull no-init-label) - (.checkCast gen ifn-type) - ;box init args - (dotimes [i (count pclasses)] - (. gen (loadArg i)) - (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) - ;call init fn - (. gen (invokeInterface ifn-type (new Method "invoke" obj-type - (arg-types (count ptypes))))) - ;expecting [[super-ctor-args] state] returned - (. gen dup) - (. gen push 0) - (. gen (invokeStatic rt-type nth-method)) - (. gen storeLocal local) - - (. gen (loadThis)) - (. gen dupX1) - (dotimes [i (count super-pclasses)] - (. gen loadLocal local) - (. gen push i) - (. gen (invokeStatic rt-type nth-method)) - (. clojure.lang.Compiler$HostExpr (emitUnboxArg nil gen (nth super-pclasses i)))) - (. gen (invokeConstructor super-type super-m)) - - (if state - (do - (. gen push 1) - (. gen (invokeStatic rt-type nth-method)) - (. gen (putField ctype state-name obj-type))) - (. gen pop)) - - (. gen goTo end-label) - ;no init found - (. gen mark no-init-label) - (. gen (throwException ex-type (str impl-pkg-name "/" prefix init-name " not defined"))) - (. gen mark end-label)) - (if (= pclasses super-pclasses) - (do - (. gen (loadThis)) - (. gen (loadArgs)) - (. gen (invokeConstructor super-type super-m))) - (throw (new Exception ":init not specified, but ctor and super ctor args differ")))) - - (when post-init - (emit-get-var gen post-init-name) - (. gen dup) - (. gen ifNull no-post-init-label) - (.checkCast gen ifn-type) - (. gen (loadThis)) - ;box init args - (dotimes [i (count pclasses)] - (. gen (loadArg i)) - (. clojure.lang.Compiler$HostExpr (emitBoxReturn nil gen (nth pclasses i)))) - ;call init fn - (. gen (invokeInterface ifn-type (new Method "invoke" obj-type - (arg-types (inc (count ptypes)))))) - (. gen pop) - (. gen goTo end-post-init-label) - ;no init found - (. gen mark no-post-init-label) - (. gen (throwException ex-type (str impl-pkg-name "/" prefix post-init-name " not defined"))) - (. gen mark end-post-init-label)) - - (. gen (returnValue)) - (. gen (endMethod)) - ;factory - (when factory - (let [fm (new Method factory-name ctype ptypes) - gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) - fm nil nil cv)] - (. gen (visitCode)) - (. gen newInstance ctype) - (. gen dup) - (. gen (loadArgs)) - (. gen (invokeConstructor ctype m)) - (. gen (returnValue)) - (. gen (endMethod)))))) - - ;add methods matching supers', if no fn -> call super - (let [mm (non-private-methods super)] - (doseq [#^java.lang.reflect.Method meth (vals mm)] - (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false - (fn [#^GeneratorAdapter gen #^Method m] - (. gen (loadThis)) - ;push args - (. gen (loadArgs)) - ;call super - (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) - (. super-type (getInternalName)) - (. m (getName)) - (. m (getDescriptor))))))) - ;add methods matching interfaces', if no fn -> throw - (reduce (fn [mm #^java.lang.reflect.Method meth] - (if (contains? mm (method-sig meth)) - mm - (do - (emit-forwarding-method (.getName meth) (.getParameterTypes meth) (.getReturnType meth) false - emit-unsupported) - (assoc mm (method-sig meth) meth)))) - mm (mapcat #(.getMethods #^Class %) interfaces)) - ;extra methods - (doseq [[mname pclasses rclass :as msig] methods] - (emit-forwarding-method (str mname) pclasses rclass (:static ^msig) - emit-unsupported)) - ;expose specified overridden superclass methods - (doseq [[local-mname #^java.lang.reflect.Method m] (reduce (fn [ms [[name _ _] m]] - (if (contains? exposes-methods (symbol name)) - (conj ms [((symbol name) exposes-methods) m]) - ms)) [] (seq mm))] - (let [ptypes (to-types (.getParameterTypes m)) - rtype (totype (.getReturnType m)) - exposer-m (new Method (str local-mname) rtype ptypes) - target-m (new Method (.getName m) rtype ptypes) - gen (new GeneratorAdapter (. Opcodes ACC_PUBLIC) exposer-m nil nil cv)] - (. gen (loadThis)) - (. gen (loadArgs)) - (. gen (visitMethodInsn (. Opcodes INVOKESPECIAL) - (. super-type (getInternalName)) - (. target-m (getName)) - (. target-m (getDescriptor)))) - (. gen (returnValue)) - (. gen (endMethod))))) - ;main - (when main - (let [m (. Method getMethod "void main (String[])") - gen (new GeneratorAdapter (+ (. Opcodes ACC_PUBLIC) (. Opcodes ACC_STATIC)) - m nil nil cv) - no-main-label (. gen newLabel) - end-label (. gen newLabel)] - (. gen (visitCode)) - - (emit-get-var gen main-name) - (. gen dup) - (. gen ifNull no-main-label) - (.checkCast gen ifn-type) - (. gen loadArgs) - (. gen (invokeStatic rt-type (. Method (getMethod "clojure.lang.ISeq seq(Object)")))) - (. gen (invokeInterface ifn-type (new Method "applyTo" obj-type - (into-array [iseq-type])))) - (. gen pop) - (. gen goTo end-label) - ;no main found - (. gen mark no-main-label) - (. gen (throwException ex-type (str impl-pkg-name "/" prefix main-name " not defined"))) - (. gen mark end-label) - (. gen (returnValue)) - (. gen (endMethod)))) - ;field exposers - (doseq [[f {getter :get setter :set}] exposes] - (let [fld (find-field super (str f)) - ftype (totype (.getType fld)) - static? (Modifier/isStatic (.getModifiers fld)) - acc (+ Opcodes/ACC_PUBLIC (if static? Opcodes/ACC_STATIC 0))] - (when getter - (let [m (new Method (str getter) ftype (to-types [])) - gen (new GeneratorAdapter acc m nil nil cv)] - (. gen (visitCode)) - (if static? - (. gen getStatic ctype (str f) ftype) - (do - (. gen loadThis) - (. gen getField ctype (str f) ftype))) - (. gen (returnValue)) - (. gen (endMethod)))) - (when setter - (let [m (new Method (str setter) Type/VOID_TYPE (into-array [ftype])) - gen (new GeneratorAdapter acc m nil nil cv)] - (. gen (visitCode)) - (if static? - (do - (. gen loadArgs) - (. gen putStatic ctype (str f) ftype)) - (do - (. gen loadThis) - (. gen loadArgs) - (. gen putField ctype (str f) ftype))) - (. gen (returnValue)) - (. gen (endMethod)))))) - ;finish class def - (. cv (visitEnd)) - [cname (. cv (toByteArray))])) - -(defmacro gen-class - "When compiling, generates compiled bytecode for a class with the - given package-qualified :name (which, as all names in these - parameters, can be a string or symbol), and writes the .class file - to the *compile-path* directory. When not compiling, does - nothing. The gen-class construct contains no implementation, as the - implementation will be dynamically sought by the generated class in - functions in an implementing Clojure namespace. Given a generated - class org.mydomain.MyClass with a method named mymethod, gen-class - will generate an implementation that looks for a function named by - (str prefix mymethod) (default prefix: \"-\") in a - Clojure namespace specified by :impl-ns - (defaults to the current namespace). All inherited methods, - generated methods, and init and main functions (see :methods, :init, - and :main below) will be found similarly prefixed. By default, the - static initializer for the generated class will attempt to load the - Clojure support code for the class as a resource from the classpath, - e.g. in the example case, ``org/mydomain/MyClass__init.class``. This - behavior can be controlled by :load-impl-ns - - Note that methods with a maximum of 18 parameters are supported. - - In all subsequent sections taking types, the primitive types can be - referred to by their Java names (int, float etc), and classes in the - java.lang package can be used without a package qualifier. All other - classes must be fully qualified. - - Options should be a set of key/value pairs, all except for :name are optional: - - :name aname - - The package-qualified name of the class to be generated - - :extends aclass - - Specifies the superclass, the non-private methods of which will be - overridden by the class. If not provided, defaults to Object. - - :implements [interface ...] - - One or more interfaces, the methods of which will be implemented by the class. - - :init name - - If supplied, names a function that will be called with the arguments - to the constructor. Must return [ [superclass-constructor-args] state] - If not supplied, the constructor args are passed directly to - the superclass constructor and the state will be nil - - :constructors {[param-types] [super-param-types], ...} - - By default, constructors are created for the generated class which - match the signature(s) of the constructors for the superclass. This - parameter may be used to explicitly specify constructors, each entry - providing a mapping from a constructor signature to a superclass - constructor signature. When you supply this, you must supply an :init - specifier. - - :post-init name - - If supplied, names a function that will be called with the object as - the first argument, followed by the arguments to the constructor. - It will be called every time an object of this class is created, - immediately after all the inherited constructors have completed. - It's return value is ignored. - - :methods [ [name [param-types] return-type], ...] - - The generated class automatically defines all of the non-private - methods of its superclasses/interfaces. This parameter can be used - to specify the signatures of additional methods of the generated - class. Static methods can be specified with #^{:static true} in the - signature's metadata. Do not repeat superclass/interface signatures - here. - - :main boolean - - If supplied and true, a static public main function will be generated. It will - pass each string of the String[] argument as a separate argument to - a function called (str prefix main). - - :factory name - - If supplied, a (set of) public static factory function(s) will be - created with the given name, and the same signature(s) as the - constructor(s). - - :state name - - If supplied, a public final instance field with the given name will be - created. You must supply an :init function in order to provide a - value for the state. Note that, though final, the state can be a ref - or agent, supporting the creation of Java objects with transactional - or asynchronous mutation semantics. - - :exposes {protected-field-name {:get name :set name}, ...} - - Since the implementations of the methods of the generated class - occur in Clojure functions, they have no access to the inherited - protected fields of the superclass. This parameter can be used to - generate public getter/setter methods exposing the protected field(s) - for use in the implementation. - - :exposes-methods {super-method-name exposed-name, ...} - - It is sometimes necessary to call the superclass' implementation of an - overridden method. Those methods may be exposed and referred in - the new method implementation by a local name. - - :prefix string - - Default: \"-\" Methods called e.g. Foo will be looked up in vars called - prefixFoo in the implementing ns. - - :impl-ns name - - Default: the name of the current ns. Implementations of methods will be looked up in this namespace. - - :load-impl-ns boolean - - Default: true. Causes the static initializer for the generated class - to reference the load code for the implementing namespace. Should be - true when implementing-ns is the default, false if you intend to - load the code via some other method." - - [& options] - (when *compile-files* - (let [options-map (apply hash-map options) - [cname bytecode] (generate-class options-map)] - (clojure.lang.Compiler/writeClassFile cname bytecode)))) - -;;;;;;;;;;;;;;;;;;;; gen-interface ;;;;;;;;;;;;;;;;;;;;;; -;; based on original contribution by Chris Houser - -(defn- #^Type asm-type - "Returns an asm Type object for c, which may be a primitive class - (such as Integer/TYPE), any other class (such as Double), or a - fully-qualified class name given as a string or symbol - (such as 'java.lang.String)" - [c] - (if (or (instance? Class c) (prim->class c)) - (Type/getType (the-class c)) - (let [strx (str c)] - (Type/getObjectType - (.replace (if (some #{\.} strx) - strx - (str "java.lang." strx)) - "." "/"))))) - -(defn- generate-interface - [{:keys [name extends methods]}] - (let [iname (.replace (str name) "." "/") - cv (ClassWriter. ClassWriter/COMPUTE_MAXS)] - (. cv visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC - Opcodes/ACC_ABSTRACT - Opcodes/ACC_INTERFACE) - iname nil "java/lang/Object" - (when (seq extends) - (into-array (map #(.getInternalName (asm-type %)) extends)))) - (doseq [[mname pclasses rclass] methods] - (. cv visitMethod (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) - (str mname) - (Type/getMethodDescriptor (asm-type rclass) - (if pclasses - (into-array Type (map asm-type pclasses)) - (make-array Type 0))) - nil nil)) - (. cv visitEnd) - [iname (. cv toByteArray)])) - -(defmacro gen-interface - "When compiling, generates compiled bytecode for an interface with - the given package-qualified :name (which, as all names in these - parameters, can be a string or symbol), and writes the .class file - to the *compile-path* directory. When not compiling, does nothing. - - In all subsequent sections taking types, the primitive types can be - referred to by their Java names (int, float etc), and classes in the - java.lang package can be used without a package qualifier. All other - classes must be fully qualified. - - Options should be a set of key/value pairs, all except for :name are - optional: - - :name aname - - The package-qualified name of the class to be generated - - :extends [interface ...] - - One or more interfaces, which will be extended by this interface. - - :methods [ [name [param-types] return-type], ...] - - This parameter is used to specify the signatures of the methods of - the generated interface. Do not repeat superinterface signatures - here." - - [& options] - (when *compile-files* - (let [options-map (apply hash-map options) - [cname bytecode] (generate-interface options-map)] - (clojure.lang.Compiler/writeClassFile cname bytecode)))) - -(comment - -(defn gen-and-load-class - "Generates and immediately loads the bytecode for the specified - class. Note that a class generated this way can be loaded only once - - the JVM supports only one class with a given name per - classloader. Subsequent to generation you can import it into any - desired namespaces just like any other class. See gen-class for a - description of the options." - - [& options] - (let [options-map (apply hash-map options) - [cname bytecode] (generate-class options-map)] - (.. (clojure.lang.RT/getRootClassLoader) (defineClass cname bytecode)))) - -) -; 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. - -(ns clojure.inspector - (:import - (java.awt BorderLayout) - (java.awt.event ActionEvent ActionListener) - (javax.swing.tree TreeModel) - (javax.swing.table TableModel AbstractTableModel) - (javax.swing JPanel JTree JTable JScrollPane JFrame JToolBar JButton SwingUtilities))) - -(defn atom? [x] - (not (coll? x))) - -(defn collection-tag [x] - (cond - (instance? java.util.Map$Entry x) :entry - (instance? java.util.Map x) :map - (sequential? x) :seq - :else :atom)) - -(defmulti is-leaf collection-tag) -(defmulti get-child (fn [parent index] (collection-tag parent))) -(defmulti get-child-count collection-tag) - -(defmethod is-leaf :default [node] - (atom? node)) -(defmethod get-child :default [parent index] - (nth parent index)) -(defmethod get-child-count :default [parent] - (count parent)) - -(defmethod is-leaf :entry [e] - (is-leaf (val e))) -(defmethod get-child :entry [e index] - (get-child (val e) index)) -(defmethod get-child-count :entry [e] - (count (val e))) - -(defmethod is-leaf :map [m] - false) -(defmethod get-child :map [m index] - (nth (seq m) index)) - -(defn tree-model [data] - (proxy [TreeModel] [] - (getRoot [] data) - (addTreeModelListener [treeModelListener]) - (getChild [parent index] - (get-child parent index)) - (getChildCount [parent] - (get-child-count parent)) - (isLeaf [node] - (is-leaf node)) - (valueForPathChanged [path newValue]) - (getIndexOfChild [parent child] - -1) - (removeTreeModelListener [treeModelListener]))) - - -(defn old-table-model [data] - (let [row1 (first data) - colcnt (count row1) - cnt (count data) - vals (if (map? row1) vals identity)] - (proxy [TableModel] [] - (addTableModelListener [tableModelListener]) - (getColumnClass [columnIndex] Object) - (getColumnCount [] colcnt) - (getColumnName [columnIndex] - (if (map? row1) - (name (nth (keys row1) columnIndex)) - (str columnIndex))) - (getRowCount [] cnt) - (getValueAt [rowIndex columnIndex] - (nth (vals (nth data rowIndex)) columnIndex)) - (isCellEditable [rowIndex columnIndex] false) - (removeTableModelListener [tableModelListener])))) - -(defn inspect-tree - "creates a graphical (Swing) inspector on the supplied hierarchical data" - [data] - (doto (JFrame. "Clojure Inspector") - (.add (JScrollPane. (JTree. (tree-model data)))) - (.setSize 400 600) - (.setVisible true))) - -(defn inspect-table - "creates a graphical (Swing) inspector on the supplied regular - data, which must be a sequential data structure of data structures - of equal length" - [data] - (doto (JFrame. "Clojure Inspector") - (.add (JScrollPane. (JTable. (old-table-model data)))) - (.setSize 400 600) - (.setVisible true))) - - -(defmulti list-provider class) - -(defmethod list-provider :default [x] - {:nrows 1 :get-value (fn [i] x) :get-label (fn [i] (.getName (class x)))}) - -(defmethod list-provider java.util.List [c] - (let [v (if (vector? c) c (vec c))] - {:nrows (count v) - :get-value (fn [i] (v i)) - :get-label (fn [i] i)})) - -(defmethod list-provider java.util.Map [c] - (let [v (vec (sort (map (fn [[k v]] (vector k v)) c)))] - {:nrows (count v) - :get-value (fn [i] ((v i) 1)) - :get-label (fn [i] ((v i) 0))})) - -(defn list-model [provider] - (let [{:keys [nrows get-value get-label]} provider] - (proxy [AbstractTableModel] [] - (getColumnCount [] 2) - (getRowCount [] nrows) - (getValueAt [rowIndex columnIndex] - (cond - (= 0 columnIndex) (get-label rowIndex) - (= 1 columnIndex) (print-str (get-value rowIndex))))))) - -(defmulti table-model class) - -(defmethod table-model :default [x] - (proxy [AbstractTableModel] [] - (getColumnCount [] 2) - (getRowCount [] 1) - (getValueAt [rowIndex columnIndex] - (if (zero? columnIndex) - (class x) - x)))) - -;(defn make-inspector [x] -; (agent {:frame frame :data x :parent nil :index 0})) - - -(defn inspect - "creates a graphical (Swing) inspector on the supplied object" - [x] - (doto (JFrame. "Clojure Inspector") - (.add - (doto (JPanel. (BorderLayout.)) - (.add (doto (JToolBar.) - (.add (JButton. "Back")) - (.addSeparator) - (.add (JButton. "List")) - (.add (JButton. "Table")) - (.add (JButton. "Bean")) - (.add (JButton. "Line")) - (.add (JButton. "Bar")) - (.addSeparator) - (.add (JButton. "Prev")) - (.add (JButton. "Next"))) - BorderLayout/NORTH) - (.add - (JScrollPane. - (doto (JTable. (list-model (list-provider x))) - (.setAutoResizeMode JTable/AUTO_RESIZE_LAST_COLUMN))) - BorderLayout/CENTER))) - (.setSize 400 400) - (.setVisible true))) - - -(comment - -(load-file "src/inspector.clj") -(refer 'inspector) -(inspect-tree {:a 1 :b 2 :c [1 2 3 {:d 4 :e 5 :f [6 7 8]}]}) -(inspect-table [[1 2 3][4 5 6][7 8 9][10 11 12]]) - -) -;; 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. - -;; Originally contributed by Stephen C. Gilardi - -(ns clojure.main - (:import (clojure.lang Compiler Compiler$CompilerException - LineNumberingPushbackReader RT))) - -(declare main) - -(defmacro with-bindings - "Executes body in the context of thread-local bindings for several vars - that often need to be set!: *ns* *warn-on-reflection* *print-meta* - *print-length* *print-level* *compile-path* *command-line-args* *1 - *2 *3 *e" - [& body] - `(binding [*ns* *ns* - *warn-on-reflection* *warn-on-reflection* - *print-meta* *print-meta* - *print-length* *print-length* - *print-level* *print-level* - *compile-path* (System/getProperty "clojure.compile.path" "classes") - *command-line-args* *command-line-args* - *1 nil - *2 nil - *3 nil - *e nil] - ~@body)) - -(defn repl-prompt - "Default :prompt hook for repl" - [] - (printf "%s=> " (ns-name *ns*))) - -(defn skip-if-eol - "If the next character on stream s is a newline, skips it, otherwise - leaves the stream untouched. Returns :line-start, :stream-end, or :body - to indicate the relative location of the next character on s. The stream - must either be an instance of LineNumberingPushbackReader or duplicate - its behavior of both supporting .unread and collapsing all of CR, LF, and - CRLF to a single \\newline." - [s] - (let [c (.read s)] - (cond - (= c (int \newline)) :line-start - (= c -1) :stream-end - :else (do (.unread s c) :body)))) - -(defn skip-whitespace - "Skips whitespace characters on stream s. Returns :line-start, :stream-end, - or :body to indicate the relative location of the next character on s. - Interprets comma as whitespace and semicolon as comment to end of line. - Does not interpret #! as comment to end of line because only one - character of lookahead is available. The stream must either be an - instance of LineNumberingPushbackReader or duplicate its behavior of both - supporting .unread and collapsing all of CR, LF, and CRLF to a single - \\newline." - [s] - (loop [c (.read s)] - (cond - (= c (int \newline)) :line-start - (= c -1) :stream-end - (= c (int \;)) (do (.readLine s) :line-start) - (or (Character/isWhitespace c) (= c (int \,))) (recur (.read s)) - :else (do (.unread s c) :body)))) - -(defn repl-read - "Default :read hook for repl. Reads from *in* which must either be an - instance of LineNumberingPushbackReader or duplicate its behavior of both - supporting .unread and collapsing all of CR, LF, and CRLF into a single - \\newline. repl-read: - - skips whitespace, then - - returns request-prompt on start of line, or - - returns request-exit on end of stream, or - - reads an object from the input stream, then - - skips the next input character if it's end of line, then - - returns the object." - [request-prompt request-exit] - (or ({:line-start request-prompt :stream-end request-exit} - (skip-whitespace *in*)) - (let [input (read)] - (skip-if-eol *in*) - input))) - -(defn- root-cause - "Returns the initial cause of an exception or error by peeling off all of - its wrappers" - [throwable] - (loop [cause throwable] - (if-let [cause (.getCause cause)] - (recur cause) - cause))) - -(defn repl-exception - "Returns CompilerExceptions in tact, but only the root cause of other - throwables" - [throwable] - (if (instance? Compiler$CompilerException throwable) - throwable - (root-cause throwable))) - -(defn repl-caught - "Default :caught hook for repl" - [e] - (.println *err* (repl-exception e))) - -(defn repl - "Generic, reusable, read-eval-print loop. By default, reads from *in*, - writes to *out*, and prints exception summaries to *err*. If you use the - default :read hook, *in* must either be an instance of - LineNumberingPushbackReader or duplicate its behavior of both supporting - .unread and collapsing CR, LF, and CRLF into a single \\newline. Options - are sequential keyword-value pairs. Available options and their defaults: - - - :init, function of no arguments, initialization hook called with - bindings for set!-able vars in place. - default: #() - - - :need-prompt, function of no arguments, called before each - read-eval-print except the first, the user will be prompted if it - returns true. - default: (if (instance? LineNumberingPushbackReader *in*) - #(.atLineStart *in*) - #(identity true)) - - - :prompt, function of no arguments, prompts for more input. - default: repl-prompt - - - :flush, function of no arguments, flushes output - default: flush - - - :read, function of two arguments, reads from *in*: - - returns its first argument to request a fresh prompt - - depending on need-prompt, this may cause the repl to prompt - before reading again - - returns its second argument to request an exit from the repl - - else returns the next object read from the input stream - default: repl-read - - - :eval, funtion of one argument, returns the evaluation of its - argument - default: eval - - - :print, function of one argument, prints its argument to the output - default: prn - - - :caught, function of one argument, a throwable, called when - read, eval, or print throws an exception or error - default: repl-caught" - [& options] - (let [{:keys [init need-prompt prompt flush read eval print caught] - :or {init #() - need-prompt (if (instance? LineNumberingPushbackReader *in*) - #(.atLineStart *in*) - #(identity true)) - prompt repl-prompt - flush flush - read repl-read - eval eval - print prn - caught repl-caught}} - (apply hash-map options) - request-prompt (Object.) - request-exit (Object.) - read-eval-print - (fn [] - (try - (let [input (read request-prompt request-exit)] - (or (#{request-prompt request-exit} input) - (let [value (eval input)] - (print value) - (set! *3 *2) - (set! *2 *1) - (set! *1 value)))) - (catch Throwable e - (caught e) - (set! *e e))))] - (with-bindings - (try - (init) - (catch Throwable e - (caught e) - (set! *e e))) - (prompt) - (flush) - (loop [] - (when-not (= (read-eval-print) request-exit) - (when (need-prompt) - (prompt) - (flush)) - (recur)))))) - -(defn load-script - "Loads Clojure source from a file or resource given its path. Paths - beginning with @ or @/ are considered relative to classpath." - [path] - (if (.startsWith path "@") - (RT/loadResourceScript - (.substring path (if (.startsWith path "@/") 2 1))) - (Compiler/loadFile path))) - -(defn- init-opt - "Load a script" - [path] - (load-script path)) - -(defn- eval-opt - "Evals expressions in str, prints each non-nil result using prn" - [str] - (let [eof (Object.)] - (with-in-str str - (loop [input (read *in* false eof)] - (when-not (= input eof) - (let [value (eval input)] - (when-not (nil? value) - (prn value)) - (recur (read *in* false eof)))))))) - -(defn- init-dispatch - "Returns the handler associated with an init opt" - [opt] - ({"-i" init-opt - "--init" init-opt - "-e" eval-opt - "--eval" eval-opt} opt)) - -(defn- initialize - "Common initialize routine for repl, script, and null opts" - [args inits] - (in-ns 'user) - (set! *command-line-args* args) - (doseq [[opt arg] inits] - ((init-dispatch opt) arg))) - -(defn- repl-opt - "Start a repl with args and inits. Print greeting if no eval options were - present" - [[_ & args] inits] - (when-not (some #(= eval-opt (init-dispatch (first %))) inits) - (println "Clojure" (clojure-version))) - (repl :init #(initialize args inits)) - (prn) - (System/exit 0)) - -(defn- script-opt - "Run a script from a file, resource, or standard in with args and inits" - [[path & args] inits] - (with-bindings - (initialize args inits) - (if (= path "-") - (load-reader *in*) - (load-script path)))) - -(defn- null-opt - "No repl or script opt present, just bind args and run inits" - [args inits] - (with-bindings - (initialize args inits))) - -(defn- help-opt - "Print help text for main" - [_ _] - (println (:doc (meta (var main))))) - -(defn- main-dispatch - "Returns the handler associated with a main option" - [opt] - (or - ({"-r" repl-opt - "--repl" repl-opt - nil null-opt - "-h" help-opt - "--help" help-opt - "-?" help-opt} opt) - script-opt)) - -(defn- legacy-repl - "Called by the clojure.lang.Repl.main stub to run a repl with args - specified the old way" - [args] - (let [[inits [sep & args]] (split-with (complement #{"--"}) args)] - (repl-opt (concat ["-r"] args) (map vector (repeat "-i") inits)))) - -(defn- legacy-script - "Called by the clojure.lang.Script.main stub to run a script with args - specified the old way" - [args] - (let [[inits [sep & args]] (split-with (complement #{"--"}) args)] - (null-opt args (map vector (repeat "-i") inits)))) - -(defn main - "Usage: java -cp clojure.jar clojure.main [init-opt*] [main-opt] [arg*] - - With no options or args, runs an interactive Read-Eval-Print Loop - - init options: - -i, --init path Load a file or resource - -e, --eval string Evaluate expressions in string; print non-nil values - - main options: - -r, --repl Run a repl - path Run a script from from a file or resource - - Run a script from standard input - -h, -?, --help Print this help message and exit - - operation: - - - Establishes thread-local bindings for commonly set!-able vars - - Enters the user namespace - - Binds *command-line-args* to a seq of strings containing command line - args that appear after any main option - - Runs all init options in order - - Runs a repl or script if requested - - The init options may be repeated and mixed freely, but must appear before - any main option. The appearance of any eval option before running a repl - suppresses the usual repl greeting message: \"Clojure ~(clojure-version)\". - - Paths may be absolute or relative in the filesystem or relative to - classpath. Classpath-relative paths have prefix of @ or @/" - [& args] - (try - (if args - (loop [[opt arg & more :as args] args inits []] - (if (init-dispatch opt) - (recur more (conj inits [opt arg])) - ((main-dispatch opt) args inits))) - (repl-opt nil nil)) - (finally - (flush)))) - -; 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. - -(ns clojure.parallel) -(alias 'parallel 'clojure.parallel) - -(comment " -The parallel library wraps the ForkJoin library scheduled for inclusion in JDK 7: - -http://gee.cs.oswego.edu/dl/concurrency-interest/index.html - -You'll need jsr166y.jar in your classpath in order to use this -library. The basic idea is that Clojure collections, and most -efficiently vectors, can be turned into parallel arrays for use by -this library with the function par, although most of the functions -take collections and will call par if needed, so normally you will -only need to call par explicitly in order to attach bound/filter/map -ops. Parallel arrays support the attachment of bounds, filters and -mapping functions prior to realization/calculation, which happens as -the result of any of several operations on the -array (pvec/psort/pfilter-nils/pfilter-dupes). Rather than perform -composite operations in steps, as would normally be done with -sequences, maps and filters are instead attached and thus composed by -providing ops to par. Note that there is an order sensitivity to the -attachments - bounds precede filters precede mappings. All operations -then happen in parallel, using multiple threads and a sophisticated -work-stealing system supported by fork-join, either when the array is -realized, or to perform aggregate operations like preduce/pmin/pmax -etc. A parallel array can be realized into a Clojure vector using -pvec. -") - -(import '(jsr166y.forkjoin ParallelArray ParallelArrayWithBounds ParallelArrayWithFilter - ParallelArrayWithMapping - Ops$Op Ops$BinaryOp Ops$Reducer Ops$Predicate Ops$BinaryPredicate - Ops$IntAndObjectPredicate Ops$IntAndObjectToObject)) - -(defn- op [f] - (proxy [Ops$Op] [] - (op [x] (f x)))) - -(defn- binary-op [f] - (proxy [Ops$BinaryOp] [] - (op [x y] (f x y)))) - -(defn- int-and-object-to-object [f] - (proxy [Ops$IntAndObjectToObject] [] - (op [i x] (f x i)))) - -(defn- reducer [f] - (proxy [Ops$Reducer] [] - (op [x y] (f x y)))) - -(defn- predicate [f] - (proxy [Ops$Predicate] [] - (op [x] (boolean (f x))))) - -(defn- binary-predicate [f] - (proxy [Ops$BinaryPredicate] [] - (op [x y] (boolean (f x y))))) - -(defn- int-and-object-predicate [f] - (proxy [Ops$IntAndObjectPredicate] [] - (op [i x] (boolean (f x i))))) - -(defn par - "Creates a parallel array from coll. ops, if supplied, perform - on-the-fly filtering or transformations during parallel realization - or calculation. ops form a chain, and bounds must precede filters, - must precede maps. ops must be a set of keyword value pairs of the - following forms: - - :bound [start end] - - Only elements from start (inclusive) to end (exclusive) will be - processed when the array is realized. - - :filter pred - - Filter preds remove elements from processing when the array is realized. pred - must be a function of one argument whose return will be processed - via boolean. - - :filter-index pred2 - - pred2 must be a function of two arguments, which will be an element - of the collection and the corresponding index, whose return will be - processed via boolean. - - :filter-with [pred2 coll2] - - pred2 must be a function of two arguments, which will be - corresponding elements of the 2 collections. - - :map f - - Map fns will be used to transform elements when the array is - realized. f must be a function of one argument. - - :map-index f2 - - f2 must be a function of two arguments, which will be an element of - the collection and the corresponding index. - - :map-with [f2 coll2] - - f2 must be a function of two arguments, which will be corresponding - elements of the 2 collections." - - ([coll] - (if (instance? ParallelArrayWithMapping coll) - coll - (. ParallelArray createUsingHandoff - (to-array coll) - (. ParallelArray defaultExecutor)))) - ([coll & ops] - (reduce (fn [pa [op args]] - (cond - (= op :bound) (. pa withBounds (args 0) (args 1)) - (= op :filter) (. pa withFilter (predicate args)) - (= op :filter-with) (. pa withFilter (binary-predicate (args 0)) (par (args 1))) - (= op :filter-index) (. pa withIndexedFilter (int-and-object-predicate args)) - (= op :map) (. pa withMapping (parallel/op args)) - (= op :map-with) (. pa withMapping (binary-op (args 0)) (par (args 1))) - (= op :map-index) (. pa withIndexedMapping (int-and-object-to-object args)) - :else (throw (Exception. (str "Unsupported par op: " op))))) - (par coll) - (partition 2 ops)))) - -;;;;;;;;;;;;;;;;;;;;; aggregate operations ;;;;;;;;;;;;;;;;;;;;;; -(defn pany - "Returns some (random) element of the coll if it satisfies the bound/filter/map" - [coll] - (. (par coll) any)) - -(defn pmax - "Returns the maximum element, presuming Comparable elements, unless - a Comparator comp is supplied" - ([coll] (. (par coll) max)) - ([coll comp] (. (par coll) max comp))) - -(defn pmin - "Returns the minimum element, presuming Comparable elements, unless - a Comparator comp is supplied" - ([coll] (. (par coll) min)) - ([coll comp] (. (par coll) min comp))) - -(defn- summary-map [s] - {:min (.min s) :max (.max s) :size (.size s) :min-index (.indexOfMin s) :max-index (.indexOfMax s)}) - -(defn psummary - "Returns a map of summary statistics (min. max, size, min-index, max-index, - presuming Comparable elements, unless a Comparator comp is supplied" - ([coll] (summary-map (. (par coll) summary))) - ([coll comp] (summary-map (. (par coll) summary comp)))) - -(defn preduce - "Returns the reduction of the realized elements of coll - using function f. Note f will not necessarily be called - consecutively, and so must be commutative. Also note that - (f base an-element) might be performed many times, i.e. base is not - an initial value as with sequential reduce." - [f base coll] - (. (par coll) (reduce (reducer f) base))) - -;;;;;;;;;;;;;;;;;;;;; collection-producing operations ;;;;;;;;;;;;;;;;;;;;;; - -(defn- pa-to-vec [pa] - (vec (. pa getArray))) - -(defn- pall - "Realizes a copy of the coll as a parallel array, with any bounds/filters/maps applied" - [coll] - (if (instance? ParallelArrayWithMapping coll) - (. coll all) - (par coll))) - -(defn pvec - "Returns the realized contents of the parallel array pa as a Clojure vector" - [pa] (pa-to-vec (pall pa))) - -(defn pdistinct - "Returns a parallel array of the distinct elements of coll" - [coll] - (pa-to-vec (. (pall coll) allUniqueElements))) - -;this doesn't work, passes null to reducer? -(defn- pcumulate [coll f init] - (.. (pall coll) (precumulate (reducer f) init))) - -(defn psort - "Returns a new vector consisting of the realized items in coll, sorted, - presuming Comparable elements, unless a Comparator comp is supplied" - ([coll] (pa-to-vec (. (pall coll) sort))) - ([coll comp] (pa-to-vec (. (pall coll) sort comp)))) - -(defn pfilter-nils - "Returns a vector containing the non-nil (realized) elements of coll" - [coll] - (pa-to-vec (. (pall coll) removeNulls))) - -(defn pfilter-dupes - "Returns a vector containing the (realized) elements of coll, - without any consecutive duplicates" - [coll] - (pa-to-vec (. (pall coll) removeConsecutiveDuplicates))) - - -(comment -(load-file "src/parallel.clj") -(refer 'parallel) -(pdistinct [1 2 3 2 1]) -;(pcumulate [1 2 3 2 1] + 0) ;broken, not exposed -(def a (make-array Object 1000000)) -(dotimes i (count a) - (aset a i (rand-int i))) -(time (reduce + 0 a)) -(time (preduce + 0 a)) -(time (count (distinct a))) -(time (count (pdistinct a))) - -(preduce + 0 [1 2 3 2 1]) -(preduce + 0 (psort a)) -(pvec (par [11 2 3 2] :filter-index (fn [x i] (> i x)))) -(pvec (par [11 2 3 2] :filter-with [(fn [x y] (> y x)) [110 2 33 2]])) - -(psummary ;or pvec/pmax etc - (par [11 2 3 2] - :filter-with [(fn [x y] (> y x)) - [110 2 33 2]] - :map #(* % 2))) - -(preduce + 0 - (par [11 2 3 2] - :filter-with [< [110 2 33 2]])) - -(time (reduce + 0 (map #(* % %) (range 1000000)))) -(time (preduce + 0 (par (range 1000000) :map-index *))) -(def v (range 1000000)) -(time (preduce + 0 (par v :map-index *))) -(time (preduce + 0 (par v :map #(* % %)))) -(time (reduce + 0 (map #(* % %) v))) -); 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. - -(ns clojure.set) - -(defn- bubble-max-key [k coll] - "Move a maximal element of coll according to fn k (which returns a number) - to the front of coll." - (let [max (apply max-key k coll)] - (cons max (remove #(identical? max %) coll)))) - -(defn union - "Return a set that is the union of the input sets" - ([] #{}) - ([s1] s1) - ([s1 s2] - (if (< (count s1) (count s2)) - (reduce conj s2 s1) - (reduce conj s1 s2))) - ([s1 s2 & sets] - (let [bubbled-sets (bubble-max-key count (conj sets s2 s1))] - (reduce into (first bubbled-sets) (rest bubbled-sets))))) - -(defn intersection - "Return a set that is the intersection of the input sets" - ([s1] s1) - ([s1 s2] - (if (< (count s2) (count s1)) - (recur s2 s1) - (reduce (fn [result item] - (if (contains? s2 item) - result - (disj result item))) - s1 s1))) - ([s1 s2 & sets] - (let [bubbled-sets (bubble-max-key #(- (count %)) (conj sets s2 s1))] - (reduce intersection (first bubbled-sets) (rest bubbled-sets))))) - -(defn difference - "Return a set that is the first set without elements of the remaining sets" - ([s1] s1) - ([s1 s2] - (if (< (count s1) (count s2)) - (reduce (fn [result item] - (if (contains? s2 item) - (disj result item) - result)) - s1 s1) - (reduce disj s1 s2))) - ([s1 s2 & sets] - (reduce difference s1 (conj sets s2)))) - - -(defn select - "Returns a set of the elements for which pred is true" - [pred xset] - (reduce (fn [s k] (if (pred k) s (disj s k))) - xset xset)) - -(defn project - "Returns a rel of the elements of xrel with only the keys in ks" - [xrel ks] - (set (map #(select-keys % ks) xrel))) - -(defn rename-keys - "Returns the map with the keys in kmap renamed to the vals in kmap" - [map kmap] - (reduce - (fn [m [old new]] - (if (not= old new) - (-> m (assoc new (m old)) (dissoc old)) - m)) - map kmap)) - -(defn rename - "Returns a rel of the maps in xrel with the keys in kmap renamed to the vals in kmap" - [xrel kmap] - (set (map #(rename-keys % kmap) xrel))) - -(defn index - "Returns a map of the distinct values of ks in the xrel mapped to a - set of the maps in xrel with the corresponding values of ks." - [xrel ks] - (reduce - (fn [m x] - (let [ik (select-keys x ks)] - (assoc m ik (conj (get m ik #{}) x)))) - {} xrel)) - -(defn map-invert - "Returns the map with the vals mapped to the keys." - [m] (reduce (fn [m [k v]] (assoc m v k)) {} m)) - -(defn join - "When passed 2 rels, returns the rel corresponding to the natural - join. When passed an additional keymap, joins on the corresponding - keys." - ([xrel yrel] ;natural join - (if (and (seq xrel) (seq yrel)) - (let [ks (intersection (set (keys (first xrel))) (set (keys (first yrel)))) - [r s] (if (<= (count xrel) (count yrel)) - [xrel yrel] - [yrel xrel]) - idx (index r ks)] - (reduce (fn [ret x] - (let [found (idx (select-keys x ks))] - (if found - (reduce #(conj %1 (merge %2 x)) ret found) - ret))) - #{} s)) - #{})) - ([xrel yrel km] ;arbitrary key mapping - (let [[r s k] (if (<= (count xrel) (count yrel)) - [xrel yrel (map-invert km)] - [yrel xrel km]) - idx (index r (vals k))] - (reduce (fn [ret x] - (let [found (idx (rename-keys (select-keys x (keys k)) k))] - (if found - (reduce #(conj %1 (merge %2 x)) ret found) - ret))) - #{} s)))) - -(comment -(refer 'set) -(def xs #{{:a 11 :b 1 :c 1 :d 4} - {:a 2 :b 12 :c 2 :d 6} - {:a 3 :b 3 :c 3 :d 8 :f 42}}) - -(def ys #{{:a 11 :b 11 :c 11 :e 5} - {:a 12 :b 11 :c 12 :e 3} - {:a 3 :b 3 :c 3 :e 7 }}) - -(join xs ys) -(join xs (rename ys {:b :yb :c :yc}) {:a :a}) - -(union #{:a :b :c} #{:c :d :e }) -(difference #{:a :b :c} #{:c :d :e}) -(intersection #{:a :b :c} #{:c :d :e}) - -(index ys [:b]) -) - -; 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. - -(ns clojure.xml - (:import (org.xml.sax ContentHandler Attributes SAXException) - (javax.xml.parsers SAXParser SAXParserFactory))) - -(def *stack*) -(def *current*) -(def *state*) ; :element :chars :between -(def *sb*) - -(defstruct element :tag :attrs :content) - -(def tag (accessor element :tag)) -(def attrs (accessor element :attrs)) -(def content (accessor element :content)) - -(def content-handler - (let [push-content (fn [e c] - (assoc e :content (conj (or (:content e) []) c))) - push-chars (fn [] - (when (and (= *state* :chars) - (some (complement #(. Character (isWhitespace %))) (str *sb*))) - (set! *current* (push-content *current* (str *sb*)))))] - (new clojure.lang.XMLHandler - (proxy [ContentHandler] [] - (startElement [uri local-name q-name #^Attributes atts] - (let [attrs (fn [ret i] - (if (neg? i) - ret - (recur (assoc ret - (. clojure.lang.Keyword (intern (symbol (. atts (getQName i))))) - (. atts (getValue i))) - (dec i)))) - e (struct element - (. clojure.lang.Keyword (intern (symbol q-name))) - (when (pos? (. atts (getLength))) - (attrs {} (dec (. atts (getLength))))))] - (push-chars) - (set! *stack* (conj *stack* *current*)) - (set! *current* e) - (set! *state* :element)) - nil) - (endElement [uri local-name q-name] - (push-chars) - (set! *current* (push-content (peek *stack*) *current*)) - (set! *stack* (pop *stack*)) - (set! *state* :between) - nil) - (characters [ch start length] - (when-not (= *state* :chars) - (set! *sb* (new StringBuilder))) - (let [#^StringBuilder sb *sb*] - (. sb (append ch start length)) - (set! *state* :chars)) - nil) - (setDocumentLocator [locator]) - (startDocument []) - (endDocument []) - (startPrefixMapping [prefix uri]) - (endPrefixMapping [prefix]) - (ignorableWhitespace [ch start length]) - (processingInstruction [target data]) - (skippedEntity [name]) - )))) - -(defn startparse-sax [s ch] - (.. SAXParserFactory (newInstance) (newSAXParser) (parse s ch))) - -(defn parse - "Parses and loads the source s, which can be a File, InputStream or - String naming a URI. Returns a tree of the xml/element struct-map, - which has the keys :tag, :attrs, and :content. and accessor fns tag, - attrs, and content. Other parsers can be supplied by passing - startparse, a fn taking a source and a ContentHandler and returning - a parser" - ([s] (parse s startparse-sax)) - ([s startparse] - (binding [*stack* nil - *current* (struct element) - *state* :between - *sb* nil] - (startparse s content-handler) - ((:content *current*) 0)))) - -(defn emit-element [e] - (if (instance? String e) - (println e) - (do - (print (str "<" (name (:tag e)))) - (when (:attrs e) - (doseq [attr (:attrs e)] - (print (str " " (name (key attr)) "='" (val attr)"'")))) - (if (:content e) - (do - (println ">") - (doseq [c (:content e)] - (emit-element c)) - (println (str "</" (name (:tag e)) ">"))) - (println "/>"))))) - -(defn emit [x] - (println "<?xml version='1.0' encoding='UTF-8'?>") - (emit-element x)) - -;(export '(tag attrs content parse element emit emit-element)) - -;(load-file "/Users/rich/dev/clojure/src/xml.clj") -;(def x (xml/parse "http://arstechnica.com/journals.rssx")) -; 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. - -;functional hierarchical zipper, with navigation, editing and enumeration -;see Huet - -(ns clojure.zip - (:refer-clojure :exclude (replace remove next))) - -(defn zipper - "Creates a new zipper structure. - - branch? is a fn that, given a node, returns true if can have - children, even if it currently doesn't. - - children is a fn that, given a branch node, returns a seq of its - children. - - make-node is a fn that, given an existing node and a seq of - children, returns a new branch node with the supplied children. - root is the root node." - [branch? children make-node root] - #^{:zip/branch? branch? :zip/children children :zip/make-node make-node} - [root nil]) - -(defn seq-zip - "Returns a zipper for nested sequences, given a root sequence" - [root] - (zipper seq? identity (fn [node children] children) root)) - -(defn vector-zip - "Returns a zipper for nested vectors, given a root vector" - [root] - (zipper vector? seq (fn [node children] (apply vector children)) root)) - -(defn xml-zip - "Returns a zipper for xml elements (as from xml/parse), - given a root element" - [root] - (zipper (complement string?) - (comp seq :content) - (fn [node children] - (assoc node :content (and children (apply vector children)))) - root)) - -(defn node - "Returns the node at loc" - [loc] (loc 0)) - -(defn branch? - "Returns true if the node at loc is a branch" - [loc] - ((:zip/branch? ^loc) (node loc))) - -(defn children - "Returns a seq of the children of node at loc, which must be a branch" - [loc] - ((:zip/children ^loc) (node loc))) - -(defn make-node - "Returns a new branch node, given an existing node and new - children. The loc is only used to supply the constructor." - [loc node children] - ((:zip/make-node ^loc) node children)) - -(defn path - "Returns a seq of nodes leading to this loc" - [loc] - (:pnodes (loc 1))) - -(defn lefts - "Returns a seq of the left siblings of this loc" - [loc] - (seq (:l (loc 1)))) - -(defn rights - "Returns a seq of the right siblings of this loc" - [loc] - (:r (loc 1))) - - -(defn down - "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)))) - -(defn up - "Returns the loc of the parent of the node at this loc, or nil if at - the top" - [loc] - (let [[node {l :l, ppath :ppath, pnodes :pnodes r :r, changed? :changed?, :as path}] loc] - (when pnodes - (let [pnode (peek pnodes)] - (with-meta (if changed? - [(make-node loc pnode (concat l (cons node r))) - (and ppath (assoc ppath :changed? true))] - [pnode ppath]) - ^loc))))) - -(defn root - "zips all the way up and returns the root node, reflecting any - changes." - [loc] - (if (= :end (loc 1)) - (node loc) - (let [p (up loc)] - (if p - (recur p) - (node loc))))) - -(defn right - "Returns the loc of the right sibling of the node at this loc, or nil" - [loc] - (let [[node {l :l [r & rnext :as rs] :r :as path}] loc] - (when (and path rs) - (with-meta [r (assoc path :l (conj l node) :r rnext)] ^loc)))) - -(defn rightmost - "Returns the loc of the rightmost sibling of the node at this loc, or self" - [loc] - (let [[node {l :l r :r :as path}] loc] - (if (and path r) - (with-meta [(last r) (assoc path :l (apply conj l node (butlast r)) :r nil)] ^loc) - loc))) - -(defn left - "Returns the loc of the left sibling of the node at this loc, or nil" - [loc] - (let [[node {l :l r :r :as path}] loc] - (when (and path (seq l)) - (with-meta [(peek l) (assoc path :l (pop l) :r (cons node r))] ^loc)))) - -(defn leftmost - "Returns the loc of the leftmost sibling of the node at this loc, or self" - [loc] - (let [[node {l :l r :r :as path}] loc] - (if (and path (seq l)) - (with-meta [(first l) (assoc path :l [] :r (concat (rest l) [node] r))] ^loc) - loc))) - -(defn insert-left - "Inserts the item as the left sibling of the node at this loc, - without moving" - [loc item] - (let [[node {l :l :as path}] loc] - (if (nil? path) - (throw (new Exception "Insert at top")) - (with-meta [node (assoc path :l (conj l item) :changed? true)] ^loc)))) - -(defn insert-right - "Inserts the item as the right sibling of the node at this loc, - without moving" - [loc item] - (let [[node {r :r :as path}] loc] - (if (nil? path) - (throw (new Exception "Insert at top")) - (with-meta [node (assoc path :r (cons item r) :changed? true)] ^loc)))) - -(defn replace - "Replaces the node at this loc, without moving" - [loc node] - (let [[_ path] loc] - (with-meta [node (assoc path :changed? true)] ^loc))) - -(defn edit - "Replaces the node at this loc with the value of (f node args)" - [loc f & args] - (replace loc (apply f (node loc) args))) - -(defn insert-child - "Inserts the item as the leftmost child of the node at this loc, - without moving" - [loc item] - (replace loc (make-node loc (node loc) (cons item (children loc))))) - -(defn append-child - "Inserts the item as the rightmost child of the node at this loc, - without moving" - [loc item] - (replace loc (make-node loc (node loc) (concat (children loc) [item])))) - -(defn next - "Moves to the next loc in the hierarchy, depth-first. When reaching - the end, returns a distinguished loc detectable via end?. If already - at the end, stays there." - [loc] - (if (= :end (loc 1)) - loc - (or - (and (branch? loc) (down loc)) - (right loc) - (loop [p loc] - (if (up p) - (or (right (up p)) (recur (up p))) - [(node p) :end]))))) - -(defn prev - "Moves to the previous loc in the hierarchy, depth-first. If already - at the root, returns nil." - [loc] - (if-let [lloc (left loc)] - (loop [loc lloc] - (if-let [child (and (branch? loc) (down loc))] - (recur (rightmost child)) - loc)) - (up loc))) - -(defn end? - "Returns true if loc represents the end of a depth-first walk" - [loc] - (= :end (loc 1))) - -(defn remove - "Removes the node at loc, returning the loc that would have preceded - it in a depth-first walk." - [loc] - (let [[node {l :l, ppath :ppath, pnodes :pnodes, rs :r, :as path}] loc] - (if (nil? path) - (throw (new Exception "Remove at top")) - (if (pos? (count l)) - (loop [loc (with-meta [(peek l) (assoc path :l (pop l) :changed? true)] ^loc)] - (if-let [child (and (branch? loc) (down loc))] - (recur (rightmost child)) - loc)) - (with-meta [(make-node loc (peek pnodes) rs) - (and ppath (assoc ppath :changed? true))] - ^loc))))) - -(comment - -(load-file "/Users/rich/dev/clojure/src/zip.clj") -(refer 'zip) -(def data '[[a * b] + [c * d]]) -(def dz (vector-zip data)) - -(right (down (right (right (down dz))))) -(lefts (right (down (right (right (down dz)))))) -(rights (right (down (right (right (down dz)))))) -(up (up (right (down (right (right (down dz))))))) -(path (right (down (right (right (down dz)))))) - -(-> dz down right right down right) -(-> dz down right right down right (replace '/) root) -(-> dz next next (edit str) next next next (replace '/) root) -(-> dz next next next next next next next next next remove root) -(-> dz next next next next next next next next next remove (insert-right 'e) root) -(-> dz next next next next next next next next next remove up (append-child 'e) root) - -(end? (-> dz next next next next next next next next next remove next)) - -(-> dz next remove next remove root) - -(loop [loc dz] - (if (end? loc) - (root loc) - (recur (next (if (= '* (node loc)) - (replace loc '/) - loc))))) - -(loop [loc dz] - (if (end? loc) - (root loc) - (recur (next (if (= '* (node loc)) - (remove loc) - loc))))) -) |