russell@unturf.com
99b0622520
Closes the remaining asm-side gaps from ticket 0005's follow-up
discussion. Every test in tests/cl-compat.lsp and tests/ursa.lsp
now runs unmodified on default asm (Scheme port) and asm-full (full
CL path) — no more commented-out tests or shim syntax.
Landed (all in default asm — useful beyond cl-compat):
* (values . xs) / (call-with-values producer consumer). values
packs a tagged pair (mval_marker . xs) when multiple; a lone arg
passes through unchanged so legacy single-value code is
undisturbed. call-with-values invokes the producer, destructures
the multi-value packet if present, applies consumer positionally.
The marker is a gensymed symbol interned once at init, so no
user-constructed pair can masquerade as a multi-value packet.
* (exit [code]) builtin. Default code is 0 when called with no
args. Passes through to the SYS_EXIT syscall.
* #(...) vector literal in the reader. .sr_hash now dispatches on
'(' as a vector literal alongside 't' and 'f'. list_to_vector_
reader is a standalone helper callable from the reader (separate
from bi_listtovec which uses the GETARG builtin convention).
Matches R7RS vector literal syntax. Existing vector builtins
already handled construction; this just teaches the reader.
* deep_equal extended to vectors. equal? now descends into vectors
(length + elementwise recursive compare), matching R7RS.
Previously only strings and pairs were handled; vectors fell
through to shallow pointer compare which only matched identical
heap objects.
Test file reverts (picking up the new capabilities):
* tests/cl-compat.lsp — multiple-value-bind test restored
(previously commented out because asm lacked values /
call-with-values).
* tests/ursa-scheme.lsp — #(1 0 1 0 1 0) literal restored
(previously worked around with (vector->list (digits ...)));
(exit 1) failure trailer restored (previously removed because
asm had no exit builtin).
* tests/ursa.lsp — same digits literal restoration.
Verified:
* asm regression: 158/158.
* asm-full regression: 158/158.
* Zoë-favorites across Python + C + asm + asm-full: all suites
green with native reader syntax and multi-value tests.
* make test-all stays green.
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))
|