russell@unturf.com
192118388f
Zoë Trout's favorites at wedgewack.org/ursa.lisp.txt are Common Lisp:
iterative LOOP macros, setf cascades, defun with &optional, image-
based stone-lisp culture. Her first contribution to lumbda was a
question — "do we care for our programs, and how long are they alive
for?" — and the answer now extends beyond the RNG portal (§7.5) to
iteration style itself.
Four-phase delivery, all under ticket 0004:
Phase A — idiomatic Scheme ports at examples/ursa-scheme.lsp.
Every Zoë defun rewritten as named-let + tail recursion + list-
backed work queue + type-predicate dispatch.
Phase B — CL compat shim at cl-compat.lsp.
defun (with &optional), setf (simple vars, multi-pair), flet,
multiple-value-bind, t / nil (nil=#f so cond/if compose),
evenp/oddp/plusp/minusp/zerop, mod/ash/logbitp/nreverse,
cl-when/cl-unless (plain when is a void-returning lumbda special
form), declare (no-op), cddddr (missing accessor).
Phase C — cl-loop macro covering 14 patterns.
while/until/repeat, for VAR from A to/below/downto B, for VAR =
INIT [then STEP], for VAR across VEC, of-type T, do, when/unless
return, finally (return VAL). Sequential do*-style stepping via
gensym + cl-subst. Look-ahead termination so `repeat 4 for s = 4
then (- (* s s) 2) finally (return s)` returns 37634 (pre-step)
rather than 1416317954 (post-step). Every expansion ends in a
named-let tail call — TCO holds for loops of any length.
Phase D — load examples/ursa.lisp.txt with minimal annotation.
Preserves Zoë's CL. Minimal edits documented in file header:
load cl-compat.lsp, loop→cl-loop, when→cl-when, random→random-int,
&key→&optional. rho/digits omitted (need make-array/CLOS — see
ticket 0004 for scope boundary).
Defect uncovered along the way (c/types.c env_lookup): a "global
shortcut" checked global env immediately after missing the local
frame, SKIPPING intermediate parent scopes. Broke lexical scoping
whenever a parent scope shadowed a global. Reproduced with
(define s 4)
(let ((s 100)) (let ((m 0)) s)) ; returned 4, should return 100
Any nested let whose body referenced a shadowed name silently read
the global. Fix: remove the shortcut, walk the parent chain end-to-
end. 1255 assertions across five suites pass unchanged after fix —
surfaced only because cl-loop iterator names routinely collide with
globals accumulated in a stone-lisp image.
Whitepaper §9.2 documents the CL-in-Scheme design and the guarantees
that survive (TCO, portal determinism, cross-impl reproducibility).
Zoë added to authors + acknowledgments; reacknowledgment reframes
her first contribution as the deeper program-lifetime question, with
RNG portal as a derivative (§7.5) and cl-loop as the follow-up.
Tests: tests/cl-compat.lsp (44 assertions) and tests/ursa.lsp (28
assertions) exercise both paths under Python + C via tests/zoe-
favorites-test.sh, wired into make test-all.
MOAD notes: unmoad flags memq/assq in cl-compat.lsp over cl-loop-
keywords (~30 elements, constant) and var->new (≤4 state vars per
loop). Both are macro-expansion-time, bounded-small-N — not runtime
hot paths. Pre-existing c/types.c findings (strcmp-in-loop for
record-type lookup) are not from this change.
171 lines
6.4 KiB
Common Lisp
171 lines
6.4 KiB
Common Lisp
;; tests/cl-compat.lsp — exercises the CL compatibility shim.
|
|
;; Runs in both Python and C via make test-zoe-favorites.
|
|
(load "cl-compat.lsp")
|
|
|
|
(define *pass* 0)
|
|
(define *fail* 0)
|
|
(define (check name got expected)
|
|
(cond ((equal? got expected)
|
|
(set! *pass* (+ *pass* 1))
|
|
(display "PASS: ") (display name) (newline))
|
|
(else
|
|
(set! *fail* (+ *fail* 1))
|
|
(display "FAIL: ") (display name)
|
|
(display " got=") (write got)
|
|
(display " expected=") (write expected) (newline))))
|
|
|
|
;; ── constants ────────────────────────────────────────────────────
|
|
(check "t" t #t)
|
|
(check "nil" nil #f)
|
|
|
|
;; ── predicates ───────────────────────────────────────────────────
|
|
(check "evenp-4" (evenp 4) #t)
|
|
(check "oddp-3" (oddp 3) #t)
|
|
(check "plusp-5" (plusp 5) #t)
|
|
(check "minusp-n" (minusp -5) #t)
|
|
(check "zerop-0" (zerop 0) #t)
|
|
|
|
;; ── arithmetic ───────────────────────────────────────────────────
|
|
(check "mod-10-3" (mod 10 3) 1)
|
|
(check "ash-1-3" (ash 1 3) 8)
|
|
(check "ash-8-n3" (ash 8 -3) 1)
|
|
(check "ash-255-n4" (ash 255 -4) 15)
|
|
|
|
;; ── logbitp ──────────────────────────────────────────────────────
|
|
(check "logbitp-0-6" (logbitp 0 6) #f)
|
|
(check "logbitp-1-6" (logbitp 1 6) #t)
|
|
(check "logbitp-2-6" (logbitp 2 6) #t)
|
|
(check "logbitp-3-6" (logbitp 3 6) #f)
|
|
|
|
;; ── list ops ─────────────────────────────────────────────────────
|
|
(check "nreverse" (nreverse (list 1 2 3)) '(3 2 1))
|
|
|
|
;; ── cl-when / cl-unless ──────────────────────────────────────────
|
|
(check "cl-when-t" (cl-when #t 1 2 3) 3)
|
|
(check "cl-when-f" (cl-when #f 1 2 3) #f)
|
|
(check "cl-unless-t" (cl-unless #t 1 2 3) #f)
|
|
(check "cl-unless-f" (cl-unless #f 1 2 3) 3)
|
|
|
|
;; ── defun ────────────────────────────────────────────────────────
|
|
(defun square-it (x) (* x x))
|
|
(check "defun-basic" (square-it 7) 49)
|
|
|
|
(defun greet (who &optional (greeting "hello"))
|
|
(list greeting who))
|
|
(check "defun-opt-default" (greet 'world) '("hello" world))
|
|
(check "defun-opt-provided" (greet 'world "bonjour") '("bonjour" world))
|
|
|
|
(defun maybe (x &optional y)
|
|
(if (null? y) 'no-y (list x y)))
|
|
(check "defun-opt-nil" (maybe 1) 'no-y)
|
|
(check "defun-opt-given" (maybe 1 2) '(1 2))
|
|
|
|
;; ── setf ─────────────────────────────────────────────────────────
|
|
(define x 10)
|
|
(setf x 20)
|
|
(check "setf-single" x 20)
|
|
|
|
(define a 1) (define b 2) (define c 3)
|
|
(setf a 100 b 200 c 300)
|
|
(check "setf-multi-a" a 100)
|
|
(check "setf-multi-b" b 200)
|
|
(check "setf-multi-c" c 300)
|
|
|
|
;; ── flet ─────────────────────────────────────────────────────────
|
|
(check "flet"
|
|
(flet ((double (n) (* 2 n))
|
|
(triple (n) (* 3 n)))
|
|
(+ (double 5) (triple 5)))
|
|
25)
|
|
|
|
;; ── multiple-value-bind ──────────────────────────────────────────
|
|
(check "mvb"
|
|
(multiple-value-bind (q r) (values 7 3) (list q r))
|
|
'(7 3))
|
|
|
|
;; ── cl-loop: 14 representative patterns ─────────────────────────
|
|
|
|
;; 1. while + do
|
|
(define counter 0)
|
|
(cl-loop while (< counter 5) do (setf counter (+ counter 1)))
|
|
(check "loop-while-do" counter 5)
|
|
|
|
;; 2. while + multi-setf
|
|
(define d 16) (define s 0)
|
|
(cl-loop while (evenp d) do (setf d (ash d -1) s (1+ s)))
|
|
(check "loop-while-multi-d" d 1)
|
|
(check "loop-while-multi-s" s 4)
|
|
|
|
;; 3. while + finally return
|
|
(define u 10)
|
|
(check "loop-while-finally"
|
|
(cl-loop while (> u 0) do (setf u (- u 1)) finally (return u))
|
|
0)
|
|
|
|
;; 4. repeat + simple-for + unless return + finally
|
|
(check "loop-repeat-simple-unless"
|
|
(cl-loop repeat 5 for av = 3 unless (> av 0) return 'early finally (return 'done))
|
|
'done)
|
|
|
|
;; 5. repeat + when return
|
|
(check "loop-repeat-when-return"
|
|
(let ((k 0))
|
|
(cl-loop repeat 10 do (setf k (+ k 1))
|
|
when (= k 3) return 'got-three
|
|
finally (return 'not-hit)))
|
|
'got-three)
|
|
|
|
;; 6. repeat + then accumulator + finally
|
|
(check "loop-repeat-then"
|
|
(cl-loop repeat 4 for sv of-type integer = 4 then (- (* sv sv) 2) finally (return sv))
|
|
37634)
|
|
|
|
;; 7. range to + then accumulator
|
|
(check "loop-range-to-then"
|
|
(cl-loop for i from 0 to 4 for j = 1 then (+ j (expt 2 i)) finally (return j))
|
|
31)
|
|
|
|
;; 8. range below + do
|
|
(define acc '())
|
|
(cl-loop for i from 0 below 5 do (set! acc (cons i acc)))
|
|
(check "loop-range-below" (reverse acc) '(0 1 2 3 4))
|
|
|
|
;; 9. range downto + then accumulator
|
|
(check "loop-range-downto-then"
|
|
(cl-loop for i from 4 downto 0 for sum = (expt 2 i) then (+ sum (expt 2 i)) finally (return sum))
|
|
31)
|
|
|
|
;; 10. with + across + finally
|
|
(check "loop-with-across"
|
|
(cl-loop with result = 0 for digit across (vector 1 2 3 4 5)
|
|
do (setf result (+ (* result 10) digit))
|
|
finally (return result))
|
|
12345)
|
|
|
|
;; 11. simple-for (infinite) + when return
|
|
(check "loop-infinite-when"
|
|
(let ((gen 0))
|
|
(cl-loop for i = (begin (set! gen (+ gen 1)) gen)
|
|
when (> i 3) return i))
|
|
4)
|
|
|
|
;; 12. simple-for + until + finally (body variant)
|
|
(check "loop-simple-until-finally-body"
|
|
(let ((found 0))
|
|
(cl-loop for dv = (if (= found 0) #f 42)
|
|
until dv
|
|
do (set! found 1)
|
|
finally (set! found (+ found 100)))
|
|
found)
|
|
101)
|
|
|
|
;; 13. declare (no-op) inside defun
|
|
(defun decl-fn (x)
|
|
(declare (optimize (speed 3)) (type integer x))
|
|
(* x x))
|
|
(check "declare-noop" (decl-fn 9) 81)
|
|
|
|
(display "══════════════════════════════") (newline)
|
|
(display "cl-compat: ") (display *pass*) (display " passed, ")
|
|
(display *fail*) (display " failed") (newline)
|
|
(if (> *fail* 0) (exit 1))
|