giles
f449f82fdd
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s
defmacro/macrolet/symbol-macrolet/macroexpand, gensym/gentemp, full LOOP macro (loop.sx) with all clause types. Phase 2 dynamic variables: cl-apply-dyn, cl-letstar-bind, cl-mark-special!/cl-special? for defvar/defparameter specials with let-based dynamic rebinding. 27 macro+LOOP tests; 182 eval tests (8 new dynamic var tests). Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
624 lines
23 KiB
Plaintext
624 lines
23 KiB
Plaintext
;; 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))))
|