Make assoc a macro instead of a special form

The new macro evaluates its lvalue only once.

NEWS

@@ -32,6 +32,7 @@ Changes from 0.13.0
    * try form now possible in defmacro/deftag
    * Fixed a crash when `with` suppresses an exception. `with` now returns
      `None` in this case.
+   * `assoc` now evaluates its arguments only once each
 
    [ Misc. Improvements ]
    * `read`, `read_str`, and `eval` are exposed and documented as top-level

hy/compiler.py

@@ -1406,30 +1406,6 @@ class HyASTCompiler(object):
                             step=step.expr),
             ctx=ast.Load())
 
-    @builds("assoc")
-    @checkargs(min=3, even=False)
-    def compile_assoc_expression(self, expr):
-        expr.pop(0)  # assoc
-        # (assoc foo bar baz)  => foo[bar] = baz
-        target = self.compile(expr.pop(0))
-        ret = target
-        i = iter(expr)
-        for (key, val) in ((self.compile(x), self.compile(y))
-                           for (x, y) in zip(i, i)):
-
-            ret += key + val + ast.Assign(
-                lineno=expr.start_line,
-                col_offset=expr.start_column,
-                targets=[
-                    ast.Subscript(
-                        lineno=expr.start_line,
-                        col_offset=expr.start_column,
-                        value=target.force_expr,
-                        slice=ast.Index(value=key.force_expr),
-                        ctx=ast.Store())],
-                value=val.force_expr)
-        return ret
-
     @builds("with_decorator")
     @checkargs(min=1)
     def compile_decorate_expression(self, expr):

hy/core/language.hy

@@ -328,9 +328,9 @@
     (do
       (defn merge-entry [m e]
         (setv k (get e 0) v (get e 1))
-        (if (in k m)
-          (assoc m k (f (get m k) v))
-          (assoc m k v))
+        (setv (get m k) (if (in k m)
+                          (f (get m k) v)
+                          v))
         m)
       (defn merge2 [m1 m2]
         (reduce merge-entry (.items m2) (or m1 {})))

hy/core/macros.hy

@@ -20,6 +20,22 @@
          ~@(interleave (repeat name) rest))
      ~name))
 
+
+(defmacro assoc [coll k1 v1 &rest other-kvs]
+  (if (odd? (len other-kvs))
+    (macro-error (last other-kvs)
+                 "`assoc` takes an odd number of arguments"))
+  (setv c (if other-kvs
+            (gensym "c")
+            coll))
+  `(setv ~@(+ (if other-kvs
+                [c coll]
+                [])
+              #* (genexpr [`(get ~c ~k) v]
+                          [[k v] (partition (+ (, k1 v1)
+                                               other-kvs))]))))
+
+
 (defmacro with [args &rest body]
   "shorthand for nested with* loops:
   (with [x foo y bar] baz) ->

tests/native_tests/language.hy

@@ -628,12 +628,27 @@
   (assoc vals "two" "three")
   (assert (= (get vals "two") "three")))
 
+
 (defn test-multiassoc []
   "NATIVE: test assoc multiple values"
   (setv vals {"one" "two"})
   (assoc vals "two" "three" "four" "five")
   (assert (and (= (get vals "two") "three") (= (get vals "four") "five") (= (get vals "one") "two"))))
 
+
+(defn test-assoc-eval-lvalue-once []
+  ;; https://github.com/hylang/hy/issues/1068
+  "`assoc` only evaluates its lvalue once"
+  (setv counter [])
+  (setv d {})
+  (defn f []
+    (.append counter 1)
+    d)
+  (assoc (f)  "a" 1  "b" 2  "c" 3)
+  (assert (= d {"a" 1  "b" 2  "c" 3}))
+  (assert (= counter [1])))
+
+
 (defn test-pass []
   "NATIVE: Test pass worksish"
   (if True (do) (do))