;; lib/common-lisp/loop.sx — The LOOP macro for CL-on-SX
;;
;; Supported clauses:
;;   for VAR in LIST             — iterate over list
;;   for VAR across VECTOR       — alias for 'in'
;;   for VAR from N              — numeric iteration (to/upto/below/downto/above/by)
;;   for VAR = EXPR [then EXPR]  — general iteration
;;   while COND                  — stop when false
;;   until COND                  — stop when true
;;   repeat N                    — repeat N times
;;   collect EXPR [into VAR]
;;   append EXPR [into VAR]
;;   nconc EXPR [into VAR]
;;   sum EXPR [into VAR]
;;   count EXPR [into VAR]
;;   maximize EXPR [into VAR]
;;   minimize EXPR [into VAR]
;;   do FORM...
;;   when/if COND clause...
;;   unless COND clause...
;;   finally FORM...
;;   always COND
;;   never COND
;;   thereis COND
;;   named BLOCK-NAME
;;
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/eval.sx already loaded.
;; Uses defmacro in the CL evaluator.

;; ── LOOP expansion driver ─────────────────────────────────────────────────

;; cl-loop-parse: analyse the flat LOOP clause list and build a Lisp form.
;; Returns a (block NAME (let (...) (tagbody ...))) form.
(define
  cl-loop-parse
  (fn
    (clauses)
    (define block-name nil)
    (define with-bindings (list))
    (define for-bindings (list))
    (define test-forms (list))
    (define repeat-var nil)
    (define repeat-count nil)
    (define body-forms (list))
    (define accum-vars (dict))
    (define accum-clauses (dict))
    (define result-var nil)
    (define finally-forms (list))
    (define return-expr nil)
    (define termination nil)
    (define idx 0)
    (define (lp-peek) (if (< idx (len clauses)) (nth clauses idx) nil))
    (define
      (next!)
      (let ((v (lp-peek))) (do (set! idx (+ idx 1)) v)))
    (define
      (skip-if pred)
      (if (and (not (nil? (lp-peek))) (pred (lp-peek))) (next!) nil))
    (define (upcase-str s) (if (string? s) (upcase s) s))
    (define (kw? s k) (= (upcase-str s) k))
    (define
      (make-accum-var!)
      (if
        (nil? result-var)
        (do (set! result-var "#LOOP-RESULT") result-var)
        result-var))
    (define
      (add-accum! type expr into-var)
      (let
        ((v (if (nil? into-var) (make-accum-var!) into-var)))
        (if
          (not (has-key? accum-vars v))
          (do
            (set!
              accum-vars
              (assoc
                accum-vars
                v
                (cond
                  ((= type ":sum") 0)
                  ((= type ":count") 0)
                  ((= type ":maximize") nil)
                  ((= type ":minimize") nil)
                  (:else (list)))))
            (set! accum-clauses (assoc accum-clauses v type))))
        (let
          ((update (cond ((= type ":collect") (list "SETQ" v (list "APPEND" v (list "LIST" expr)))) ((= type ":append") (list "SETQ" v (list "APPEND" v expr))) ((= type ":nconc") (list "SETQ" v (list "NCONC" v expr))) ((= type ":sum") (list "SETQ" v (list "+" v expr))) ((= type ":count") (list "SETQ" v (list "+" v (list "IF" expr 1 0)))) ((= type ":maximize") (list "SETQ" v (list "IF" (list "OR" (list "NULL" v) (list ">" expr v)) expr v))) ((= type ":minimize") (list "SETQ" v (list "IF" (list "OR" (list "NULL" v) (list "<" expr v)) expr v))) (:else (list "SETQ" v (list "APPEND" v (list "LIST" expr)))))))
          (set! body-forms (append body-forms (list update))))))
    (define
      (parse-clause!)
      (let
        ((tok (lp-peek)))
        (if
          (nil? tok)
          nil
          (do
            (let
              ((u (upcase-str tok)))
              (cond
                ((= u "NAMED")
                  (do (next!) (set! block-name (next!)) (parse-clause!)))
                ((= u "WITH")
                  (do
                    (next!)
                    (let
                      ((var (next!)))
                      (skip-if (fn (s) (kw? s "=")))
                      (let
                        ((init (next!)))
                        (set!
                          with-bindings
                          (append with-bindings (list (list var init))))
                        (parse-clause!)))))
                ((= u "FOR")
                  (do
                    (next!)
                    (let
                      ((var (next!)))
                      (let
                        ((kw2 (upcase-str (lp-peek))))
                        (cond
                          ((or (= kw2 "IN") (= kw2 "ACROSS"))
                            (do
                              (next!)
                              (let
                                ((lst-expr (next!))
                                  (tail-var (str "#TAIL-" var)))
                                (set!
                                  for-bindings
                                  (append for-bindings (list {:list lst-expr :tail tail-var :type ":list" :var var})))
                                (parse-clause!))))
                          ((= kw2 "=")
                            (do
                              (next!)
                              (let
                                ((init-expr (next!)))
                                (let
                                  ((then-expr (if (kw? (lp-peek) "THEN") (do (next!) (next!)) init-expr)))
                                  (set!
                                    for-bindings
                                    (append for-bindings (list {:type ":general" :then then-expr :init init-expr :var var})))
                                  (parse-clause!)))))
                          ((or (= kw2 "FROM") (= kw2 "DOWNFROM") (= kw2 "UPFROM"))
                            (do
                              (next!)
                              (let
                                ((from-expr (next!))
                                  (dir (if (= kw2 "DOWNFROM") ":down" ":up"))
                                  (limit-expr nil)
                                  (limit-type nil)
                                  (step-expr 1))
                                (let
                                  ((lkw (upcase-str (lp-peek))))
                                  (when
                                    (or
                                      (= lkw "TO")
                                      (= lkw "UPTO")
                                      (= lkw "BELOW")
                                      (= lkw "DOWNTO")
                                      (= lkw "ABOVE"))
                                    (do
                                      (next!)
                                      (set! limit-type lkw)
                                      (set! limit-expr (next!)))))
                                (when
                                  (kw? (lp-peek) "BY")
                                  (do (next!) (set! step-expr (next!))))
                                (set!
                                  for-bindings
                                  (append for-bindings (list {:dir dir :step step-expr :from from-expr :type ":numeric" :limit-type limit-type :var var :limit limit-expr})))
                                (parse-clause!))))
                          ((or (= kw2 "TO") (= kw2 "UPTO") (= kw2 "BELOW"))
                            (do
                              (next!)
                              (let
                                ((limit-expr (next!))
                                  (step-expr 1))
                                (when
                                  (kw? (lp-peek) "BY")
                                  (do (next!) (set! step-expr (next!))))
                                (set!
                                  for-bindings
                                  (append for-bindings (list {:dir ":up" :step step-expr :from 0 :type ":numeric" :limit-type kw2 :var var :limit limit-expr})))
                                (parse-clause!))))
                          (:else (do (parse-clause!))))))))
                ((= u "WHILE")
                  (do
                    (next!)
                    (set! test-forms (append test-forms (list {:expr (next!) :type ":while"})))
                    (parse-clause!)))
                ((= u "UNTIL")
                  (do
                    (next!)
                    (set! test-forms (append test-forms (list {:expr (next!) :type ":until"})))
                    (parse-clause!)))
                ((= u "REPEAT")
                  (do
                    (next!)
                    (set! repeat-count (next!))
                    (set! repeat-var "#REPEAT-COUNT")
                    (parse-clause!)))
                ((or (= u "COLLECT") (= u "COLLECTING"))
                  (do
                    (next!)
                    (let
                      ((expr (next!)) (into-var nil))
                      (when
                        (kw? (lp-peek) "INTO")
                        (do (next!) (set! into-var (next!))))
                      (add-accum! ":collect" expr into-var)
                      (parse-clause!))))
                ((or (= u "APPEND") (= u "APPENDING"))
                  (do
                    (next!)
                    (let
                      ((expr (next!)) (into-var nil))
                      (when
                        (kw? (lp-peek) "INTO")
                        (do (next!) (set! into-var (next!))))
                      (add-accum! ":append" expr into-var)
                      (parse-clause!))))
                ((or (= u "NCONC") (= u "NCONCING"))
                  (do
                    (next!)
                    (let
                      ((expr (next!)) (into-var nil))
                      (when
                        (kw? (lp-peek) "INTO")
                        (do (next!) (set! into-var (next!))))
                      (add-accum! ":nconc" expr into-var)
                      (parse-clause!))))
                ((or (= u "SUM") (= u "SUMMING"))
                  (do
                    (next!)
                    (let
                      ((expr (next!)) (into-var nil))
                      (when
                        (kw? (lp-peek) "INTO")
                        (do (next!) (set! into-var (next!))))
                      (add-accum! ":sum" expr into-var)
                      (parse-clause!))))
                ((or (= u "COUNT") (= u "COUNTING"))
                  (do
                    (next!)
                    (let
                      ((expr (next!)) (into-var nil))
                      (when
                        (kw? (lp-peek) "INTO")
                        (do (next!) (set! into-var (next!))))
                      (add-accum! ":count" expr into-var)
                      (parse-clause!))))
                ((or (= u "MAXIMIZE") (= u "MAXIMIZING"))
                  (do
                    (next!)
                    (let
                      ((expr (next!)) (into-var nil))
                      (when
                        (kw? (lp-peek) "INTO")
                        (do (next!) (set! into-var (next!))))
                      (add-accum! ":maximize" expr into-var)
                      (parse-clause!))))
                ((or (= u "MINIMIZE") (= u "MINIMIZING"))
                  (do
                    (next!)
                    (let
                      ((expr (next!)) (into-var nil))
                      (when
                        (kw? (lp-peek) "INTO")
                        (do (next!) (set! into-var (next!))))
                      (add-accum! ":minimize" expr into-var)
                      (parse-clause!))))
                ((= u "DO")
                  (do
                    (next!)
                    (define
                      (loop-kw? s)
                      (let
                        ((us (upcase-str s)))
                        (some
                          (fn (k) (= us k))
                          (list
                            "FOR"
                            "WITH"
                            "WHILE"
                            "UNTIL"
                            "REPEAT"
                            "COLLECT"
                            "COLLECTING"
                            "APPEND"
                            "APPENDING"
                            "NCONC"
                            "NCONCING"
                            "SUM"
                            "SUMMING"
                            "COUNT"
                            "COUNTING"
                            "MAXIMIZE"
                            "MAXIMIZING"
                            "MINIMIZE"
                            "MINIMIZING"
                            "DO"
                            "WHEN"
                            "IF"
                            "UNLESS"
                            "FINALLY"
                            "ALWAYS"
                            "NEVER"
                            "THEREIS"
                            "RETURN"
                            "NAMED"))))
                    (define
                      (collect-do-forms!)
                      (if
                        (or (nil? (lp-peek)) (loop-kw? (lp-peek)))
                        nil
                        (do
                          (set!
                            body-forms
                            (append body-forms (list (next!))))
                          (collect-do-forms!))))
                    (collect-do-forms!)
                    (parse-clause!)))
                ((or (= u "WHEN") (= u "IF"))
                  (do
                    (next!)
                    (let
                      ((cond-expr (next!))
                       (body-start (len body-forms)))
                      (parse-clause!)
                      ;; wrap forms added since body-start in (WHEN cond ...)
                      (when (> (len body-forms) body-start)
                        (let ((added (list (nth body-forms body-start))))
                          (set! body-forms
                            (append
                              (if (> body-start 0)
                                (list (nth body-forms (- body-start 1)))
                                (list))
                              (list (list "WHEN" cond-expr (first added)))))
                          nil)))))
                ((= u "UNLESS")
                  (do
                    (next!)
                    (let
                      ((cond-expr (next!))
                       (body-start (len body-forms)))
                      (parse-clause!)
                      (when (> (len body-forms) body-start)
                        (let ((added (list (nth body-forms body-start))))
                          (set! body-forms
                            (append
                              (if (> body-start 0)
                                (list (nth body-forms (- body-start 1)))
                                (list))
                              (list (list "UNLESS" cond-expr (first added)))))
                          nil)))))
                ((= u "ALWAYS")
                  (do (next!) (set! termination {:expr (next!) :type ":always"}) (parse-clause!)))
                ((= u "NEVER")
                  (do (next!) (set! termination {:expr (next!) :type ":never"}) (parse-clause!)))
                ((= u "THEREIS")
                  (do (next!) (set! termination {:expr (next!) :type ":thereis"}) (parse-clause!)))
                ((= u "RETURN")
                  (do (next!) (set! return-expr (next!)) (parse-clause!)))
                ((= u "FINALLY")
                  (do
                    (next!)
                    (define
                      (collect-finally!)
                      (if
                        (nil? (lp-peek))
                        nil
                        (do
                          (set!
                            finally-forms
                            (append finally-forms (list (next!))))
                          (collect-finally!))))
                    (collect-finally!)
                    (parse-clause!)))
                (:else
                  (do
                    (set! body-forms (append body-forms (list (next!))))
                    (parse-clause!)))))))))
    (parse-clause!)
    (define let-bindings (list))
    (for-each
      (fn (wb) (set! let-bindings (append let-bindings (list wb))))
      with-bindings)
    (for-each
      (fn
        (v)
        (set!
          let-bindings
          (append let-bindings (list (list v (get accum-vars v))))))
      (keys accum-vars))
    (when
      (not (nil? repeat-var))
      (set!
        let-bindings
        (append let-bindings (list (list repeat-var repeat-count)))))
    (for-each
      (fn
        (fb)
        (let
          ((type (get fb "type")))
          (cond
            ((= type ":list")
              (do
                (set!
                  let-bindings
                  (append
                    let-bindings
                    (list (list (get fb "tail") (get fb "list")))
                    (list
                      (list
                        (get fb "var")
                        (list
                          "IF"
                          (list "CONSP" (get fb "tail"))
                          (list "CAR" (get fb "tail"))
                          nil)))))
                nil))
            ((= type ":numeric")
              (set!
                let-bindings
                (append
                  let-bindings
                  (list (list (get fb "var") (get fb "from"))))))
            ((= type ":general")
              (set!
                let-bindings
                (append
                  let-bindings
                  (list (list (get fb "var") (get fb "init"))))))
            (:else nil))))
      for-bindings)
    (define all-tests (list))
    (when
      (not (nil? repeat-var))
      (set!
        all-tests
        (append
          all-tests
          (list
            (list
              "WHEN"
              (list "<=" repeat-var 0)
              (list "RETURN-FROM" block-name (if (nil? result-var) nil result-var))))))
      (set!
        body-forms
        (append
          (list (list "SETQ" repeat-var (list "-" repeat-var 1)))
          body-forms)))
    (for-each
      (fn
        (fb)
        (when
          (= (get fb "type") ":list")
          (let
            ((tvar (get fb "tail")) (var (get fb "var")))
            (set!
              all-tests
              (append
                all-tests
                (list
                  (list
                    "WHEN"
                    (list "NULL" tvar)
                    (list
                      "RETURN-FROM"
                      block-name
                      (if (nil? result-var) nil result-var))))))
            (set!
              body-forms
              (append
                body-forms
                (list
                  (list "SETQ" tvar (list "CDR" tvar))
                  (list
                    "SETQ"
                    var
                    (list "IF" (list "CONSP" tvar) (list "CAR" tvar) nil))))))))
      for-bindings)
    (for-each
      (fn
        (fb)
        (when
          (= (get fb "type") ":numeric")
          (let
            ((var (get fb "var"))
              (dir (get fb "dir"))
              (lim (get fb "limit"))
              (ltype (get fb "limit-type"))
              (step (get fb "step")))
            (when
              (not (nil? lim))
              (let
                ((test-op (cond ((or (= ltype "BELOW") (= ltype "ABOVE")) (if (= dir ":up") ">=" "<=")) ((or (= ltype "TO") (= ltype "UPTO")) ">") ((= ltype "DOWNTO") "<") (:else (if (= dir ":up") ">" "<")))))
                (set!
                  all-tests
                  (append
                    all-tests
                    (list
                      (list
                        "WHEN"
                        (list test-op var lim)
                        (list
                          "RETURN-FROM"
                          block-name
                          (if (nil? result-var) nil result-var))))))))
            (let
              ((step-op (if (or (= dir ":down") (= ltype "DOWNTO") (= ltype "ABOVE")) "-" "+")))
              (set!
                body-forms
                (append
                  body-forms
                  (list (list "SETQ" var (list step-op var step)))))))))
      for-bindings)
    (for-each
      (fn
        (fb)
        (when
          (= (get fb "type") ":general")
          (set!
            body-forms
            (append
              body-forms
              (list (list "SETQ" (get fb "var") (get fb "then")))))))
      for-bindings)
    (for-each
      (fn
        (t)
        (let
          ((type (get t "type")) (expr (get t "expr")))
          (if
            (= type ":while")
            (set!
              all-tests
              (append
                all-tests
                (list
                  (list
                    "WHEN"
                    (list "NOT" expr)
                    (list
                      "RETURN-FROM"
                      block-name
                      (if (nil? result-var) nil result-var))))))
            (set!
              all-tests
              (append
                all-tests
                (list
                  (list
                    "WHEN"
                    expr
                    (list
                      "RETURN-FROM"
                      block-name
                      (if (nil? result-var) nil result-var)))))))))
      test-forms)
    (when
      (not (nil? termination))
      (let
        ((type (get termination "type")) (expr (get termination "expr")))
        (cond
          ((= type ":always")
            (set!
              body-forms
              (append
                body-forms
                (list
                  (list "UNLESS" expr (list "RETURN-FROM" block-name false)))))
            (set! return-expr true))
          ((= type ":never")
            (set!
              body-forms
              (append
                body-forms
                (list
                  (list "WHEN" expr (list "RETURN-FROM" block-name false)))))
            (set! return-expr true))
          ((= type ":thereis")
            (set!
              body-forms
              (append
                body-forms
                (list
                  (list "WHEN" expr (list "RETURN-FROM" block-name expr)))))))))
    (define tag "#LOOP-START")
    (define
      inner-body
      (append (list tag) all-tests body-forms (list (list "GO" tag))))
    (define
      result-form
      (cond
        ((not (nil? return-expr)) return-expr)
        ((not (nil? result-var)) result-var)
        (:else nil)))
    (define
      full-body
      (if
        (= (len let-bindings) 0)
        (append
          (list "PROGN")
          (list (append (list "TAGBODY") inner-body))
          finally-forms
          (list result-form))
        (list
          "LET*"
          let-bindings
          (append (list "TAGBODY") inner-body)
          (append (list "PROGN") finally-forms (list result-form)))))
    (list "BLOCK" block-name full-body)))

;; ── Install LOOP as a CL macro ────────────────────────────────────────────
;;
;; (loop ...) — the form arrives with head "LOOP" and rest = clauses.
;; The macro fn receives the full form.

(dict-set!
  cl-macro-registry
  "LOOP"
  (fn (form env) (cl-loop-parse (rest form))))