diff options
| -rw-r--r-- | src/clj/clojure/core.clj | 226 | ||||
| -rw-r--r-- | src/jvm/clojure/lang/Compiler.java | 309 | ||||
| -rw-r--r-- | test/clojure/test_clojure/control.clj | 86 | ||||
| -rw-r--r-- | test/clojure/test_clojure/rt.clj | 27 | ||||
| -rw-r--r-- | test/clojure/test_helper.clj | 35 |
5 files changed, 546 insertions, 137 deletions
diff --git a/src/clj/clojure/core.clj b/src/clj/clojure/core.clj index c928e4f7..6f41594e 100644 --- a/src/clj/clojure/core.clj +++ b/src/clj/clojure/core.clj @@ -5714,25 +5714,154 @@ (map #(cons `fn %) fnspecs))) ~@body)) +(defn fnil + "Takes a function f, and returns a function that calls f, replacing + a nil first argument to f with the supplied value x. Higher arity + versions can replace arguments in the second and third + positions (y, z). Note that the function f can take any number of + arguments, not just the one(s) being nil-patched." + {:added "1.2" + :static true} + ([f x] + (fn + ([a] (f (if (nil? a) x a))) + ([a b] (f (if (nil? a) x a) b)) + ([a b c] (f (if (nil? a) x a) b c)) + ([a b c & ds] (apply f (if (nil? a) x a) b c ds)))) + ([f x y] + (fn + ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) + ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c)) + ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds)))) + ([f x y z] + (fn + ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) + ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c))) + ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds))))) + ;;;;;;; case ;;;;;;;;;;;;; (defn- shift-mask [shift mask x] (-> x (bit-shift-right shift) (bit-and mask))) +(def ^:private max-mask-bits 13) +(def ^:private max-switch-table-size (bit-shift-left 1 max-mask-bits)) + +(defn- maybe-min-hash + "takes a collection of hashes and returns [shift mask] or nil if none found" + [hashes] + (first + (filter (fn [[s m]] + (apply distinct? (map #(shift-mask s m %) hashes))) + (for [mask (map #(dec (bit-shift-left 1 %)) (range 1 (inc max-mask-bits))) + shift (range 0 31)] + [shift mask])))) + (defn- min-hash "takes a collection of keys and returns [shift mask]" [keys] (let [hashes (map hash keys) - cnt (count keys)] - (when-not (apply distinct? hashes) - (throw (IllegalArgumentException. "Hashes must be distinct"))) - (or (first - (filter (fn [[s m]] - (apply distinct? (map #(shift-mask s m %) hashes))) - (for [mask (map #(dec (bit-shift-left 1 %)) (range 1 14)) - shift (range 0 31)] - [shift mask]))) - (throw (IllegalArgumentException. "No distinct mapping found"))))) + _ (when-not (apply distinct? hashes) + (throw (IllegalArgumentException. "Hashes must be distinct"))) + sm (maybe-min-hash hashes)] + (or sm (throw (IllegalArgumentException. "No distinct mapping found"))))) + +(defn- case-map + "Transforms a sequence of test constants and a corresponding sequence of then + expressions into a sorted map to be consumed by case*. The form of the map + entries are {(case-f test) [(test-f test) then]}." + [case-f test-f tests thens] + (into1 (sorted-map) + (zipmap (map case-f tests) + (map vector + (map test-f tests) + thens)))) + +(defn- fits-table? + "Returns true if the collection of ints can fit within the + max-table-switch-size, false otherwise." + [ints] + (< (- (apply max (seq ints)) (apply min (seq ints))) max-switch-table-size)) + +(defn- prep-ints + "Takes a sequence of int-sized test constants and a corresponding sequence of + then expressions. Returns a tuple of [shift mask case-map switch-type] where + case-map is a map of int case values to [test then] tuples, and switch-type + is either :sparse or :compact." + [tests thens] + (if (fits-table? tests) + ; compact case ints, no shift-mask + [0 0 (case-map int int tests thens) :compact] + (let [[shift mask] (or (maybe-min-hash (map int tests)) [0 0])] + (if (zero? mask) + ; sparse case ints, no shift-mask + [0 0 (case-map int int tests thens) :sparse] + ; compact case ints, with shift-mask + [shift mask (case-map #(shift-mask shift mask (int %)) int tests thens) :compact])))) + +(defn- merge-hash-collisions + "Takes a case expression, default expression, and a sequence of test constants + and a corresponding sequence of then expressions. Returns a tuple of + [tests thens skip-check-set] where no tests have the same hash. Each set of + input test constants with the same hash is replaced with a single test + constant (the case int), and their respective thens are combined into: + (condp = expr + test-1 then-1 + ... + test-n then-n + default). + The skip-check is a set of case ints for which post-switch equivalence + checking must not be done (the cases holding the above condp thens)." + [expr-sym default tests thens] + (let [buckets (loop [m {} ks tests vs thens] + (if (and ks vs) + (recur + (update-in m [(hash (first ks))] (fnil conj []) [(first ks) (first vs)]) + (next ks) (next vs)) + m)) + assoc-multi (fn [m h bucket] + (let [testexprs (apply concat bucket) + expr `(condp = ~expr-sym ~@testexprs ~default)] + (assoc m h expr))) + hmap (reduce1 + (fn [m [h bucket]] + (if (== 1 (count bucket)) + (assoc m (ffirst bucket) (second (first bucket))) + (assoc-multi m h bucket))) + {} buckets) + skip-check (->> buckets + (filter #(< 1 (count (second %)))) + (map first) + (into1 #{}))] + [(keys hmap) (vals hmap) skip-check])) + +(defn- prep-hashes + "Takes a sequence of test constants and a corresponding sequence of then + expressions. Returns a tuple of [shift mask case-map switch-type skip-check] + where case-map is a map of int case values to [test then] tuples, switch-type + is either :sparse or :compact, and skip-check is a set of case ints for which + post-switch equivalence checking must not be done (occurs with hash + collisions)." + [expr-sym default tests thens] + (let [hashes (into1 #{} (map hash tests))] + (if (== (count tests) (count hashes)) + (if (fits-table? hashes) + ; compact case ints, no shift-mask + [0 0 (case-map hash identity tests thens) :compact] + (let [[shift mask] (or (maybe-min-hash hashes) [0 0])] + (if (zero? mask) + ; sparse case ints, no shift-mask + [0 0 (case-map hash identity tests thens) :sparse] + ; compact case ints, with shift-mask + [shift mask (case-map #(shift-mask shift mask (hash %)) identity tests thens) :compact]))) + ; resolve hash collisions and try again + (let [[tests thens skip-check] (merge-hash-collisions expr-sym default tests thens) + [shift mask case-map switch-type] (prep-hashes expr-sym default tests thens) + skip-check (if (zero? mask) + skip-check + (into1 #{} (map #(shift-mask shift mask %) skip-check)))] + [shift mask case-map switch-type skip-check])))) + (defmacro case "Takes an expression, and a set of clauses. @@ -5763,24 +5892,40 @@ (let [ge (with-meta (gensym) {:tag Object}) default (if (odd? (count clauses)) (last clauses) - `(throw (IllegalArgumentException. (str "No matching clause: " ~ge)))) - cases (partition 2 clauses) - case-map (reduce1 (fn [m [test expr]] - (if (seq? test) - (into1 m (zipmap test (repeat expr))) - (assoc m test expr))) - {} cases) - [shift mask] (if (seq case-map) (min-hash (keys case-map)) [0 0]) - - hmap (reduce1 (fn [m [test expr :as te]] - (assoc m (shift-mask shift mask (hash test)) te)) - (sorted-map) case-map)] - `(let [~ge ~e] - ~(condp = (count clauses) - 0 default - 1 default - `(case* ~ge ~shift ~mask ~(key (first hmap)) ~(key (last hmap)) ~default ~hmap - ~(every? keyword? (keys case-map))))))) + `(throw (IllegalArgumentException. (str "No matching clause: " ~ge))))] + (if (> 2 (count clauses)) + `(let [~ge ~e] ~default) + (let [pairs (partition 2 clauses) + assoc-test (fn assoc-test [m test expr] + (if (contains? m test) + (throw (IllegalArgumentException. (str "Duplicate case test constant: " test))) + (assoc m test expr))) + pairs (reduce1 + (fn [m [test expr]] + (if (seq? test) + (reduce1 #(assoc-test %1 %2 expr) m test) + (assoc-test m test expr))) + {} pairs) + tests (keys pairs) + thens (vals pairs) + mode (cond + (every? #(and (integer? %) (<= Integer/MIN_VALUE % Integer/MAX_VALUE)) tests) + :ints + (every? keyword? tests) + :identity + :else :hashes)] + (condp = mode + :ints + (let [[shift mask imap switch-type] (prep-ints tests thens)] + `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :int))) + :hashes + (let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)] + `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-equiv ~skip-check))) + :identity + (let [[shift mask imap switch-type skip-check] (prep-hashes ge default tests thens)] + `(let [~ge ~e] (case* ~ge ~shift ~mask ~default ~imap ~switch-type :hash-identity ~skip-check)))))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; helper files ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (alter-meta! (find-ns 'clojure.core) assoc :doc "Fundamental library of the Clojure language") @@ -6194,31 +6339,6 @@ (cons x (keepi (inc idx) (rest s)))))))))] (keepi 0 coll)))) -(defn fnil - "Takes a function f, and returns a function that calls f, replacing - a nil first argument to f with the supplied value x. Higher arity - versions can replace arguments in the second and third - positions (y, z). Note that the function f can take any number of - arguments, not just the one(s) being nil-patched." - {:added "1.2" - :static true} - ([f x] - (fn - ([a] (f (if (nil? a) x a))) - ([a b] (f (if (nil? a) x a) b)) - ([a b c] (f (if (nil? a) x a) b c)) - ([a b c & ds] (apply f (if (nil? a) x a) b c ds)))) - ([f x y] - (fn - ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) - ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) c)) - ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) c ds)))) - ([f x y z] - (fn - ([a b] (f (if (nil? a) x a) (if (nil? b) y b))) - ([a b c] (f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c))) - ([a b c & ds] (apply f (if (nil? a) x a) (if (nil? b) y b) (if (nil? c) z c) ds))))) - (defn every-pred "Takes a set of predicates and returns a function f that returns true if all of its composing predicates return a logical true value against all of its arguments, else it returns diff --git a/src/jvm/clojure/lang/Compiler.java b/src/jvm/clojure/lang/Compiler.java index d037186e..89d5df4e 100644 --- a/src/jvm/clojure/lang/Compiler.java +++ b/src/jvm/clojure/lang/Compiler.java @@ -1212,6 +1212,31 @@ static Class maybePrimitiveType(Expr e){ return null; } +static Class maybeJavaClass(Collection<Expr> exprs){ + Class match = null; + try + { + for (Expr e : exprs) + { + if (e instanceof ThrowExpr) + continue; + if (!e.hasJavaClass()) + return null; + Class c = e.getJavaClass(); + if (match == null) + match = c; + else if (match != c) + return null; + } + } + catch(Exception e) + { + return null; + } + return match; +} + + static abstract class MethodExpr extends HostExpr{ static void emitArgsAsArray(IPersistentVector args, ObjExpr objx, GeneratorAdapter gen){ gen.push(args.count()); @@ -7700,23 +7725,32 @@ static public class MethodParamExpr implements Expr, MaybePrimitiveExpr{ } } -public static class CaseExpr extends UntypedExpr{ +public static class CaseExpr implements Expr, MaybePrimitiveExpr{ public final LocalBindingExpr expr; public final int shift, mask, low, high; public final Expr defaultExpr; - public final HashMap<Integer,Expr> tests; + public final SortedMap<Integer,Expr> tests; public final HashMap<Integer,Expr> thens; - public final boolean allKeywords; - + public final Keyword switchType; + public final Keyword testType; + public final Set<Integer> skipCheck; + public final Class returnType; public final int line; + final static Type NUMBER_TYPE = Type.getType(Number.class); + final static Method intValueMethod = Method.getMethod("int intValue()"); + final static Method hashMethod = Method.getMethod("int hash(Object)"); final static Method hashCodeMethod = Method.getMethod("int hashCode()"); - final static Method equalsMethod = Method.getMethod("boolean equals(Object, Object)"); - - + final static Method equivMethod = Method.getMethod("boolean equiv(Object, Object)"); + final static Keyword compactKey = Keyword.intern(null, "compact"); + final static Keyword sparseKey = Keyword.intern(null, "sparse"); + final static Keyword hashIdentityKey = Keyword.intern(null, "hash-identity"); + final static Keyword hashEquivKey = Keyword.intern(null, "hash-equiv"); + final static Keyword intKey = Keyword.intern(null, "int"); + //(case* expr shift mask default map<minhash, [test then]> table-type test-type skip-check?) public CaseExpr(int line, LocalBindingExpr expr, int shift, int mask, int low, int high, Expr defaultExpr, - HashMap<Integer,Expr> tests,HashMap<Integer,Expr> thens, boolean allKeywords){ + SortedMap<Integer,Expr> tests,HashMap<Integer,Expr> thens, Keyword switchType, Keyword testType, Set<Integer> skipCheck){ this.expr = expr; this.shift = shift; this.mask = mask; @@ -7726,66 +7760,217 @@ public static class CaseExpr extends UntypedExpr{ this.tests = tests; this.thens = thens; this.line = line; - this.allKeywords = allKeywords; + if (switchType != compactKey && switchType != sparseKey) + throw new IllegalArgumentException("Unexpected switch type: "+switchType); + this.switchType = switchType; + if (testType != intKey && testType != hashEquivKey && testType != hashIdentityKey) + throw new IllegalArgumentException("Unexpected test type: "+switchType); + this.testType = testType; + this.skipCheck = skipCheck; + Collection<Expr> returns = new ArrayList(thens.values()); + returns.add(defaultExpr); + this.returnType = maybeJavaClass(returns); + if(RT.count(skipCheck) > 0 && RT.booleanCast(RT.WARN_ON_REFLECTION.deref())) + { + RT.errPrintWriter() + .format("Performance warning, %s:%d - hash collision of some case test constants; if selected, those entries will be tested sequentially.\n", + SOURCE_PATH.deref(), line); + } + } + + public boolean hasJavaClass(){ + return returnType != null; + } + + public boolean canEmitPrimitive(){ + return Util.isPrimitive(returnType); + } + + public Class getJavaClass(){ + return returnType; } public Object eval() { throw new UnsupportedOperationException("Can't eval case"); } - public void emit(C context, ObjExpr objx, GeneratorAdapter gen){ + public void emit(C context, ObjExpr objx, GeneratorAdapter gen){ + doEmit(context, objx, gen, false); + } + + public void emitUnboxed(C context, ObjExpr objx, GeneratorAdapter gen){ + doEmit(context, objx, gen, true); + } + + public void doEmit(C context, ObjExpr objx, GeneratorAdapter gen, boolean emitUnboxed){ Label defaultLabel = gen.newLabel(); Label endLabel = gen.newLabel(); - HashMap<Integer,Label> labels = new HashMap(); + SortedMap<Integer,Label> labels = new TreeMap(); for(Integer i : tests.keySet()) { labels.put(i, gen.newLabel()); } - Label[] la = new Label[(high-low)+1]; + gen.visitLineNumber(line, gen.mark()); - for(int i=low;i<=high;i++) - { - la[i-low] = labels.containsKey(i) ? labels.get(i) : defaultLabel; - } + Class primExprClass = maybePrimitiveType(expr); + Type primExprType = primExprClass == null ? null : Type.getType(primExprClass); - gen.visitLineNumber(line, gen.mark()); - expr.emit(C.EXPRESSION, objx, gen); - gen.invokeStatic(UTIL_TYPE,hashMethod); - gen.push(shift); - gen.visitInsn(ISHR); - gen.push(mask); - gen.visitInsn(IAND); - gen.visitTableSwitchInsn(low, high, defaultLabel, la); + if (testType == intKey) + emitExprForInts(objx, gen, primExprType, defaultLabel); + else + emitExprForHashes(objx, gen); + + if (switchType == sparseKey) + { + Label[] la = new Label[labels.size()]; + la = labels.values().toArray(la); + int[] ints = Numbers.int_array(tests.keySet()); + gen.visitLookupSwitchInsn(defaultLabel, ints, la); + } + else + { + Label[] la = new Label[(high-low)+1]; + for(int i=low;i<=high;i++) + { + la[i-low] = labels.containsKey(i) ? labels.get(i) : defaultLabel; + } + gen.visitTableSwitchInsn(low, high, defaultLabel, la); + } for(Integer i : labels.keySet()) { gen.mark(labels.get(i)); - expr.emit(C.EXPRESSION, objx, gen); - tests.get(i).emit(C.EXPRESSION, objx, gen); - if(allKeywords) - { - gen.visitJumpInsn(IF_ACMPNE, defaultLabel); - } + if (testType == intKey) + emitThenForInts(objx, gen, primExprType, tests.get(i), thens.get(i), defaultLabel, emitUnboxed); + else if (RT.contains(skipCheck, i) == RT.T) + emitExpr(objx, gen, thens.get(i), emitUnboxed); else - { - gen.invokeStatic(UTIL_TYPE, equalsMethod); - gen.ifZCmp(GeneratorAdapter.EQ, defaultLabel); - } - thens.get(i).emit(C.EXPRESSION,objx,gen); + emitThenForHashes(objx, gen, tests.get(i), thens.get(i), defaultLabel, emitUnboxed); gen.goTo(endLabel); } gen.mark(defaultLabel); - defaultExpr.emit(C.EXPRESSION, objx, gen); + emitExpr(objx, gen, defaultExpr, emitUnboxed); gen.mark(endLabel); if(context == C.STATEMENT) gen.pop(); } + private boolean isShiftMasked(){ + return mask != 0; + } + + private void emitShiftMask(GeneratorAdapter gen){ + if (isShiftMasked()) + { + gen.push(shift); + gen.visitInsn(ISHR); + gen.push(mask); + gen.visitInsn(IAND); + } + } + + private void emitExprForInts(ObjExpr objx, GeneratorAdapter gen, Type exprType, Label defaultLabel){ + if (exprType == null) + { + if(RT.booleanCast(RT.WARN_ON_REFLECTION.deref())) + { + RT.errPrintWriter() + .format("Performance warning, %s:%d - case has int tests, but tested expression is not primitive.\n", + SOURCE_PATH.deref(), line); + } + expr.emit(C.EXPRESSION, objx, gen); + gen.instanceOf(NUMBER_TYPE); + gen.ifZCmp(GeneratorAdapter.EQ, defaultLabel); + expr.emit(C.EXPRESSION, objx, gen); + gen.checkCast(NUMBER_TYPE); + gen.invokeVirtual(NUMBER_TYPE, intValueMethod); + emitShiftMask(gen); + } + else if (exprType == Type.LONG_TYPE + || exprType == Type.INT_TYPE + || exprType == Type.SHORT_TYPE + || exprType == Type.BYTE_TYPE) + { + expr.emitUnboxed(C.EXPRESSION, objx, gen); + gen.cast(exprType, Type.INT_TYPE); + emitShiftMask(gen); + } + else + { + gen.goTo(defaultLabel); + } + } + + private void emitThenForInts(ObjExpr objx, GeneratorAdapter gen, Type exprType, Expr test, Expr then, Label defaultLabel, boolean emitUnboxed){ + if (exprType == null) + { + expr.emit(C.EXPRESSION, objx, gen); + test.emit(C.EXPRESSION, objx, gen); + gen.invokeStatic(UTIL_TYPE, equivMethod); + gen.ifZCmp(GeneratorAdapter.EQ, defaultLabel); + emitExpr(objx, gen, then, emitUnboxed); + } + else if (exprType == Type.LONG_TYPE) + { + ((NumberExpr)test).emitUnboxed(C.EXPRESSION, objx, gen); + expr.emitUnboxed(C.EXPRESSION, objx, gen); + gen.ifCmp(Type.LONG_TYPE, GeneratorAdapter.NE, defaultLabel); + emitExpr(objx, gen, then, emitUnboxed); + } + else if (exprType == Type.INT_TYPE + || exprType == Type.SHORT_TYPE + || exprType == Type.BYTE_TYPE) + { + if (isShiftMasked()) + { + ((NumberExpr)test).emitUnboxed(C.EXPRESSION, objx, gen); + expr.emitUnboxed(C.EXPRESSION, objx, gen); + gen.cast(exprType, Type.LONG_TYPE); + gen.ifCmp(Type.LONG_TYPE, GeneratorAdapter.NE, defaultLabel); + } + // else direct match + emitExpr(objx, gen, then, emitUnboxed); + } + else + { + gen.goTo(defaultLabel); + } + } + + private void emitExprForHashes(ObjExpr objx, GeneratorAdapter gen){ + expr.emit(C.EXPRESSION, objx, gen); + gen.invokeStatic(UTIL_TYPE,hashMethod); + emitShiftMask(gen); + } + + private void emitThenForHashes(ObjExpr objx, GeneratorAdapter gen, Expr test, Expr then, Label defaultLabel, boolean emitUnboxed){ + expr.emit(C.EXPRESSION, objx, gen); + test.emit(C.EXPRESSION, objx, gen); + if(testType == hashIdentityKey) + { + gen.visitJumpInsn(IF_ACMPNE, defaultLabel); + } + else + { + gen.invokeStatic(UTIL_TYPE, equivMethod); + gen.ifZCmp(GeneratorAdapter.EQ, defaultLabel); + } + emitExpr(objx, gen, then, emitUnboxed); + } + + private static void emitExpr(ObjExpr objx, GeneratorAdapter gen, Expr expr, boolean emitUnboxed){ + if (emitUnboxed && expr instanceof MaybePrimitiveExpr) + ((MaybePrimitiveExpr)expr).emitUnboxed(C.EXPRESSION,objx,gen); + else + expr.emit(C.EXPRESSION,objx,gen); + } + + static class Parser implements IParser{ - //(case* expr shift mask low high default map<minhash, [test then]> identity?) + //(case* expr shift mask default map<minhash, [test then]> table-type test-type skip-check?) //prepared by case macro and presumed correct //case macro binds actual expr in let so expr is always a local, //no need to worry about multiple evaluation @@ -7794,25 +7979,43 @@ public static class CaseExpr extends UntypedExpr{ if(context == C.EVAL) return analyze(context, RT.list(RT.list(FN, PersistentVector.EMPTY, form))); PersistentVector args = PersistentVector.create(form.next()); - HashMap<Integer,Expr> tests = new HashMap(); - HashMap<Integer,Expr> thens = new HashMap(); - LocalBindingExpr testexpr = (LocalBindingExpr) analyze(C.EXPRESSION, args.nth(0)); + Object exprForm = args.nth(0); + int shift = ((Number)args.nth(1)).intValue(); + int mask = ((Number)args.nth(2)).intValue(); + Object defaultForm = args.nth(3); + Map caseMap = (Map)args.nth(4); + Keyword switchType = ((Keyword)args.nth(5)); + Keyword testType = ((Keyword)args.nth(6)); + Set skipCheck = RT.count(args) < 8 ? null : (Set)args.nth(7); + + ISeq keys = RT.keys(caseMap); + int low = ((Number)RT.first(keys)).intValue(); + int high = ((Number)RT.nth(keys, RT.count(keys)-1)).intValue(); + + LocalBindingExpr testexpr = (LocalBindingExpr) analyze(C.EXPRESSION, exprForm); testexpr.shouldClear = false; - + + SortedMap<Integer,Expr> tests = new TreeMap(); + HashMap<Integer,Expr> thens = new HashMap(); + PathNode branch = new PathNode(PATHTYPE.BRANCH, (PathNode) CLEAR_PATH.get()); - for(Object o : ((Map)args.nth(6)).entrySet()) + + for(Object o : caseMap.entrySet()) { Map.Entry e = (Map.Entry) o; Integer minhash = ((Number)e.getKey()).intValue(); - MapEntry me = (MapEntry) e.getValue(); - Expr testExpr = new ConstantExpr(me.getKey()); - tests.put(minhash, testExpr); + Object pair = e.getValue(); // [test-val then-expr] + Expr testExpr = testType == intKey + ? NumberExpr.parse(((Number)RT.first(pair)).intValue()) + : new ConstantExpr(RT.first(pair)); + tests.put(minhash, testExpr); + Expr thenExpr; try { Var.pushThreadBindings( RT.map(CLEAR_PATH, new PathNode(PATHTYPE.PATH,branch))); - thenExpr = analyze(context, me.getValue()); + thenExpr = analyze(context, RT.second(pair)); } finally{ Var.popThreadBindings(); @@ -7824,21 +8027,15 @@ public static class CaseExpr extends UntypedExpr{ try { Var.pushThreadBindings( RT.map(CLEAR_PATH, new PathNode(PATHTYPE.PATH,branch))); - defaultExpr = analyze(context, args.nth(5)); + defaultExpr = analyze(context, args.nth(3)); } finally{ Var.popThreadBindings(); } - return new CaseExpr(((Number)LINE.deref()).intValue(), - testexpr, - ((Number)args.nth(1)).intValue(), - ((Number)args.nth(2)).intValue(), - ((Number)args.nth(3)).intValue(), - ((Number)args.nth(4)).intValue(), - defaultExpr, - tests,thens,args.nth(7) != RT.F); - + int line = ((Number)LINE.deref()).intValue(); + return new CaseExpr(line, testexpr, shift, mask, low, high, + defaultExpr, tests, thens, switchType, testType, skipCheck); } } } diff --git a/test/clojure/test_clojure/control.clj b/test/clojure/test_clojure/control.clj index 49cfe95b..3a7d4c3a 100644 --- a/test/clojure/test_clojure/control.clj +++ b/test/clojure/test_clojure/control.clj @@ -14,7 +14,7 @@ (ns clojure.test-clojure.control (:use clojure.test - [clojure.test-helper :only (exception)])) + clojure.test-helper)) ;; *** Helper functions *** @@ -323,6 +323,90 @@ :map (sorted-map :a 1 :b 2) :set #{3 2 1} :set (sorted-set 2 1 3)))) + (testing "test number equivalence" + (is (= :1 (case 1N 1 :1 :else)))) + (testing "test warn when boxing/hashing expr for all-ints case" + (should-print-err-message + #"Performance warning, .*:\d+ - case has int tests, but tested expression is not primitive..*\r?\n" + (let [x (Object.)] (case x 1 1 2)))) + (testing "test correct behavior on sparse ints" + (are [result input] (= result (case input + 2r1000000000000000000000000000000 :big + 1 :small + :else)) + :small 1 + :big 1073741824 + :else 2) + (are [result input] (= result (case input + 1 :small + 2r1000000000000000000000000000000 :big + :else)) + :small 1 + :big 1073741824 + :else 2)) + (testing "test emits return types" + (should-not-reflect (Long. (case 1 1 1))) ; new Long(long) + (should-not-reflect (Long. (case 1 1 "1")))) ; new Long(String) + (testing "non-equivalence of chars and nums" + (are [result input] (= result (case input 97 :97 :else)) + :else \a + :else (char \a) + :97 (int \a)) + (are [result input] (= result (case input \a :a :else)) + :else 97 + :else 97N + :a (char 97))) + (testing "test error on duplicate test constants" + (is (thrown-with-msg? + IllegalArgumentException + #"Duplicate case test constant: 1" + (eval `(case 0 1 :x 1 :y))))) + (testing "test correct behaviour on Number truncation" + (let [^Object x (Long. 8589934591) ; force bindings to not be emitted as a primitive long + ^Object y (Long. -1)] + (is (= :diff (case x -1 :oops :diff))) + (is (= :same (case y -1 :same :oops))))) + (testing "test correct behavior on hash collision" + (is (== (hash 1) (hash 9223372039002259457N))) + (are [result input] (= result (case input + 1 :long + 9223372039002259457N :big + :else)) + :long 1 + :big 9223372039002259457N + :else 4294967296 + :else 2) + (are [result input] (= result (case input + 9223372039002259457N :big + 1 :long + :else)) + :long 1 + :big 9223372039002259457N + :else 4294967296 + :else 2) + (are [result input] (= result (case input + 0 :zero + -1 :neg1 + 2 :two + :oops :OOPS)) + :zero 0 + :neg1 -1 + :two 2 + :OOPS :oops) + (are [result input] (= result (case input + 1204766517646190306 :a + 1 :b + -2 :c + :d)) + :a 1204766517646190306 + :b 1 + :c -2 + :d 4294967296 + :d 3)) + (testing "test warn for hash collision" + (should-print-err-message + #"Performance warning, .*:\d+ - hash collision of some case test constants; if selected, those entries will be tested sequentially..*\r?\n" + (case 1 1 :long 9223372039002259457N :big 2))) (testing "test constants are *not* evaluated" (let [test-fn ;; never write code like this... diff --git a/test/clojure/test_clojure/rt.clj b/test/clojure/test_clojure/rt.clj index 231e12c9..a70df2db 100644 --- a/test/clojure/test_clojure/rt.clj +++ b/test/clojure/test_clojure/rt.clj @@ -11,33 +11,6 @@ (ns clojure.test-clojure.rt (:use clojure.test clojure.test-helper)) -(defmacro with-err-print-writer - "Evaluate with err pointing to a temporary PrintWriter, and - return err contents as a string." - [& body] - `(let [s# (java.io.StringWriter.) - p# (java.io.PrintWriter. s#)] - (binding [*err* p#] - ~@body - (str s#)))) - -(defmacro with-err-string-writer - "Evaluate with err pointing to a temporary StringWriter, and - return err contents as a string." - [& body] - `(let [s# (java.io.StringWriter.)] - (binding [*err* s#] - ~@body - (str s#)))) - -(defmacro should-print-err-message - "Turn on all warning flags, and test that error message prints - correctly for all semi-reasonable bindings of *err*." - [msg-re form] - `(binding [*warn-on-reflection* true] - (is (re-matches ~msg-re (with-err-string-writer (eval-in-temp-ns ~form)))) - (is (re-matches ~msg-re (with-err-print-writer (eval-in-temp-ns ~form)))))) - (defn bare-rt-print "Return string RT would print prior to print-initialize" [x] diff --git a/test/clojure/test_helper.clj b/test/clojure/test_helper.clj index b5d11f43..2e8ba94a 100644 --- a/test/clojure/test_helper.clj +++ b/test/clojure/test_helper.clj @@ -95,3 +95,38 @@ reach certain point." [] (throw (new Exception "Exception which should never occur"))) + +(defmacro with-err-print-writer + "Evaluate with err pointing to a temporary PrintWriter, and + return err contents as a string." + [& body] + `(let [s# (java.io.StringWriter.) + p# (java.io.PrintWriter. s#)] + (binding [*err* p#] + ~@body + (str s#)))) + +(defmacro with-err-string-writer + "Evaluate with err pointing to a temporary StringWriter, and + return err contents as a string." + [& body] + `(let [s# (java.io.StringWriter.)] + (binding [*err* s#] + ~@body + (str s#)))) + +(defmacro should-print-err-message + "Turn on all warning flags, and test that error message prints + correctly for all semi-reasonable bindings of *err*." + [msg-re form] + `(binding [*warn-on-reflection* true] + (is (re-matches ~msg-re (with-err-string-writer (eval-in-temp-ns ~form)))) + (is (re-matches ~msg-re (with-err-print-writer (eval-in-temp-ns ~form)))))) + +(defmacro should-not-reflect + "Turn on all warning flags, and test that reflection does not occur + (as identified by messages to *err*)." + [form] + `(binding [*warn-on-reflection* true] + (is (nil? (re-find #"^Reflection warning" (with-err-string-writer (eval-in-temp-ns ~form))))) + (is (nil? (re-find #"^Reflection warning" (with-err-print-writer (eval-in-temp-ns ~form))))))) |