coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cl: Phase 6 FORMAT + substr fixes — 514/514 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 39s
Details

Browse Source 
FORMAT with ~A/~S/~D/~F/~%/~&/~T/~P/~{...~}/~^; cl-fmt-loop,
cl-fmt-find-close, cl-fmt-iterate, cl-fmt-a/cl-fmt-s helpers.
Fix substr(start,length) semantics throughout: SUBSEQ end formula
corrected to (- end start), cl-fmt-loop char extraction fixed.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-05 12:23:54 +00:00
parent 025ddbebdd
commit 4f9da65b3d
5 changed files with 176 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

142
lib/common-lisp/eval.sx
View File

@@ -191,6 +191,140 @@
(cl-eval-body body e5)))))))))))))
;; ── FORMAT helpers ──────────────────────────────────────────────
(define cl-fmt-a
(fn (arg)
(cond
((= arg nil) "()")
((= arg true) "T")
((= arg false) "NIL")
((string? arg) arg)
((number? arg) (str arg))
((list? arg)
(if (= (len arg) 0) "()"
(str "("
(reduce (fn (a x) (str a " " (cl-fmt-a x)))
(cl-fmt-a (nth arg 0))
(rest arg))
")")))
((and (dict? arg) (= (get arg "cl-type") "keyword"))
(str ":" (get arg "name")))
((and (dict? arg) (= (get arg "cl-type") "char"))
(get arg "value"))
(:else (str arg)))))
(define cl-fmt-s
(fn (arg)
(cond
((= arg nil) "NIL")
((= arg true) "T")
((= arg false) "NIL")
((string? arg) (str "\"" arg "\""))
((number? arg) (str arg))
((list? arg)
(if (= (len arg) 0) "NIL"
(str "("
(reduce (fn (a x) (str a " " (cl-fmt-s x)))
(cl-fmt-s (nth arg 0))
(rest arg))
")")))
((and (dict? arg) (= (get arg "cl-type") "keyword"))
(str ":" (get arg "name")))
((and (dict? arg) (= (get arg "cl-type") "char"))
(str "#\\" (get arg "value")))
(:else (str arg)))))
;; Find position of ~CH (tilde+ch) in ctrl, starting from i, tracking nesting
(define cl-fmt-find-close
(fn (ctrl ch i depth)
(if (>= i (- (len ctrl) 1)) -1
(let ((c (substr ctrl i 1)))
(if (= c "~")
(let ((nxt (upcase (substr ctrl (+ i 1) 1))))
(cond
((= nxt ch)
(if (= depth 0) i (cl-fmt-find-close ctrl ch (+ i 2) (- depth 1))))
((or (= nxt "{") (= nxt "["))
(cl-fmt-find-close ctrl ch (+ i 2) (+ depth 1)))
(:else
(cl-fmt-find-close ctrl ch (+ i 2) depth))))
(cl-fmt-find-close ctrl ch (+ i 1) depth))))))
;; Process inner ~{...~} string over each element of a list
(define cl-fmt-iterate
(fn (inner items)
(if (= items nil) ""
(if (= (len items) 0) ""
(reduce
(fn (acc x)
(str acc (get (cl-fmt-loop inner (list x) 0 "") "out")))
"" items)))))
;; Main format loop: returns {:out string :args remaining}
(define cl-fmt-loop
(fn (ctrl args i out)
(if (>= i (len ctrl))
{:out out :args args}
(let ((ch (substr ctrl i 1)))
(if (not (= ch "~"))
(cl-fmt-loop ctrl args (+ i 1) (str out ch))
(let ((dir (if (< (+ i 1) (len ctrl))
(upcase (substr ctrl (+ i 1) 1))
"")))
(cond
((= dir "A")
(cl-fmt-loop ctrl (rest args) (+ i 2)
(str out (if (> (len args) 0) (cl-fmt-a (nth args 0)) ""))))
((= dir "S")
(cl-fmt-loop ctrl (rest args) (+ i 2)
(str out (if (> (len args) 0) (cl-fmt-s (nth args 0)) ""))))
((or (= dir "D") (= dir "F") (= dir "B") (= dir "X") (= dir "O"))
(cl-fmt-loop ctrl (rest args) (+ i 2)
(str out (if (> (len args) 0) (str (nth args 0)) ""))))
((= dir "%")
(cl-fmt-loop ctrl args (+ i 2) (str out "\n")))
((= dir "&")
(cl-fmt-loop ctrl args (+ i 2)
(if (or (= (len out) 0)
(= (substr out (- (len out) 1) 1) "\n"))
out (str out "\n"))))
((= dir "T")
(cl-fmt-loop ctrl args (+ i 2) (str out "\t")))
((= dir "P")
(let ((arg (if (> (len args) 0) (nth args 0) 1)))
(cl-fmt-loop ctrl (rest args) (+ i 2)
(str out (if (= arg 1) "" "s")))))
((= dir "{")
(let ((end-i (cl-fmt-find-close ctrl "}" (+ i 2) 0)))
(if (= end-i -1)
{:out (str out "~{") :args args}
(let ((inner (if (> end-i (+ i 2))
(substr ctrl (+ i 2) (- end-i (+ i 2)))
"")))
(let ((list-arg (if (> (len args) 0) (nth args 0) (list))))
(cl-fmt-loop ctrl (rest args) (+ end-i 2)
(str out (cl-fmt-iterate inner (if (= list-arg nil) (list) list-arg)))))))))
((= dir "[")
(let ((end-i (cl-fmt-find-close ctrl "]" (+ i 2) 0)))
(if (= end-i -1)
{:out (str out "~[") :args args}
(let ((inner (if (> end-i (+ i 2))
(substr ctrl (+ i 2) (- end-i (+ i 2)))
"")))
(let ((arg (if (> (len args) 0) (nth args 0) 0)))
(let ((chosen (if (= arg true) "T"
(if (= arg nil) "NIL"
(get (cl-fmt-loop inner (list arg) 0 "") "out")))))
(cl-fmt-loop ctrl (rest args) (+ end-i 2)
(str out chosen))))))))
((= dir "~")
(cl-fmt-loop ctrl args (+ i 2) (str out "~")))
((= dir "^")
{:out out :args args})
(:else
(cl-fmt-loop ctrl args (+ i 2) (str out "~" dir))))))))))
;; ── sequence/list helpers (needed by builtins) ───────────────────
(define cl-member-helper
@@ -520,7 +654,7 @@
(start (nth args 1))
(end (if (> (len args) 2) (nth args 2) nil)))
(if (string? seq)
(if end (substr seq start (- end 1)) (substr seq start (- (len seq) 1)))
(if end (substr seq start (- end start)) (substr seq start (- (len seq) start)))
(if (= seq nil) (list)
(if end (slice seq start end) (slice seq start (len seq)))))))
"STRING" (fn (args)
@@ -552,6 +686,12 @@
(reduce (fn (a c) (str a (if (dict? c) (get c "value") c))) "" x)
(str x)))
(:else x))))
"FORMAT" (fn (args)
(let ((dest (nth args 0))
(ctrl (if (> (len args) 1) (nth args 1) ""))
(fargs (if (> (len args) 2) (slice args 2 (len args)) (list))))
(let ((result (get (cl-fmt-loop ctrl fargs 0 "") "out")))
(if (= dest nil) result nil))))
"MAKE-LIST" (fn (args)
(let ((n (nth args 0)))
(map (fn (_) nil) (range 0 n))))))