;;; 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)))
