russell@unturf.com
c6658e03a4
Four fixes that turn the asm-full infrastructure from "loads cl-compat
but crashes on cl-loop-emit output" into "runs Zoë Trout's full CL
test suite (18/19) end-to-end." Zoë's original `examples/ursa.lisp.txt`
now produces matching answers to the Python and C tiers on asm-full.
1. asm/lumbda.s bi_apply — second arg was being clobbered. The
previous impl did `GETARG %rbx; GETARG %rdi; movq %rbx, %rdi;
... movq %r12, %rsi` — so the args-list got overwritten by the
proc, and %r12 (empty after two GETARGs) became the arg list
instead. `(apply f '(1 2 3))` silently reduced to `(f)`. Fix:
`GETARG %rbx; GETARG %rsi; movq %rbx, %rdi; call apply_proc_raw`.
2. asm/lumbda.s bi_expt — decrements rcx by 1 until zero. Negative
exponents looped forever. cl-loop's look-ahead termination stages
step values in a let* BEFORE the terminate check, so a range that
ends at 0 ends up evaluating `(expt 2 -1)` on the last step. Fix:
guard negative exponents, return 0. asm is integer-only; returning
a rational would need a new type. Zero truncates the out-of-range
iter's contribution, which the look-ahead termination discards
anyway — the result is correct.
3. asm/lumbda.s GC roots — macro_env_head was not marked. Under
GC_NAIVE (which CL_FULL implies), any collection during a macro-
heavy workload (like miller-rabin's expanding cl-loops) reclaimed
the macro table nodes. Next use failed with "unbound variable:
cl-when" or similar. Fix: mark macro_env_head alongside the
global env (same 24-byte (sym, val, next) shape as env nodes, so
gc_mark_env handles it). Guarded .ifdef CL_FULL.
4. asm/lumbda.s prelude — added `cadar` (used by
cl-loop-finalizer-expr). The previous omission triggered an
"unbound variable: cadar" in any cl-loop with a `finally (return
X)` finalizer.
5. cl-compat.lsp — two new helpers routed around asm's reduced
list-processing builtins:
* `cl-append` for n-list concatenation. asm's builtin `append`
is 2-arg only; cl-loop-emit appends five spec groups
(range + then + simple + across + counter). Reducing with
2-arg append works on every tier.
* `cl-zip` for parallel 2-list zip (already in earlier commit,
mentioned here for completeness — asm's `map` is single-list
only).
Verification on asm/lumbda-full:
* /tmp/ursa-load-test.lsp — 18/19 pass (the one remaining fail
is a random-state expectation, not an asm bug).
* (primep 97) → 97
* (primep 100) → #f
* (lucas-lehmer-primep 13) → #t (M₁₃ = 8191, prime)
* (lucas-lehmer-primep 11) → #f (M₁₁ = 2047 = 23·89)
* (of-n-bits 8) → random integer in [128, 256) with top bit set
* (prime-of-n-bits 8) → random 8-bit prime
make test-all stays green. All three asm variants still 158/158 on
their local test suites. asm's minimal footprint preserved — every
new line above is under .ifdef CL_FULL except the expt/apply fixes,
which are general correctness improvements independent of CL.
564 lines
24 KiB
Text
564 lines
24 KiB
Text
;;; cl-compat.lsp — Common Lisp compatibility shim for lumbda.
|
|
;;;
|
|
;;; Purpose: let Common Lisp programs — especially Zoë Trout's favorites
|
|
;;; at wedgewack.org/ursa.lisp.txt — load with minimal rewriting. Adds
|
|
;;; CL spellings on top of lumbda's functional core. Does not compromise
|
|
;;; TCO, portal determinism, or cross-impl reproducibility — every shim
|
|
;;; here is syntactic sugar over existing lumbda primitives or tail-
|
|
;;; recursive expansions.
|
|
;;;
|
|
;;; Load explicitly: (load "cl-compat.lsp")
|
|
;;; Not auto-loaded; it shadows `when`/`unless` with CL return semantics.
|
|
;;;
|
|
;;; Coverage:
|
|
;;; Constants: t, nil
|
|
;;; Predicates: evenp, oddp, plusp, minusp, zerop
|
|
;;; Arithmetic: mod, ash, logbitp
|
|
;;; Lists: nreverse (non-destructive)
|
|
;;; Control: when, unless (CL semantics — return nil on false)
|
|
;;; Binding: defun (with &optional), setf (simple vars, multi-pair), flet
|
|
;;; Values: multiple-value-bind
|
|
;;;
|
|
;;; Not covered (by design — see ticket 0004):
|
|
;;; &key args — positional only. repunit-value uses a rest-list fallback.
|
|
;;; defgeneric — hand-port dispatch to (cond ((type? ...)) ...).
|
|
;;; make-array :adjustable :fill-pointer — hand-port to list or vector.
|
|
;;;
|
|
;;; Companion: examples/ursa.lisp.txt ships Zoë's favorites as Scheme
|
|
;;; ports; this shim exists so her CL source can also load unchanged
|
|
;;; (after Phase C + Phase D land — see ticket 0004).
|
|
|
|
;; ── constants ────────────────────────────────────────────────────
|
|
;; nil binds to #f, not '(). In CL, nil is simultaneously the empty
|
|
;; list AND false. Scheme separates these — #f is false, '() is the
|
|
;; empty list and is truthy in Scheme. Since CL code most often uses
|
|
;; nil as a boolean (e.g. `(return nil)` from a `loop`, `(cond (test
|
|
;; nil))`), binding nil to #f makes those paths work under Scheme's
|
|
;; cond/if. CL code that uses nil as an empty list is rarer and can
|
|
;; substitute '() directly.
|
|
(define t #t)
|
|
(define nil #f)
|
|
|
|
;; ── predicate aliases (CL -p suffix) ─────────────────────────────
|
|
(define evenp even?)
|
|
(define oddp odd?)
|
|
(define plusp positive?)
|
|
(define minusp negative?)
|
|
(define zerop zero?)
|
|
|
|
;; ── arithmetic ───────────────────────────────────────────────────
|
|
(define (mod a b) (modulo a b))
|
|
|
|
;; Arithmetic shift: left for k>=0, right for k<0.
|
|
(define (ash n k)
|
|
(if (>= k 0)
|
|
(* n (expt 2 k))
|
|
(quotient n (expt 2 (- k)))))
|
|
|
|
;; Bit-i test. (logbitp 0 6) = #f, (logbitp 1 6) = #t, (logbitp 2 6) = #t.
|
|
(define (logbitp i n)
|
|
(odd? (ash n (- i))))
|
|
|
|
;; ── list ops ─────────────────────────────────────────────────────
|
|
;; Lumbda has no mutable list spine; non-destructive reverse serves.
|
|
;; Code that relied on nreverse's in-place semantics still gets the
|
|
;; right answer — just a fresh allocation instead of reuse.
|
|
(define nreverse reverse)
|
|
|
|
;; ── cl-when / cl-unless — CL-flavored when/unless ────────────────
|
|
;; Plain `when`/`unless` in lumbda are hardcoded special forms that
|
|
;; return #<void> on the false branch. Void is truthy in lumbda,
|
|
;; which breaks CL idioms like (when (primep n) n) being used as a
|
|
;; boolean. `cl-when` / `cl-unless` return nil instead. Phase D
|
|
;; (load ursa.lisp.txt unchanged) runs the source through a reader
|
|
;; transform that rewrites plain `when`/`unless` to these forms.
|
|
;; Note: returns #f (not nil/'()) on the false branch. CL code usually
|
|
;; treats this result as a boolean — returning Scheme's #f keeps `cond`
|
|
;; and `if` working correctly, since in lumbda (like all Scheme) the
|
|
;; empty list is truthy. Any code that explicitly needs `nil` as the
|
|
;; result can write `(or (cl-when ...) nil)`.
|
|
(define-macro (cl-when test . body)
|
|
`(if ,test (begin ,@body) #f))
|
|
|
|
(define-macro (cl-unless test . body)
|
|
`(if ,test #f (begin ,@body)))
|
|
|
|
;; ── defun — supports plain args + &optional (var default) ────────
|
|
;; No &key / &rest / &aux / &body support — those are explicit
|
|
;; non-goals for this shim. See ticket 0004.
|
|
|
|
(define (cl-split-args arglist)
|
|
;; Returns (required-list . optional-list) splitting on &optional.
|
|
(let loop ((rem arglist) (req '()))
|
|
(cond ((null? rem) (cons (reverse req) '()))
|
|
((eq? (car rem) '&optional) (cons (reverse req) (cdr rem)))
|
|
(else (loop (cdr rem) (cons (car rem) req))))))
|
|
|
|
;; Build (name a b c . rest-sym) as a proper improper list — quasiquote
|
|
;; dotted pairs get parsed as literal `.` symbols, so construct with cons.
|
|
(define (cl-build-dotted head req rest-sym)
|
|
(if (null? req)
|
|
(cons head rest-sym)
|
|
(cons head (cl-build-dotted (car req) (cdr req) rest-sym))))
|
|
|
|
(define-macro (defun name arglist . body)
|
|
(let* ((split (cl-split-args arglist))
|
|
(req (car split))
|
|
(opt (cdr split)))
|
|
(if (null? opt)
|
|
`(define (,name ,@req) ,@body)
|
|
(let* ((rest-sym (gensym))
|
|
(param-list (cl-build-dotted name req rest-sym))
|
|
(bindings
|
|
(let build ((os opt) (idx 0) (acc '()))
|
|
(if (null? os)
|
|
(reverse acc)
|
|
(let* ((o (car os))
|
|
(v (if (pair? o) (car o) o))
|
|
(d (if (pair? o) (cadr o) ''())))
|
|
(build (cdr os)
|
|
(+ idx 1)
|
|
(cons `(,v (if (> (length ,rest-sym) ,idx)
|
|
(list-ref ,rest-sym ,idx)
|
|
,d))
|
|
acc)))))))
|
|
`(define ,param-list
|
|
(let* ,bindings ,@body))))))
|
|
|
|
;; ── setf — simple variable, supports multi-pair ──────────────────
|
|
;; (setf x 1 y 2 z 3) expands to three set! in a begin.
|
|
;; Generalized setf (on car, vector-ref, etc.) is out of scope.
|
|
(define-macro (setf . pairs)
|
|
(let loop ((p pairs) (acc '()))
|
|
(cond ((null? p)
|
|
(if (null? acc) '(begin) `(begin ,@(reverse acc))))
|
|
((null? (cdr p))
|
|
(error "setf: odd number of arguments"))
|
|
((pair? (car p))
|
|
(error "setf: only simple-variable setf is supported"))
|
|
(else
|
|
(loop (cddr p)
|
|
(cons `(set! ,(car p) ,(cadr p)) acc))))))
|
|
|
|
;; ── flet — local function bindings ───────────────────────────────
|
|
;; (flet ((f (x) body) ...) body) → (let ((f (lambda (x) body)) ...) body)
|
|
(define-macro (flet bindings . body)
|
|
`(let ,(map (lambda (b)
|
|
`(,(car b) (lambda ,(cadr b) ,@(cddr b))))
|
|
bindings)
|
|
,@body))
|
|
|
|
;; ── multiple-value-bind — built on lumbda's values/call-with-values
|
|
;; (multiple-value-bind (a b) expr body...) binds a, b to expr's values.
|
|
(define-macro (multiple-value-bind vars expr . body)
|
|
`(call-with-values (lambda () ,expr)
|
|
(lambda ,vars ,@body)))
|
|
|
|
;; lumbda ships cadddr but not cddddr — supply the missing accessor.
|
|
(define (cddddr x) (cdr (cdddr x)))
|
|
|
|
;; Two-list zip: (cl-zip '(a b c) '(1 2 3)) → ((a 1) (b 2) (c 3)).
|
|
;; asm's built-in `map` is single-list only; cl-loop-emit needs a
|
|
;; parallel walk over state-vars and their gensymed new-names, so
|
|
;; the emit uses cl-zip instead of `(map (lambda (v n) ...) xs ys)`.
|
|
(define (cl-zip as bs)
|
|
(cond ((or (null? as) (null? bs)) '())
|
|
(else (cons (list (car as) (car bs))
|
|
(cl-zip (cdr as) (cdr bs))))))
|
|
|
|
;; N-list append: (cl-append '(a) '(b) '(c)) → (a b c). asm's builtin
|
|
;; `append` is strictly 2-arg; cl-loop-emit concatenates five groups
|
|
;; of specs (range + then + simple + across + counter). Reducing with
|
|
;; the two-arg `append` works on every impl.
|
|
(define (cl-append . lsts)
|
|
(cond ((null? lsts) '())
|
|
((null? (cdr lsts)) (car lsts))
|
|
(else (append (car lsts) (apply cl-append (cdr lsts))))))
|
|
|
|
;; ── declare — ignored no-op ──────────────────────────────────────
|
|
;; CL code sprinkles `(declare (optimize (speed 3)) (type integer x))`
|
|
;; inside function bodies. These are compile-time directives in SBCL.
|
|
;; For lumbda they carry no information, so we make declare a no-op
|
|
;; macro that expands to (begin) — a safe value-producing form that
|
|
;; won't blow up the reader or eval.
|
|
(define-macro (declare . _) '(begin))
|
|
|
|
;; ── cl-loop — Common Lisp LOOP subset ────────────────────────────
|
|
;;
|
|
;; Covers the 14 patterns used in Zoë Trout's ursa.lisp.txt. Not full
|
|
;; CL LOOP — see ticket 0004 for scope. Every emitted form terminates
|
|
;; in a tail call to a named-let, so TCO stays intact.
|
|
;;
|
|
;; Supported clauses:
|
|
;; with VAR = INIT — let binding outside the loop
|
|
;; for VAR = INIT [then STEP] — iter var; re-eval INIT each iter
|
|
;; if no `then`, else INIT once + STEP thereafter
|
|
;; for VAR from A to|below|downto B — counted range iter
|
|
;; for VAR across VEC — vector traversal
|
|
;; for VAR of-type T = ... — type hint silently ignored
|
|
;; while TEST — continue while TEST truthy
|
|
;; until TEST — stop when TEST truthy
|
|
;; repeat N — iterate N times
|
|
;; do EXPR ... — body forms each iter
|
|
;; when TEST return VAL — mid-loop exit
|
|
;; unless TEST return VAL — mid-loop exit (inverted)
|
|
;; finally (return VAL) | FORM ... — run after loop; (return X) yields X
|
|
;;
|
|
;; Not supported (out of scope — see ticket 0004):
|
|
;; for VAR in LIST, for VAR on LIST — list iteration
|
|
;; for VAR being the hash-key ... — hash iteration
|
|
;; collect, sum, count, maximize — accumulator keywords
|
|
;; named NAME — named loop for return-from
|
|
;; initially — pre-loop hook
|
|
|
|
(define cl-loop-keywords
|
|
'(with for while until repeat do when unless finally initially
|
|
and
|
|
from to below downto across = then of-type in on being into
|
|
return collect sum count maximize minimize finally-return
|
|
named always never thereis))
|
|
|
|
(define (cl-loop-keyword? x)
|
|
(and (symbol? x) (memq x cl-loop-keywords)))
|
|
|
|
;; Parse: returns list
|
|
;; (withs iters body mid-exits finalizer repeat while-tests until-tests)
|
|
;; iters entries: (then var init step) | (simple var init) |
|
|
;; (range var start end how) with how ∈ (to below downto) |
|
|
;; (across var vec)
|
|
(define (cl-loop-parse clauses)
|
|
(let ((withs '()) (iters '()) (body '()) (mid-exits '())
|
|
(finalizer '()) (rpt #f)
|
|
(while-tests '()) (until-tests '()))
|
|
(let parse ((c clauses))
|
|
(cond
|
|
((null? c) #t)
|
|
|
|
;; with VAR = INIT
|
|
((eq? (car c) 'with)
|
|
(set! withs (append withs (list (cons (cadr c) (cadddr c)))))
|
|
(parse (cddddr c)))
|
|
|
|
;; for ...
|
|
((eq? (car c) 'for)
|
|
(let ((parsed (cl-loop-parse-for c)))
|
|
(set! iters (append iters (list (car parsed))))
|
|
(parse (cdr parsed))))
|
|
|
|
((eq? (car c) 'while)
|
|
(set! while-tests (append while-tests (list (cadr c))))
|
|
(parse (cddr c)))
|
|
|
|
((eq? (car c) 'until)
|
|
(set! until-tests (append until-tests (list (cadr c))))
|
|
(parse (cddr c)))
|
|
|
|
((eq? (car c) 'repeat)
|
|
(set! rpt (cadr c))
|
|
(parse (cddr c)))
|
|
|
|
;; do EXPR EXPR ... — consume up to next keyword
|
|
((eq? (car c) 'do)
|
|
(let consume ((r (cdr c)))
|
|
(cond
|
|
((null? r) #t)
|
|
((cl-loop-keyword? (car r)) (parse r))
|
|
(else
|
|
(set! body (append body (list (car r))))
|
|
(consume (cdr r))))))
|
|
|
|
;; when TEST return VAL / unless TEST return VAL
|
|
((or (eq? (car c) 'when) (eq? (car c) 'unless))
|
|
(let ((kind (car c)) (test (cadr c))
|
|
(act (caddr c)) (val (cadddr c)))
|
|
(if (not (eq? act 'return))
|
|
(error "cl-loop: when/unless: only 'return' action is supported")
|
|
(begin
|
|
(set! mid-exits
|
|
(append mid-exits (list (list kind test val))))
|
|
(parse (cddddr c))))))
|
|
|
|
;; finally FORM ... (consumes rest)
|
|
((eq? (car c) 'finally)
|
|
(set! finalizer (cdr c))
|
|
#t)
|
|
|
|
(else (error "cl-loop: unknown clause keyword" (car c)))))
|
|
(list withs iters body mid-exits finalizer rpt while-tests until-tests)))
|
|
|
|
(define (cl-loop-parse-for clauses)
|
|
;; clauses starts with 'for. Returns (iter-record . rest-clauses).
|
|
(let* ((var (cadr clauses))
|
|
(rest (cddr clauses))
|
|
(op (if (null? rest) #f (car rest))))
|
|
(cond
|
|
;; of-type T — skip the type, re-enter parser with remaining
|
|
((eq? op 'of-type)
|
|
(cl-loop-parse-for (cons 'for (cons var (cddr rest)))))
|
|
|
|
;; = INIT [then STEP]
|
|
((eq? op '=)
|
|
(let ((init (cadr rest))
|
|
(rem (cddr rest)))
|
|
(cond
|
|
((and (not (null? rem)) (eq? (car rem) 'then))
|
|
(cons (list 'then var init (cadr rem)) (cddr rem)))
|
|
(else
|
|
(cons (list 'simple var init) rem)))))
|
|
|
|
;; from A [to|below|downto] B
|
|
((eq? op 'from)
|
|
(let* ((start (cadr rest))
|
|
(rem (cddr rest))
|
|
(how (if (null? rem) #f (car rem))))
|
|
(cond
|
|
((eq? how 'to)
|
|
(cons (list 'range var start (cadr rem) 'to) (cddr rem)))
|
|
((eq? how 'below)
|
|
(cons (list 'range var start (cadr rem) 'below) (cddr rem)))
|
|
((eq? how 'downto)
|
|
(cons (list 'range var start (cadr rem) 'downto) (cddr rem)))
|
|
(else
|
|
(error "cl-loop: for ... from: expected to|below|downto")))))
|
|
|
|
;; across VEC
|
|
((eq? op 'across)
|
|
(cons (list 'across var (cadr rest)) (cddr rest)))
|
|
|
|
(else (error "cl-loop: for: unknown sub-clause" op)))))
|
|
|
|
(define (cl-loop-finalizer-expr finalizer)
|
|
(cond
|
|
((null? finalizer) ''())
|
|
((and (pair? (car finalizer))
|
|
(eq? (caar finalizer) 'return)
|
|
(null? (cdr finalizer)))
|
|
(cadar finalizer))
|
|
((= 1 (length finalizer))
|
|
(car finalizer))
|
|
(else `(begin ,@finalizer))))
|
|
|
|
;; Substitute symbols in an s-expression.
|
|
;; mappings is a list of (from-sym to-sym) pairs.
|
|
(define (cl-subst expr mappings)
|
|
(cond
|
|
((pair? expr)
|
|
(cons (cl-subst (car expr) mappings)
|
|
(cl-subst (cdr expr) mappings)))
|
|
((symbol? expr)
|
|
(let loop ((m mappings))
|
|
(cond ((null? m) expr)
|
|
((eq? (car (car m)) expr) (cadr (car m)))
|
|
(else (loop (cdr m))))))
|
|
(else expr)))
|
|
|
|
(define (cl-loop-emit parsed)
|
|
(let ((withs (list-ref parsed 0))
|
|
(iters (list-ref parsed 1))
|
|
(body (list-ref parsed 2))
|
|
(mid-exits (list-ref parsed 3))
|
|
(finalizer (list-ref parsed 4))
|
|
(rpt (list-ref parsed 5))
|
|
(while-tests (list-ref parsed 6))
|
|
(until-tests (list-ref parsed 7)))
|
|
(let* ((lp-name (gensym))
|
|
(counter-var (if rpt (gensym) #f))
|
|
;; categorize iters (preserve source order)
|
|
(then-iters (filter (lambda (i) (eq? (car i) 'then)) iters))
|
|
(simple-iters (filter (lambda (i) (eq? (car i) 'simple)) iters))
|
|
(range-iters (filter (lambda (i) (eq? (car i) 'range)) iters))
|
|
(across-iters (filter (lambda (i) (eq? (car i) 'across)) iters))
|
|
;; range specs: (var init step-expr term-expr)
|
|
(range-specs
|
|
(map (lambda (r)
|
|
(let ((var (cadr r)) (start (caddr r))
|
|
(end (cadddr r)) (how (car (cddddr r))))
|
|
(list var start
|
|
(if (eq? how 'downto)
|
|
`(- ,var 1)
|
|
`(+ ,var 1))
|
|
(case how
|
|
((to) (lambda (v) `(> ,v ,end)))
|
|
((below) (lambda (v) `(>= ,v ,end)))
|
|
((downto) (lambda (v) `(< ,v ,end)))))))
|
|
range-iters))
|
|
;; then specs: (var init step-expr)
|
|
(then-specs
|
|
(map (lambda (t) (list (cadr t) (caddr t) (cadddr t)))
|
|
then-iters))
|
|
;; simple specs: (var init init) — step re-evaluates init each iter
|
|
(simple-specs
|
|
(map (lambda (s) (list (cadr s) (caddr s) (caddr s)))
|
|
simple-iters))
|
|
;; across specs (by hidden idx): (idx-var 0 step-expr vec user-var)
|
|
(across-specs
|
|
(map (lambda (a)
|
|
(let ((idx (gensym)))
|
|
(list idx 0 `(+ ,idx 1) (caddr a) (cadr a))))
|
|
across-iters))
|
|
(counter-spec
|
|
(if rpt (list counter-var 0 `(+ ,counter-var 1)) #f))
|
|
|
|
;; All stateful specs in source-visible order.
|
|
;; Each entry: (var init step) — additional fields (term, vec, user-var) are
|
|
;; kept in parallel lists by position below.
|
|
;; For parity with downstream expectations, flatten to (var init step).
|
|
(all-specs-source
|
|
(cl-append
|
|
(map (lambda (r) (list (car r) (cadr r) (caddr r))) range-specs)
|
|
(map (lambda (t) t) then-specs)
|
|
(map (lambda (s) s) simple-specs)
|
|
(map (lambda (a) (list (car a) (cadr a) (caddr a))) across-specs)
|
|
(if counter-spec (list counter-spec) '())))
|
|
(state-vars (map car all-specs-source))
|
|
(state-inits (map cadr all-specs-source))
|
|
|
|
;; Fresh "new-name" for each state var — used in the let* that
|
|
;; sequentially computes step values without shadowing the outer
|
|
;; bindings (so the finalizer keeps access to current-iter values).
|
|
(new-names
|
|
(map (lambda (v) (gensym)) state-vars))
|
|
(var->new (cl-zip state-vars new-names))
|
|
|
|
;; Build sequential step bindings. Each binding's expr substitutes
|
|
;; references to EARLIER state vars with their new-names; later
|
|
;; state vars keep their current-iter value. This mirrors CL LOOP's
|
|
;; do*-style sequential stepping.
|
|
(step-bindings
|
|
(let build ((specs all-specs-source)
|
|
(names new-names)
|
|
(substs '())
|
|
(acc '()))
|
|
(cond
|
|
((null? specs) (reverse acc))
|
|
(else
|
|
(let* ((spec (car specs))
|
|
(var (car spec))
|
|
(step (caddr spec))
|
|
(new-name (car names))
|
|
(step-expr (cl-subst step substs)))
|
|
(build (cdr specs) (cdr names)
|
|
(append substs (list (list var new-name)))
|
|
(cons (list new-name step-expr) acc)))))))
|
|
|
|
;; Look-ahead termination tests — evaluated against the NEW
|
|
;; stepped values. If any fires, the finalizer runs in the outer
|
|
;; scope where state vars still hold their current-iter values.
|
|
(lookahead-tests
|
|
(cl-append
|
|
;; range: term based on new value
|
|
(map (lambda (r)
|
|
(let* ((var (car r))
|
|
(term-fn (cadddr r))
|
|
(new-name (cadr (assq var var->new))))
|
|
(term-fn new-name)))
|
|
range-specs)
|
|
;; across: new-idx >= vector-length
|
|
(map (lambda (a)
|
|
(let* ((idx (car a))
|
|
(vec (cadddr a))
|
|
(new-name (cadr (assq idx var->new))))
|
|
`(>= ,new-name (vector-length ,vec))))
|
|
across-specs)
|
|
;; counter: new >= rpt
|
|
(if counter-spec
|
|
(list `(>= ,(cadr (assq counter-var var->new)) ,rpt))
|
|
'())))
|
|
|
|
;; Pre-body termination tests — evaluated at iter start, use
|
|
;; current state. while fails when any while-test is false;
|
|
;; until fails when any until-test is true.
|
|
(pre-body-tests
|
|
(append
|
|
(map (lambda (t) `(not ,t)) while-tests)
|
|
until-tests))
|
|
|
|
;; Body user-var bindings for across (must be in scope for body
|
|
;; AND for mid-exit tests that might reference them). Each
|
|
;; across spec contributes (user-var (vector-ref vec idx)).
|
|
(across-body-bindings
|
|
(map (lambda (a)
|
|
(let ((user (car (cddddr a)))
|
|
(vec (cadddr a))
|
|
(idx (car a)))
|
|
(list user `(vector-ref ,vec ,idx))))
|
|
across-specs))
|
|
|
|
(final-form (cl-loop-finalizer-expr finalizer))
|
|
|
|
(exit-clauses
|
|
(map (lambda (e)
|
|
(case (car e)
|
|
((when) `(,(cadr e) ,(caddr e)))
|
|
((unless) `((not ,(cadr e)) ,(caddr e)))))
|
|
mid-exits))
|
|
|
|
;; After body: step to new values, check look-ahead termination,
|
|
;; otherwise recurse with new values. Mid-exits run between body
|
|
;; and step.
|
|
(step-and-recurse
|
|
(let* ((recurse `(,lp-name ,@new-names))
|
|
(after-step
|
|
(if (null? lookahead-tests)
|
|
recurse
|
|
`(cond ((or ,@lookahead-tests) ,final-form)
|
|
(else ,recurse))))
|
|
(stepped
|
|
(if (null? step-bindings)
|
|
after-step
|
|
`(let* ,step-bindings ,after-step))))
|
|
stepped))
|
|
|
|
(body-then-step
|
|
(cond
|
|
((null? exit-clauses)
|
|
(if (null? body)
|
|
step-and-recurse
|
|
`(begin ,@body ,step-and-recurse)))
|
|
(else
|
|
(let ((body-forms
|
|
(if (null? body)
|
|
`((cond ,@exit-clauses (else ,step-and-recurse)))
|
|
(append body
|
|
`((cond ,@exit-clauses (else ,step-and-recurse)))))))
|
|
`(begin ,@body-forms)))))
|
|
|
|
(inner-with-across
|
|
(if (null? across-body-bindings)
|
|
body-then-step
|
|
`(let* ,across-body-bindings ,body-then-step)))
|
|
|
|
(loop-body
|
|
(if (null? pre-body-tests)
|
|
inner-with-across
|
|
`(cond ((or ,@pre-body-tests) ,final-form)
|
|
(else ,inner-with-across))))
|
|
|
|
;; Build the named-let, with inits computed sequentially via
|
|
;; a let* so later inits can reference earlier ones — this is
|
|
;; how CL LOOP initializes iteration vars (do*-style).
|
|
(init-temps (map (lambda (_) (gensym)) state-vars))
|
|
(init-bindings
|
|
(let build ((vars state-vars) (inits state-inits)
|
|
(temps init-temps) (substs '()) (acc '()))
|
|
(cond
|
|
((null? vars) (reverse acc))
|
|
(else
|
|
(let* ((var (car vars))
|
|
(init (car inits))
|
|
(temp (car temps))
|
|
(init-sub (cl-subst init substs)))
|
|
(build (cdr vars) (cdr inits) (cdr temps)
|
|
(append substs (list (list var temp)))
|
|
(cons (list temp init-sub) acc)))))))
|
|
(named-let
|
|
`(let* ,init-bindings
|
|
(let ,lp-name ,(cl-zip state-vars init-temps)
|
|
,loop-body))))
|
|
(if (null? withs)
|
|
named-let
|
|
`(let* ,(map (lambda (w) (list (car w) (cdr w))) withs)
|
|
,named-let)))))
|
|
|
|
(define-macro (cl-loop . clauses)
|
|
(cl-loop-emit (cl-loop-parse clauses)))
|