implement the car and cdr setf places

Setf.carp

@@ -46,6 +46,16 @@ Example:
   (defndynamic get-place [n]
     (Map.get Setf.places n))
 
+  (hidden place-symbol)
+  (defndynamic place-symbol [name args]
+    (let [target (car args)]
+      (cond
+        (/= 2 (length args))
+          (macro-error (list "The `setf` place " name " takes exactly one argument, but got " (- (length args) 1)))
+        (symbol? target)
+          target
+        (macro-error (list "The `setf` place " name " can only update a symbol, but got " target)))))
+
   (hidden malformed)
   (defdynamic malformed (gensym-with 'place-malformed))
 
@@ -78,13 +88,29 @@ x ; => [1 10 3]
 (Setf.register-simple-place 'sym 'set!)
 (Setf.register-simple-place 'nth 'Array.aset!)
 (Setf.register-simple-place 'char-at 'String.string-set!)
-; something is fishy with these
-;(register-place 'car
-;  (fn [args] `(set! %(car args) (cons %(cadr args) (cdr %(car args))))))
-;(register-place 'cdr
-;  (fn [args] `(set! %(car args) (cons (car %(car args)) %(cadr args)))))
+(Setf.register-place 'car
+  (fn [args]
+    (let [target (Setf.place-symbol 'car args)]
+      `(set! %target (cons %(cadr args) (cdr %target))))))
+(Setf.register-place 'cdr
+  (fn [args]
+    (let [target (Setf.place-symbol 'cdr args)]
+      `(set! %target (cons (car %target) %(cadr args))))))
 
 (doc Setf "is a module that emulates a simple version of
 [`setf`](http://www.lispworks.com/documentation/HyperSpec/Body/m_setf_.htm#setf)
 that allows you to register your own places using
-[`register-place`](#register-place).")
+[`register-place`](#register-place).
+
+The places that come registered out of the box are a bare symbol, `nth` and
+`char-at`, which all set values at runtime, and `car` and `cdr`, which set the
+head and tail of a dynamic list at macro time:
+
+```
+(defdynamic x '(2 2 3))
+(setf (car x) 1)
+x ; => (1 2 3)
+```
+
+Because `car` and `cdr` expand to a `set!` of the list itself, their argument
+has to be a symbol; anything else is a macro error.")

docs/Setf.html

@@ -34,6 +34,15 @@ <h1>
 <a href="http://www.lispworks.com/documentation/HyperSpec/Body/m_setf_.htm#setf"><code>setf</code></a>
 that allows you to register your own places using
 <a href="#register-place"><code>register-place</code></a>.</p>
+<p>The places that come registered out of the box are a bare symbol, <code>nth</code> and
+<code>char-at</code>, which all set values at runtime, and <code>car</code> and <code>cdr</code>, which set the
+head and tail of a dynamic list at macro time:</p>
+<pre><code>(defdynamic x '(2 2 3))
+(setf (car x) 1)
+x ; =&gt; (1 2 3)
+</code></pre>
+<p>Because <code>car</code> and <code>cdr</code> expand to a <code>set!</code> of the list itself, their argument
+has to be a symbol; anything else is a macro error.</p>
 
                 </div>
                 <div class="binder">

test/extra-args-place.carp

@@ -0,0 +1,7 @@
+(load "../Setf.carp")
+(use Setf)
+
+(defdynamic y 77)
+(defdynamic x '(1 2 3))
+
+(setf (car x y) 999)

test/non-symbol-car-place.carp

@@ -0,0 +1,4 @@
+(load "../Setf.carp")
+(use Setf)
+
+(setf (car (list 1 2 3)) 9)

test/non-symbol-cdr-place.carp

@@ -0,0 +1,4 @@
+(load "../Setf.carp")
+(use Setf)
+
+(setf (cdr (list 1 2 3)) '(9))

test/setf.carp

@@ -16,22 +16,54 @@
 (load "Test.carp")
 (use-all Test Setf)
 
+; a macro error aborts the compiler, so these paths need a child run
+(defndynamic fixture-outcome [fixture pattern]
+  (let-do [marker (str "test/." fixture ".outcome")]
+    ; removing first means a failed write aborts read-file instead of reading stale
+    (shell (str "rm -f " marker))
+    (shell (str "{ carp -x test/" fixture ".carp 2>&1 | grep -q '" pattern
+                "' && printf caught || printf missed ; } > " marker))
+    (let-do [outcome (read-file marker)]
+      (shell (str "rm -f " marker))
+      outcome)))
+
+(defdynamic non-symbol-car
+  (fixture-outcome "non-symbol-car-place" "can only update a symbol"))
+(defdynamic non-symbol-cdr
+  (fixture-outcome "non-symbol-cdr-place" "can only update a symbol"))
+(defdynamic extra-args
+  (fixture-outcome "extra-args-place" "takes exactly one argument"))
+
 (deftest test
-  ; as of yet unimplemented
-  ;(assert-dynamic-equal test
-  ;                      '(1 2 3)
-  ;                      (let-do [x '(2 2 3)]
-  ;                        (setf (car x) 1)
-  ;                        x)
-  ;                      "setf works for car"
-  ;)
-  ;(assert-dynamic-equal test
-  ;                      '(1 2)
-  ;                      (let-do [x '(1 2 3)]
-  ;                        (setf (cdr x) '(2))
-  ;                        x)
-  ;                      "setf works for cdr"
-  ;)
+  (assert-dynamic-equal test
+                        '(1 2 3)
+                        (let-do [x '(2 2 3)]
+                          (setf (car x) 1)
+                          x)
+                        "setf works for car"
+  )
+  (assert-dynamic-equal test
+                        '(1 2)
+                        (let-do [x '(1 2 3)]
+                          (setf (cdr x) '(2))
+                          x)
+                        "setf works for cdr"
+  )
+  (assert-dynamic-equal test
+                        "caught"
+                        non-symbol-car
+                        "setf rejects a car place that is not a symbol"
+  )
+  (assert-dynamic-equal test
+                        "caught"
+                        non-symbol-cdr
+                        "setf rejects a cdr place that is not a symbol"
+  )
+  (assert-dynamic-equal test
+                        "caught"
+                        extra-args
+                        "setf rejects a car place with extra arguments"
+  )
   (assert-equal test
                 &[1 2 3]
                 &(let-do [x [1 3 3]]