From d38be8737354617f5289d0bde40307ed766a56a7 Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Sat, 15 Aug 2026 19:43:07 +0200 Subject: [PATCH 1/2] implement the car and cdr setf places Both places were commented out at the initial commit under "something is fishy with these". The quasiquoted builders are correct as written; what would have failed is the call, which used a bare `register-place` at a point in the file where only `Setf.register-place` resolves. Qualifying it makes both work, so they keep their original quasiquoted shape. Both expand to a `set!` of the place's argument, so that argument has to be a symbol. A non-symbol used to expand to nonsense like `(set! (foo) ...)`; it now raises a macro error naming the place and the offending form. The two tests are enabled exactly as they were written: a dynamic function returning a bare list can be a hazard, but `Test.dynhandler` stringifies both sides with `str` before emitting the comparison, so the list is never evaluated as code. --- Setf.carp | 35 +++++++++++++++++++++++++++++------ docs/Setf.html | 9 +++++++++ test/non-symbol-place.carp | 4 ++++ test/setf.carp | 38 +++++++++++++++++++++++--------------- 4 files changed, 65 insertions(+), 21 deletions(-) create mode 100644 test/non-symbol-place.carp diff --git a/Setf.carp b/Setf.carp index 91dbc8a..1b1502f 100644 --- a/Setf.carp +++ b/Setf.carp @@ -46,6 +46,13 @@ Example: (defndynamic get-place [n] (Map.get Setf.places n)) + (hidden place-symbol) + (defndynamic place-symbol [name args] + (let [target (car args)] + (if (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 +85,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.") diff --git a/docs/Setf.html b/docs/Setf.html index 1e18d90..62f9242 100644 --- a/docs/Setf.html +++ b/docs/Setf.html @@ -34,6 +34,15 @@

setf that allows you to register your own places using 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.

diff --git a/test/non-symbol-place.carp b/test/non-symbol-place.carp new file mode 100644 index 0000000..a278a13 --- /dev/null +++ b/test/non-symbol-place.carp @@ -0,0 +1,4 @@ +(load "../Setf.carp") +(use Setf) + +(setf (car (list 1 2 3)) 9) diff --git a/test/setf.carp b/test/setf.carp index 12fb977..ff830e3 100644 --- a/test/setf.carp +++ b/test/setf.carp @@ -16,22 +16,30 @@ (load "Test.carp") (use-all Test Setf) +; a macro error aborts the compiler, so this path needs a child run +(shell "{ carp -x test/non-symbol-place.carp 2>&1 | grep -q 'can only update a symbol' && printf caught || printf missed ; } > /tmp/setf-non-symbol-place.txt") +(defdynamic non-symbol-place (read-file "/tmp/setf-non-symbol-place.txt")) + (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-place + "setf rejects a car place that is not a symbol" + ) (assert-equal test &[1 2 3] &(let-do [x [1 3 3]] From f1a366cfa9ce969160df9140074c4a82531037ad Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Sun, 16 Aug 2026 00:57:43 +0200 Subject: [PATCH 2/2] address review: fail-closed guard fixture, arity check, cdr fixture The assertion that proves the symbol guard exists could pass vacuously. `shell` swallows failures (`commandShell` catches and returns nil), so a failed marker write left `read-file` picking up the previous run's answer. With the guard deleted and a stale read-only /tmp marker in place, the suite reported 9/0 exit 0. Removing the marker before writing it closes that: `read-file` on a missing file aborts the run, so a failed write can no longer be mistaken for a green check. The marker also moves out of the shared /tmp namespace into test/, and is removed again once it has been read, so a leftover now means an aborted run rather than normal operation. `place-symbol` validated `(car args)` but nothing constrained arity, and the builders read the value with `(cadr args)`, so `(setf (car x y) 999)` silently wrote `y` into the head and dropped `999`. The registered runtime places reject over-application as a type error; this now errors too. Fixtures added for the cdr side of the guard and for the arity check, both via the same helper as the car one. Verified: suite 11/0 exit 0; deleting the guard with a stale read-only marker present now gives exit 3 / 8 pass 3 fail; deleting only the arity branch gives exit 1 / 10 pass 1 fail. gendocs exits 0 and leaves docs/ clean; angler is clean on all five files. --- Setf.carp | 7 ++-- test/extra-args-place.carp | 7 ++++ ...l-place.carp => non-symbol-car-place.carp} | 0 test/non-symbol-cdr-place.carp | 4 +++ test/setf.carp | 32 ++++++++++++++++--- 5 files changed, 44 insertions(+), 6 deletions(-) create mode 100644 test/extra-args-place.carp rename test/{non-symbol-place.carp => non-symbol-car-place.carp} (100%) create mode 100644 test/non-symbol-cdr-place.carp diff --git a/Setf.carp b/Setf.carp index 1b1502f..cb69053 100644 --- a/Setf.carp +++ b/Setf.carp @@ -49,8 +49,11 @@ Example: (hidden place-symbol) (defndynamic place-symbol [name args] (let [target (car args)] - (if (symbol? target) - target + (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) diff --git a/test/extra-args-place.carp b/test/extra-args-place.carp new file mode 100644 index 0000000..bd6095c --- /dev/null +++ b/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) diff --git a/test/non-symbol-place.carp b/test/non-symbol-car-place.carp similarity index 100% rename from test/non-symbol-place.carp rename to test/non-symbol-car-place.carp diff --git a/test/non-symbol-cdr-place.carp b/test/non-symbol-cdr-place.carp new file mode 100644 index 0000000..e71706e --- /dev/null +++ b/test/non-symbol-cdr-place.carp @@ -0,0 +1,4 @@ +(load "../Setf.carp") +(use Setf) + +(setf (cdr (list 1 2 3)) '(9)) diff --git a/test/setf.carp b/test/setf.carp index ff830e3..900d7be 100644 --- a/test/setf.carp +++ b/test/setf.carp @@ -16,9 +16,23 @@ (load "Test.carp") (use-all Test Setf) -; a macro error aborts the compiler, so this path needs a child run -(shell "{ carp -x test/non-symbol-place.carp 2>&1 | grep -q 'can only update a symbol' && printf caught || printf missed ; } > /tmp/setf-non-symbol-place.txt") -(defdynamic non-symbol-place (read-file "/tmp/setf-non-symbol-place.txt")) +; 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 (assert-dynamic-equal test @@ -37,9 +51,19 @@ ) (assert-dynamic-equal test "caught" - non-symbol-place + 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]]