Compare commits
12 Commits
32a82a2e12
...
loops/comm
| Author | SHA1 | Date | |
|---|---|---|---|
| 6d53d36495 | |||
| c311d4ebc4 | |||
| 99f8ccb30e | |||
| 4f9da65b3d | |||
| 025ddbebdd | |||
| f449f82fdd | |||
| 0e426cfea8 | |||
| 71c4b5e33f | |||
| 4cd8773766 | |||
| 733b1ebefa | |||
| 85911d7b84 | |||
| ab66b29a74 |
500
lib/common-lisp/clos.sx
Normal file
500
lib/common-lisp/clos.sx
Normal file
@@ -0,0 +1,500 @@
|
||||
;; lib/common-lisp/clos.sx — CLOS: classes, instances, generic functions
|
||||
;;
|
||||
;; Class records: {:clos-type "class" :name "NAME" :slots {...} :parents [...] :methods [...]}
|
||||
;; Instance: {:clos-type "instance" :class "NAME" :slots {slot: val ...}}
|
||||
;; Method: {:qualifiers [...] :specializers [...] :fn (fn (args next-fn) ...)}
|
||||
;;
|
||||
;; SX primitive notes:
|
||||
;; dict->list: use (map (fn (k) (list k (get d k))) (keys d))
|
||||
;; dict-set (pure): use assoc
|
||||
;; fn?/callable?: use callable?
|
||||
|
||||
;; ── dict helpers ───────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-dict->list
|
||||
(fn (d) (map (fn (k) (list k (get d k))) (keys d))))
|
||||
|
||||
;; ── class registry ─────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-class-registry
|
||||
(dict
|
||||
"t"
|
||||
{:parents (list) :clos-type "class" :slots (dict) :methods (list) :name "t"}
|
||||
"null"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "null"}
|
||||
"integer"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "integer"}
|
||||
"float"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "float"}
|
||||
"string"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "string"}
|
||||
"symbol"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "symbol"}
|
||||
"cons"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "cons"}
|
||||
"list"
|
||||
{:parents (list "t") :clos-type "class" :slots (dict) :methods (list) :name "list"}))
|
||||
|
||||
;; ── clos-generic-registry ─────────────────────────────────────────────────
|
||||
|
||||
(define clos-generic-registry (dict))
|
||||
|
||||
;; ── class-of ──────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-class-of
|
||||
(fn
|
||||
(x)
|
||||
(cond
|
||||
((nil? x) "null")
|
||||
((integer? x) "integer")
|
||||
((float? x) "float")
|
||||
((string? x) "string")
|
||||
((symbol? x) "symbol")
|
||||
((and (list? x) (> (len x) 0)) "cons")
|
||||
((and (list? x) (= (len x) 0)) "null")
|
||||
((and (dict? x) (= (get x "clos-type") "instance")) (get x "class"))
|
||||
(:else "t"))))
|
||||
|
||||
;; ── subclass-of? ──────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Captures clos-class-registry at define time to avoid free-variable issues.
|
||||
|
||||
(define
|
||||
clos-subclass-of?
|
||||
(let
|
||||
((registry clos-class-registry))
|
||||
(fn
|
||||
(class-name super-name)
|
||||
(if
|
||||
(= class-name super-name)
|
||||
true
|
||||
(let
|
||||
((rec (get registry class-name)))
|
||||
(if
|
||||
(nil? rec)
|
||||
false
|
||||
(some
|
||||
(fn (p) (clos-subclass-of? p super-name))
|
||||
(get rec "parents"))))))))
|
||||
|
||||
;; ── instance-of? ──────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-instance-of?
|
||||
(fn (obj class-name) (clos-subclass-of? (clos-class-of obj) class-name)))
|
||||
|
||||
;; ── defclass ──────────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; slot-specs: list of dicts with keys: name initarg initform accessor reader writer
|
||||
;; Each missing key defaults to nil.
|
||||
|
||||
(define clos-slot-spec (fn (spec) (if (string? spec) {:initform nil :initarg nil :reader nil :writer nil :accessor nil :name spec} spec)))
|
||||
|
||||
(define
|
||||
clos-defclass
|
||||
(fn
|
||||
(name parents slot-specs)
|
||||
(let
|
||||
((slots (dict)))
|
||||
(for-each
|
||||
(fn
|
||||
(pname)
|
||||
(let
|
||||
((prec (get clos-class-registry pname)))
|
||||
(when
|
||||
(not (nil? prec))
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(when
|
||||
(nil? (get slots k))
|
||||
(dict-set! slots k (get (get prec "slots") k))))
|
||||
(keys (get prec "slots"))))))
|
||||
parents)
|
||||
(for-each
|
||||
(fn
|
||||
(s)
|
||||
(let
|
||||
((spec (clos-slot-spec s)))
|
||||
(dict-set! slots (get spec "name") spec)))
|
||||
slot-specs)
|
||||
(let
|
||||
((class-rec {:parents parents :clos-type "class" :slots slots :methods (list) :name name}))
|
||||
(dict-set! clos-class-registry name class-rec)
|
||||
(clos-install-accessors-for name slots)
|
||||
name))))
|
||||
|
||||
;; ── accessor installation (forward-declared, defined after defmethod) ──────
|
||||
|
||||
(define
|
||||
clos-install-accessors-for
|
||||
(fn
|
||||
(class-name slots)
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(let
|
||||
((spec (get slots k)))
|
||||
(let
|
||||
((reader (get spec "reader")))
|
||||
(when
|
||||
(not (nil? reader))
|
||||
(clos-add-reader-method reader class-name k)))
|
||||
(let
|
||||
((accessor (get spec "accessor")))
|
||||
(when
|
||||
(not (nil? accessor))
|
||||
(clos-add-reader-method accessor class-name k)))))
|
||||
(keys slots))))
|
||||
|
||||
;; placeholder — real impl filled in after defmethod is defined
|
||||
(define clos-add-reader-method (fn (method-name class-name slot-name) nil))
|
||||
|
||||
;; ── make-instance ─────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-make-instance
|
||||
(fn
|
||||
(class-name &rest initargs)
|
||||
(let
|
||||
((class-rec (get clos-class-registry class-name)))
|
||||
(if
|
||||
(nil? class-rec)
|
||||
(error (str "No class named: " class-name))
|
||||
(let
|
||||
((slots (dict)))
|
||||
(for-each
|
||||
(fn
|
||||
(k)
|
||||
(let
|
||||
((spec (get (get class-rec "slots") k)))
|
||||
(let
|
||||
((initform (get spec "initform")))
|
||||
(when
|
||||
(not (nil? initform))
|
||||
(dict-set!
|
||||
slots
|
||||
k
|
||||
(if (callable? initform) (initform) initform))))))
|
||||
(keys (get class-rec "slots")))
|
||||
(define
|
||||
apply-args
|
||||
(fn
|
||||
(args)
|
||||
(when
|
||||
(>= (len args) 2)
|
||||
(let
|
||||
((key (str (first args))) (val (first (rest args))))
|
||||
(let
|
||||
((skey (if (= (slice key 0 1) ":") (slice key 1 (len key)) key)))
|
||||
(let
|
||||
((matched false))
|
||||
(for-each
|
||||
(fn
|
||||
(sk)
|
||||
(let
|
||||
((spec (get (get class-rec "slots") sk)))
|
||||
(let
|
||||
((ia (get spec "initarg")))
|
||||
(when
|
||||
(or
|
||||
(= ia key)
|
||||
(= ia (str ":" skey))
|
||||
(= sk skey))
|
||||
(dict-set! slots sk val)
|
||||
(set! matched true)))))
|
||||
(keys (get class-rec "slots")))))
|
||||
(apply-args (rest (rest args)))))))
|
||||
(apply-args initargs)
|
||||
{:clos-type "instance" :slots slots :class class-name})))))
|
||||
|
||||
;; ── slot-value ────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-slot-value
|
||||
(fn
|
||||
(instance slot-name)
|
||||
(if
|
||||
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
||||
(get (get instance "slots") slot-name)
|
||||
(error (str "Not a CLOS instance: " (inspect instance))))))
|
||||
|
||||
(define
|
||||
clos-set-slot-value!
|
||||
(fn
|
||||
(instance slot-name value)
|
||||
(if
|
||||
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
||||
(dict-set! (get instance "slots") slot-name value)
|
||||
(error (str "Not a CLOS instance: " (inspect instance))))))
|
||||
|
||||
(define
|
||||
clos-slot-boundp
|
||||
(fn
|
||||
(instance slot-name)
|
||||
(and
|
||||
(dict? instance)
|
||||
(= (get instance "clos-type") "instance")
|
||||
(not (nil? (get (get instance "slots") slot-name))))))
|
||||
|
||||
;; ── find-class / change-class ─────────────────────────────────────────────
|
||||
|
||||
(define clos-find-class (fn (name) (get clos-class-registry name)))
|
||||
|
||||
(define
|
||||
clos-change-class!
|
||||
(fn
|
||||
(instance new-class-name)
|
||||
(if
|
||||
(and (dict? instance) (= (get instance "clos-type") "instance"))
|
||||
(dict-set! instance "class" new-class-name)
|
||||
(error (str "Not a CLOS instance: " (inspect instance))))))
|
||||
|
||||
;; ── defgeneric ────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-defgeneric
|
||||
(fn
|
||||
(name options)
|
||||
(let
|
||||
((combination (or (get options "method-combination") "standard")))
|
||||
(when
|
||||
(nil? (get clos-generic-registry name))
|
||||
(dict-set! clos-generic-registry name {:methods (list) :combination combination :name name}))
|
||||
name)))
|
||||
|
||||
;; ── defmethod ─────────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; method-fn: (fn (args next-fn) body)
|
||||
;; args = list of all call arguments
|
||||
;; next-fn = (fn () next-method-result) or nil
|
||||
|
||||
(define
|
||||
clos-defmethod
|
||||
(fn
|
||||
(generic-name qualifiers specializers method-fn)
|
||||
(when
|
||||
(nil? (get clos-generic-registry generic-name))
|
||||
(clos-defgeneric generic-name {}))
|
||||
(let
|
||||
((grec (get clos-generic-registry generic-name))
|
||||
(new-method {:fn method-fn :qualifiers qualifiers :specializers specializers}))
|
||||
(let
|
||||
((kept (filter (fn (m) (not (and (= (get m "qualifiers") qualifiers) (= (get m "specializers") specializers)))) (get grec "methods"))))
|
||||
(dict-set!
|
||||
clos-generic-registry
|
||||
generic-name
|
||||
(assoc grec "methods" (append kept (list new-method))))
|
||||
generic-name))))
|
||||
|
||||
;; Now install the real accessor-method installer
|
||||
(set!
|
||||
clos-add-reader-method
|
||||
(fn
|
||||
(method-name class-name slot-name)
|
||||
(clos-defmethod
|
||||
method-name
|
||||
(list)
|
||||
(list class-name)
|
||||
(fn (args next-fn) (clos-slot-value (first args) slot-name)))))
|
||||
|
||||
;; ── method specificity ─────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-method-matches?
|
||||
(fn
|
||||
(method args)
|
||||
(let
|
||||
((specs (get method "specializers")))
|
||||
(if
|
||||
(> (len specs) (len args))
|
||||
false
|
||||
(define
|
||||
check-all
|
||||
(fn
|
||||
(i)
|
||||
(if
|
||||
(>= i (len specs))
|
||||
true
|
||||
(let
|
||||
((spec (nth specs i)) (arg (nth args i)))
|
||||
(if
|
||||
(= spec "t")
|
||||
(check-all (+ i 1))
|
||||
(if
|
||||
(clos-instance-of? arg spec)
|
||||
(check-all (+ i 1))
|
||||
false))))))
|
||||
(check-all 0)))))
|
||||
|
||||
;; Precedence distance: how far class-name is from spec-name up the hierarchy.
|
||||
(define
|
||||
clos-specificity
|
||||
(let
|
||||
((registry clos-class-registry))
|
||||
(fn
|
||||
(class-name spec-name)
|
||||
(define
|
||||
walk
|
||||
(fn
|
||||
(cn depth)
|
||||
(if
|
||||
(= cn spec-name)
|
||||
depth
|
||||
(let
|
||||
((rec (get registry cn)))
|
||||
(if
|
||||
(nil? rec)
|
||||
nil
|
||||
(let
|
||||
((results (map (fn (p) (walk p (+ depth 1))) (get rec "parents"))))
|
||||
(let
|
||||
((non-nil (filter (fn (x) (not (nil? x))) results)))
|
||||
(if
|
||||
(empty? non-nil)
|
||||
nil
|
||||
(reduce
|
||||
(fn (a b) (if (< a b) a b))
|
||||
(first non-nil)
|
||||
(rest non-nil))))))))))
|
||||
(walk class-name 0))))
|
||||
|
||||
(define
|
||||
clos-method-more-specific?
|
||||
(fn
|
||||
(m1 m2 args)
|
||||
(let
|
||||
((s1 (get m1 "specializers")) (s2 (get m2 "specializers")))
|
||||
(define
|
||||
cmp
|
||||
(fn
|
||||
(i)
|
||||
(if
|
||||
(>= i (len s1))
|
||||
false
|
||||
(let
|
||||
((c1 (clos-specificity (clos-class-of (nth args i)) (nth s1 i)))
|
||||
(c2
|
||||
(clos-specificity (clos-class-of (nth args i)) (nth s2 i))))
|
||||
(cond
|
||||
((and (nil? c1) (nil? c2)) (cmp (+ i 1)))
|
||||
((nil? c1) false)
|
||||
((nil? c2) true)
|
||||
((< c1 c2) true)
|
||||
((> c1 c2) false)
|
||||
(:else (cmp (+ i 1))))))))
|
||||
(cmp 0))))
|
||||
|
||||
(define
|
||||
clos-sort-methods
|
||||
(fn
|
||||
(methods args)
|
||||
(define
|
||||
insert
|
||||
(fn
|
||||
(m sorted)
|
||||
(if
|
||||
(empty? sorted)
|
||||
(list m)
|
||||
(if
|
||||
(clos-method-more-specific? m (first sorted) args)
|
||||
(cons m sorted)
|
||||
(cons (first sorted) (insert m (rest sorted)))))))
|
||||
(reduce (fn (acc m) (insert m acc)) (list) methods)))
|
||||
|
||||
;; ── call-generic (standard method combination) ─────────────────────────────
|
||||
|
||||
(define
|
||||
clos-call-generic
|
||||
(fn
|
||||
(generic-name args)
|
||||
(let
|
||||
((grec (get clos-generic-registry generic-name)))
|
||||
(if
|
||||
(nil? grec)
|
||||
(error (str "No generic function: " generic-name))
|
||||
(let
|
||||
((applicable (filter (fn (m) (clos-method-matches? m args)) (get grec "methods"))))
|
||||
(if
|
||||
(empty? applicable)
|
||||
(error
|
||||
(str
|
||||
"No applicable method for "
|
||||
generic-name
|
||||
" with classes "
|
||||
(inspect (map clos-class-of args))))
|
||||
(let
|
||||
((primary (filter (fn (m) (empty? (get m "qualifiers"))) applicable))
|
||||
(before
|
||||
(filter
|
||||
(fn (m) (= (get m "qualifiers") (list "before")))
|
||||
applicable))
|
||||
(after
|
||||
(filter
|
||||
(fn (m) (= (get m "qualifiers") (list "after")))
|
||||
applicable))
|
||||
(around
|
||||
(filter
|
||||
(fn (m) (= (get m "qualifiers") (list "around")))
|
||||
applicable)))
|
||||
(let
|
||||
((sp (clos-sort-methods primary args))
|
||||
(sb (clos-sort-methods before args))
|
||||
(sa (clos-sort-methods after args))
|
||||
(sw (clos-sort-methods around args)))
|
||||
(define
|
||||
make-primary-chain
|
||||
(fn
|
||||
(methods)
|
||||
(if
|
||||
(empty? methods)
|
||||
(fn
|
||||
()
|
||||
(error (str "No next primary method: " generic-name)))
|
||||
(fn
|
||||
()
|
||||
((get (first methods) "fn")
|
||||
args
|
||||
(make-primary-chain (rest methods)))))))
|
||||
(define
|
||||
make-around-chain
|
||||
(fn
|
||||
(around-methods inner-thunk)
|
||||
(if
|
||||
(empty? around-methods)
|
||||
inner-thunk
|
||||
(fn
|
||||
()
|
||||
((get (first around-methods) "fn")
|
||||
args
|
||||
(make-around-chain
|
||||
(rest around-methods)
|
||||
inner-thunk))))))
|
||||
(for-each (fn (m) ((get m "fn") args (fn () nil))) sb)
|
||||
(let
|
||||
((primary-thunk (make-primary-chain sp)))
|
||||
(let
|
||||
((result (if (empty? sw) (primary-thunk) ((make-around-chain sw primary-thunk)))))
|
||||
(for-each
|
||||
(fn (m) ((get m "fn") args (fn () nil)))
|
||||
(reverse sa))
|
||||
result))))))))))
|
||||
|
||||
;; ── call-next-method / next-method-p ──────────────────────────────────────
|
||||
|
||||
(define clos-call-next-method (fn (next-fn) (next-fn)))
|
||||
|
||||
(define clos-next-method-p (fn (next-fn) (not (nil? next-fn))))
|
||||
|
||||
;; ── with-slots ────────────────────────────────────────────────────────────
|
||||
|
||||
(define
|
||||
clos-with-slots
|
||||
(fn
|
||||
(instance slot-names body-fn)
|
||||
(let
|
||||
((vals (map (fn (s) (clos-slot-value instance s)) slot-names)))
|
||||
(apply body-fn vals))))
|
||||
161
lib/common-lisp/conformance.sh
Executable file
161
lib/common-lisp/conformance.sh
Executable file
@@ -0,0 +1,161 @@
|
||||
#!/usr/bin/env bash
|
||||
# lib/common-lisp/conformance.sh — CL-on-SX conformance test runner
|
||||
#
|
||||
# Runs all Common Lisp test suites and writes scoreboard.json + scoreboard.md.
|
||||
#
|
||||
# Usage:
|
||||
# bash lib/common-lisp/conformance.sh
|
||||
# bash lib/common-lisp/conformance.sh -v
|
||||
|
||||
set -uo pipefail
|
||||
cd "$(git rev-parse --show-toplevel)"
|
||||
|
||||
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||
fi
|
||||
if [ ! -x "$SX_SERVER" ]; then
|
||||
echo "ERROR: sx_server.exe not found."
|
||||
exit 1
|
||||
fi
|
||||
|
||||
VERBOSE="${1:-}"
|
||||
TOTAL_PASS=0; TOTAL_FAIL=0
|
||||
SUITE_NAMES=()
|
||||
SUITE_PASS=()
|
||||
SUITE_FAIL=()
|
||||
|
||||
# run_suite NAME "file1 file2 ..." PASS_VAR FAIL_VAR FAILURES_VAR
|
||||
run_suite() {
|
||||
local name="$1" load_files="$2" pass_var="$3" fail_var="$4" failures_var="$5"
|
||||
local TMP; TMP=$(mktemp)
|
||||
{
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n'
|
||||
local i=2
|
||||
for f in $load_files; do
|
||||
printf '(epoch %d)\n(load "%s")\n' "$i" "$f"
|
||||
i=$((i+1))
|
||||
done
|
||||
printf '(epoch 100)\n(eval "%s")\n' "$pass_var"
|
||||
printf '(epoch 101)\n(eval "%s")\n' "$fail_var"
|
||||
} > "$TMP"
|
||||
local OUT; OUT=$(timeout 30 "$SX_SERVER" < "$TMP" 2>/dev/null)
|
||||
rm -f "$TMP"
|
||||
local P F
|
||||
P=$(echo "$OUT" | grep -A1 "^(ok-len 100 " | tail -1 | tr -d ' ()' || true)
|
||||
F=$(echo "$OUT" | grep -A1 "^(ok-len 101 " | tail -1 | tr -d ' ()' || true)
|
||||
# Also try plain (ok 100 N) format
|
||||
[ -z "$P" ] && P=$(echo "$OUT" | grep "^(ok 100 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$F" ] && F=$(echo "$OUT" | grep "^(ok 101 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
|
||||
SUITE_NAMES+=("$name")
|
||||
SUITE_PASS+=("$P")
|
||||
SUITE_FAIL+=("$F")
|
||||
TOTAL_PASS=$((TOTAL_PASS + P))
|
||||
TOTAL_FAIL=$((TOTAL_FAIL + F))
|
||||
if [ "$F" = "0" ] && [ "${P:-0}" -gt 0 ] 2>/dev/null; then
|
||||
echo " PASS $name ($P tests)"
|
||||
else
|
||||
echo " FAIL $name ($P passed, $F failed)"
|
||||
fi
|
||||
}
|
||||
|
||||
echo "=== Common Lisp on SX — Conformance Run ==="
|
||||
echo ""
|
||||
|
||||
run_suite "Phase 1: tokenizer/reader" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/tests/read.sx" \
|
||||
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||
|
||||
run_suite "Phase 1: parser/lambda-lists" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/tests/lambda.sx" \
|
||||
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||
|
||||
run_suite "Phase 2: evaluator" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/eval.sx" \
|
||||
"cl-test-pass" "cl-test-fail" "cl-test-fails"
|
||||
|
||||
run_suite "Phase 3: condition system" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/conditions.sx" \
|
||||
"passed" "failed" "failures"
|
||||
|
||||
run_suite "Phase 3: restart-demo" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/restart-demo.sx" \
|
||||
"demo-passed" "demo-failed" "demo-failures"
|
||||
|
||||
run_suite "Phase 3: parse-recover" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/parse-recover.sx" \
|
||||
"parse-passed" "parse-failed" "parse-failures"
|
||||
|
||||
run_suite "Phase 3: interactive-debugger" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
||||
"debugger-passed" "debugger-failed" "debugger-failures"
|
||||
|
||||
run_suite "Phase 4: CLOS" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/clos.sx" \
|
||||
"passed" "failed" "failures"
|
||||
|
||||
run_suite "Phase 4: geometry" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/geometry.sx" \
|
||||
"geo-passed" "geo-failed" "geo-failures"
|
||||
|
||||
run_suite "Phase 4: mop-trace" \
|
||||
"lib/common-lisp/runtime.sx lib/common-lisp/clos.sx lib/common-lisp/tests/programs/mop-trace.sx" \
|
||||
"mop-passed" "mop-failed" "mop-failures"
|
||||
|
||||
run_suite "Phase 5: macros+LOOP" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/loop.sx lib/common-lisp/tests/macros.sx" \
|
||||
"macro-passed" "macro-failed" "macro-failures"
|
||||
|
||||
run_suite "Phase 6: stdlib" \
|
||||
"lib/common-lisp/reader.sx lib/common-lisp/parser.sx lib/common-lisp/eval.sx lib/common-lisp/tests/stdlib.sx" \
|
||||
"stdlib-passed" "stdlib-failed" "stdlib-failures"
|
||||
|
||||
echo ""
|
||||
echo "=== Total: $TOTAL_PASS passed, $TOTAL_FAIL failed ==="
|
||||
|
||||
# ── write scoreboard.json ─────────────────────────────────────────────────
|
||||
|
||||
SCORE_DIR="lib/common-lisp"
|
||||
JSON="$SCORE_DIR/scoreboard.json"
|
||||
{
|
||||
printf '{\n'
|
||||
printf ' "generated": "%s",\n' "$(date -u +%Y-%m-%dT%H:%M:%SZ)"
|
||||
printf ' "total_pass": %d,\n' "$TOTAL_PASS"
|
||||
printf ' "total_fail": %d,\n' "$TOTAL_FAIL"
|
||||
printf ' "suites": [\n'
|
||||
first=true
|
||||
for i in "${!SUITE_NAMES[@]}"; do
|
||||
if [ "$first" = "true" ]; then first=false; else printf ',\n'; fi
|
||||
printf ' {"name": "%s", "pass": %d, "fail": %d}' \
|
||||
"${SUITE_NAMES[$i]}" "${SUITE_PASS[$i]}" "${SUITE_FAIL[$i]}"
|
||||
done
|
||||
printf '\n ]\n'
|
||||
printf '}\n'
|
||||
} > "$JSON"
|
||||
|
||||
# ── write scoreboard.md ───────────────────────────────────────────────────
|
||||
|
||||
MD="$SCORE_DIR/scoreboard.md"
|
||||
{
|
||||
printf '# Common Lisp on SX — Scoreboard\n\n'
|
||||
printf '_Generated: %s_\n\n' "$(date -u '+%Y-%m-%d %H:%M UTC')"
|
||||
printf '| Suite | Pass | Fail | Status |\n'
|
||||
printf '|-------|------|------|--------|\n'
|
||||
for i in "${!SUITE_NAMES[@]}"; do
|
||||
p="${SUITE_PASS[$i]}" f="${SUITE_FAIL[$i]}"
|
||||
status=""
|
||||
if [ "$f" = "0" ] && [ "${p:-0}" -gt 0 ] 2>/dev/null; then
|
||||
status="pass"
|
||||
else
|
||||
status="FAIL"
|
||||
fi
|
||||
printf '| %s | %s | %s | %s |\n' "${SUITE_NAMES[$i]}" "$p" "$f" "$status"
|
||||
done
|
||||
printf '\n**Total: %d passed, %d failed**\n' "$TOTAL_PASS" "$TOTAL_FAIL"
|
||||
} > "$MD"
|
||||
|
||||
echo ""
|
||||
echo "Scoreboard written to $JSON and $MD"
|
||||
|
||||
[ "$TOTAL_FAIL" -eq 0 ]
|
||||
@@ -20,6 +20,37 @@
|
||||
|
||||
(define cl-global-env (cl-make-env))
|
||||
|
||||
;; ── package state ─────────────────────────────────────────────────
|
||||
(define cl-packages {})
|
||||
(define cl-current-package "COMMON-LISP-USER")
|
||||
(define cl-reader-macros {})
|
||||
(define cl-dispatch-macros {})
|
||||
(define cl-package-sep?
|
||||
(fn (s)
|
||||
(let ((colon (some (fn (i) (if (= (substr s i 1) ":") i false))
|
||||
(range 0 (len s)))))
|
||||
(if colon
|
||||
(let ((pkg (substr s 0 colon))
|
||||
(rest2 (if (and (< (+ colon 1) (len s))
|
||||
(= (substr s (+ colon 1) 1) ":"))
|
||||
(substr s (+ colon 2) (- (len s) (+ colon 2)))
|
||||
(substr s (+ colon 1) (- (len s) (+ colon 1))))))
|
||||
{:pkg pkg :name rest2})
|
||||
nil))))
|
||||
|
||||
;; ── macro registry ────────────────────────────────────────────────
|
||||
;; cl-macro-registry: symbol-name -> (fn (form env) expanded-form)
|
||||
(define cl-macro-registry (dict))
|
||||
|
||||
;; Gensym counter (eval-time, distinct from runtime.sx cl-gensym)
|
||||
(define cl-gensym-counter 0)
|
||||
(define cl-eval-gensym
|
||||
(fn (prefix)
|
||||
(do
|
||||
(set! cl-gensym-counter (+ cl-gensym-counter 1))
|
||||
(str (if (nil? prefix) "G" prefix) cl-gensym-counter))))
|
||||
|
||||
|
||||
(define cl-env-get-var (fn (env name) (get (get env "vars") name)))
|
||||
(define cl-env-has-var? (fn (env name) (has-key? (get env "vars") name)))
|
||||
(define cl-env-get-fn (fn (env name) (get (get env "fns") name)))
|
||||
@@ -43,6 +74,18 @@
|
||||
(define cl-go-tag?
|
||||
(fn (v) (and (dict? v) (= (get v "cl-type") "go-tag"))))
|
||||
|
||||
(define cl-mv?
|
||||
(fn (v) (and (dict? v) (= (get v "cl-type") "mv"))))
|
||||
|
||||
(define cl-mv-primary
|
||||
(fn (v)
|
||||
(if (cl-mv? v)
|
||||
(if (> (len (get v "vals")) 0) (nth (get v "vals") 0) nil)
|
||||
v)))
|
||||
|
||||
(define cl-mv-vals
|
||||
(fn (v) (if (cl-mv? v) (get v "vals") (list v))))
|
||||
|
||||
(define cl-eval-body
|
||||
(fn (forms env)
|
||||
(cond
|
||||
@@ -165,6 +208,174 @@
|
||||
(let ((e5 (cl-bind-aux aux-specs e4)))
|
||||
(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
|
||||
(fn (item lst)
|
||||
(if (= lst nil) nil
|
||||
(if (= (len lst) 0) nil
|
||||
(if (= (nth lst 0) item)
|
||||
lst
|
||||
(cl-member-helper item (rest lst)))))))
|
||||
|
||||
(define cl-subst-helper
|
||||
(fn (new old tree)
|
||||
(if (= tree old) new
|
||||
(if (and (list? tree) (> (len tree) 0))
|
||||
(map (fn (x) (cl-subst-helper new old x)) tree)
|
||||
tree))))
|
||||
|
||||
(define cl-position-helper
|
||||
(fn (item lst idx)
|
||||
(if (= lst nil) nil
|
||||
(if (= (len lst) 0) nil
|
||||
(if (= (nth lst 0) item)
|
||||
idx
|
||||
(cl-position-helper item (rest lst) (+ idx 1)))))))
|
||||
|
||||
(define cl-position-if-helper
|
||||
(fn (fn-obj lst idx)
|
||||
(if (= lst nil) nil
|
||||
(if (= (len lst) 0) nil
|
||||
(if (cl-apply fn-obj (list (nth lst 0)))
|
||||
idx
|
||||
(cl-position-if-helper fn-obj (rest lst) (+ idx 1)))))))
|
||||
|
||||
;; ── built-in functions ────────────────────────────────────────────
|
||||
|
||||
(define cl-builtins
|
||||
@@ -190,18 +401,27 @@
|
||||
"<=" (fn (args) (if (<= (nth args 0) (nth args 1)) true nil))
|
||||
">=" (fn (args) (if (>= (nth args 0) (nth args 1)) true nil))
|
||||
"NOT" (fn (args) (if (nth args 0) nil true))
|
||||
"NULL" (fn (args) (if (= (nth args 0) nil) true nil))
|
||||
"NULL" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (or (= x nil) (and (list? x) (= (len x) 0))) true nil)))
|
||||
"NUMBERP" (fn (args) (if (number? (nth args 0)) true nil))
|
||||
"STRINGP" (fn (args) (if (string? (nth args 0)) true nil))
|
||||
"SYMBOLP" (fn (args) nil)
|
||||
"LISTP" (fn (args)
|
||||
(if (or (list? (nth args 0)) (= (nth args 0) nil)) true nil))
|
||||
(let ((x (nth args 0)))
|
||||
(if (or (list? x) (= x nil)
|
||||
(and (dict? x) (= (get x "cl-type") "cons")))
|
||||
true nil)))
|
||||
"CONSP" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "cons")) true nil)))
|
||||
(if (or (and (list? x) (> (len x) 0))
|
||||
(and (dict? x) (= (get x "cl-type") "cons")))
|
||||
true nil)))
|
||||
"ATOM" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "cons")) nil true)))
|
||||
(if (or (and (list? x) (> (len x) 0))
|
||||
(and (dict? x) (= (get x "cl-type") "cons")))
|
||||
nil true)))
|
||||
"FUNCTIONP" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (dict? x) (= (get x "cl-type") "function")) true nil)))
|
||||
@@ -252,7 +472,7 @@
|
||||
(reduce (fn (acc x) (concat (list x) acc))
|
||||
(list) (nth args 0)))
|
||||
"IDENTITY" (fn (args) (nth args 0))
|
||||
"VALUES" (fn (args) (if (> (len args) 0) (nth args 0) nil))
|
||||
"VALUES" (fn (args) (cond ((= (len args) 0) nil) ((= (len args) 1) (nth args 0)) (:else {:cl-type "mv" :vals args})))
|
||||
"PRINT" (fn (args) (nth args 0))
|
||||
"PRIN1" (fn (args) (nth args 0))
|
||||
"PRINC" (fn (args) (nth args 0))
|
||||
@@ -264,7 +484,235 @@
|
||||
"CONCATENATE" (fn (args) (reduce (fn (a b) (str a b)) "" (rest args)))
|
||||
"EQ" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||
"EQL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||
"EQUAL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))))
|
||||
"EQUAL" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||
;; sequence functions
|
||||
"MAPC" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(begin
|
||||
(for-each (fn (x) (cl-apply fn-obj (list x))) lst)
|
||||
(nth args 1))))
|
||||
"MAPCAN" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(reduce (fn (acc x)
|
||||
(let ((r (cl-apply fn-obj (list x))))
|
||||
(if (= r nil) acc
|
||||
(concat acc r))))
|
||||
(list) lst)))
|
||||
"REDUCE" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(let ((iv-r (cl-find-kw-arg "INITIAL-VALUE" args 2)))
|
||||
(let ((has-iv (get iv-r "found"))
|
||||
(iv (get iv-r "value")))
|
||||
(if (= (len lst) 0)
|
||||
(if has-iv iv (cl-apply fn-obj (list)))
|
||||
(if has-iv
|
||||
(reduce (fn (acc x) (cl-apply fn-obj (list acc x))) iv lst)
|
||||
(reduce (fn (acc x) (cl-apply fn-obj (list acc x)))
|
||||
(nth lst 0) (rest lst))))))))
|
||||
"FIND" (fn (args)
|
||||
(let ((item (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(let ((r (some (fn (x) (if (= x item) x false)) lst)))
|
||||
(if r r nil))))
|
||||
"FIND-IF" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(let ((r (some (fn (x)
|
||||
(let ((res (cl-apply fn-obj (list x))))
|
||||
(if res x false)))
|
||||
lst)))
|
||||
(if r r nil))))
|
||||
"FIND-IF-NOT" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(let ((r (some (fn (x)
|
||||
(let ((res (cl-apply fn-obj (list x))))
|
||||
(if res false x)))
|
||||
lst)))
|
||||
(if r r nil))))
|
||||
"POSITION" (fn (args)
|
||||
(cl-position-helper (nth args 0)
|
||||
(if (= (nth args 1) nil) (list) (nth args 1)) 0))
|
||||
"POSITION-IF" (fn (args)
|
||||
(cl-position-if-helper (nth args 0)
|
||||
(if (= (nth args 1) nil) (list) (nth args 1)) 0))
|
||||
"COUNT" (fn (args)
|
||||
(let ((item (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(len (filter (fn (x) (= x item)) lst))))
|
||||
"COUNT-IF" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(len (filter (fn (x) (cl-apply fn-obj (list x))) lst))))
|
||||
"EVERY" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(if (every? (fn (x) (cl-apply fn-obj (list x))) lst) true nil)))
|
||||
"SOME" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(let ((r (some (fn (x) (cl-apply fn-obj (list x))) lst)))
|
||||
(if r r nil))))
|
||||
"NOTANY" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(if (some (fn (x) (cl-apply fn-obj (list x))) lst) nil true)))
|
||||
"NOTEVERY" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(if (every? (fn (x) (cl-apply fn-obj (list x))) lst) nil true)))
|
||||
"REMOVE" (fn (args)
|
||||
(let ((item (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(filter (fn (x) (not (= x item))) lst)))
|
||||
"REMOVE-IF" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(filter (fn (x) (not (cl-apply fn-obj (list x)))) lst)))
|
||||
"REMOVE-IF-NOT" (fn (args)
|
||||
(let ((fn-obj (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(filter (fn (x) (cl-apply fn-obj (list x))) lst)))
|
||||
"SUBST" (fn (args)
|
||||
(cl-subst-helper (nth args 0) (nth args 1)
|
||||
(if (= (nth args 2) nil) (list) (nth args 2))))
|
||||
"MEMBER" (fn (args)
|
||||
(cl-member-helper (nth args 0)
|
||||
(if (= (nth args 1) nil) nil (nth args 1))))
|
||||
;; list ops
|
||||
"ASSOC" (fn (args)
|
||||
(let ((key (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(let ((r (some
|
||||
(fn (pair)
|
||||
(let ((k (if (and (dict? pair) (= (get pair "cl-type") "cons"))
|
||||
(get pair "car")
|
||||
(if (and (list? pair) (> (len pair) 0))
|
||||
(nth pair 0)
|
||||
nil))))
|
||||
(if (= k key) pair false)))
|
||||
lst)))
|
||||
(if r r nil))))
|
||||
"RASSOC" (fn (args)
|
||||
(let ((val (nth args 0))
|
||||
(lst (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(let ((r (some
|
||||
(fn (pair)
|
||||
(let ((v (if (and (dict? pair) (= (get pair "cl-type") "cons"))
|
||||
(get pair "cdr")
|
||||
(if (and (list? pair) (> (len pair) 1))
|
||||
(nth pair 1)
|
||||
nil))))
|
||||
(if (= v val) pair false)))
|
||||
lst)))
|
||||
(if r r nil))))
|
||||
"GETF" (fn (args)
|
||||
(let ((plist (if (= (nth args 0) nil) (list) (nth args 0)))
|
||||
(ind (nth args 1))
|
||||
(def (if (> (len args) 2) (nth args 2) nil)))
|
||||
(let ((ind-name (if (and (dict? ind) (= (get ind "cl-type") "keyword"))
|
||||
(get ind "name")
|
||||
(upcase (str ind)))))
|
||||
(let ((r (cl-find-kw-arg ind-name plist 0)))
|
||||
(if (get r "found") (get r "value") def)))))
|
||||
"LAST" (fn (args)
|
||||
(let ((lst (nth args 0)))
|
||||
(if (or (= lst nil) (= (len lst) 0)) nil
|
||||
(list (nth lst (- (len lst) 1))))))
|
||||
"BUTLAST" (fn (args)
|
||||
(let ((lst (nth args 0)))
|
||||
(if (or (= lst nil) (= (len lst) 0)) (list)
|
||||
(slice lst 0 (- (len lst) 1)))))
|
||||
"NTHCDR" (fn (args)
|
||||
(let ((n (nth args 0))
|
||||
(lst (nth args 1)))
|
||||
(if (= lst nil) nil
|
||||
(if (>= n (len lst)) nil
|
||||
(slice lst n (len lst))))))
|
||||
"COPY-LIST" (fn (args) (nth args 0))
|
||||
"LIST*" (fn (args)
|
||||
(if (= (len args) 0) nil
|
||||
(if (= (len args) 1) (nth args 0)
|
||||
(let ((head (slice args 0 (- (len args) 1)))
|
||||
(tail (nth args (- (len args) 1))))
|
||||
(concat head (if (list? tail) tail (list tail)))))))
|
||||
"CAAR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(let ((c (if (and (list? x) (> (len x) 0)) (nth x 0) nil)))
|
||||
(if (and (list? c) (> (len c) 0)) (nth c 0) nil))))
|
||||
"CADR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (list? x) (> (len x) 1)) (nth x 1) nil)))
|
||||
"CDAR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(let ((c (if (and (list? x) (> (len x) 0)) (nth x 0) nil)))
|
||||
(if (and (list? c) (> (len c) 0)) (rest c) nil))))
|
||||
"CDDR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (list? x) (> (len x) 2))
|
||||
(slice x 2 (len x))
|
||||
nil)))
|
||||
"CADDR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (list? x) (> (len x) 2)) (nth x 2) nil)))
|
||||
"CADDDR" (fn (args)
|
||||
(let ((x (nth args 0)))
|
||||
(if (and (list? x) (> (len x) 3)) (nth x 3) nil)))
|
||||
"PAIRLIS" (fn (args)
|
||||
(let ((ks (if (= (nth args 0) nil) (list) (nth args 0)))
|
||||
(vs (if (= (nth args 1) nil) (list) (nth args 1))))
|
||||
(map (fn (i) (list (nth ks i) (nth vs i)))
|
||||
(range 0 (len ks)))))
|
||||
;; string ops
|
||||
"SUBSEQ" (fn (args)
|
||||
(let ((seq (nth args 0))
|
||||
(start (nth args 1))
|
||||
(end (if (> (len args) 2) (nth args 2) nil)))
|
||||
(if (string? seq)
|
||||
(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)
|
||||
(let ((x (nth args 0)))
|
||||
(if (string? x) x (str x))))
|
||||
"CHAR" (fn (args)
|
||||
(let ((s (nth args 0)) (i (nth args 1)))
|
||||
{:cl-type "char" :value (substr s i (+ i 1))}))
|
||||
"CHAR=" (fn (args)
|
||||
(let ((a (nth args 0)) (b (nth args 1)))
|
||||
(let ((av (if (dict? a) (get a "value") a))
|
||||
(bv (if (dict? b) (get b "value") b)))
|
||||
(if (= av bv) true nil))))
|
||||
"STRING-LENGTH" (fn (args) (len (nth args 0)))
|
||||
"STRING<" (fn (args) (if (< (nth args 0) (nth args 1)) true nil))
|
||||
"STRING>" (fn (args) (if (> (nth args 0) (nth args 1)) true nil))
|
||||
"STRING<=" (fn (args) (if (<= (nth args 0) (nth args 1)) true nil))
|
||||
"STRING>=" (fn (args) (if (>= (nth args 0) (nth args 1)) true nil))
|
||||
"WRITE-TO-STRING" (fn (args) (inspect (nth args 0)))
|
||||
"SYMBOL-NAME" (fn (args) (upcase (str (nth args 0))))
|
||||
"COERCE" (fn (args)
|
||||
(let ((x (nth args 0))
|
||||
(tp (upcase (str (nth args 1)))))
|
||||
(cond
|
||||
((= tp "LIST") (if (string? x)
|
||||
(map (fn (i) {:cl-type "char" :value (substr x i (+ i 1))})
|
||||
(range 0 (len x))) x))
|
||||
((= tp "STRING") (if (list? x)
|
||||
(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))))))
|
||||
|
||||
;; Register builtins in cl-global-env so (function #'name) resolves them
|
||||
(for-each
|
||||
@@ -309,6 +757,39 @@
|
||||
(:else (run (+ i 1))))))))))
|
||||
(run 0))))
|
||||
|
||||
;; ── MULTIPLE VALUES ──────────────────────────────────────────────
|
||||
|
||||
(define cl-eval-multiple-value-bind
|
||||
(fn (args env)
|
||||
(let ((vars (nth args 0))
|
||||
(form (nth args 1))
|
||||
(body (rest (rest args))))
|
||||
(let ((vals (cl-mv-vals (cl-eval form env))))
|
||||
(define bind-vars
|
||||
(fn (names i e)
|
||||
(if (= (len names) 0)
|
||||
e
|
||||
(bind-vars (rest names) (+ i 1)
|
||||
(cl-env-bind-var e (nth names 0)
|
||||
(if (< i (len vals)) (nth vals i) nil))))))
|
||||
(cl-eval-body body (bind-vars vars 0 env))))))
|
||||
|
||||
(define cl-eval-multiple-value-call
|
||||
(fn (args env)
|
||||
(let ((fn-obj (cl-eval (nth args 0) env))
|
||||
(forms (rest args)))
|
||||
(let ((all-vals (reduce
|
||||
(fn (acc f)
|
||||
(concat acc (cl-mv-vals (cl-eval f env))))
|
||||
(list) forms)))
|
||||
(cl-apply fn-obj all-vals)))))
|
||||
|
||||
(define cl-eval-multiple-value-prog1
|
||||
(fn (args env)
|
||||
(let ((first-result (cl-eval (nth args 0) env)))
|
||||
(for-each (fn (f) (cl-eval f env)) (rest args))
|
||||
first-result)))
|
||||
|
||||
;; ── UNWIND-PROTECT ───────────────────────────────────────────────
|
||||
|
||||
(define cl-eval-unwind-protect
|
||||
@@ -341,7 +822,7 @@
|
||||
|
||||
(define cl-eval-if
|
||||
(fn (args env)
|
||||
(let ((cond-val (cl-eval (nth args 0) env))
|
||||
(let ((cond-val (cl-mv-primary (cl-eval (nth args 0) env)))
|
||||
(then-form (nth args 1))
|
||||
(else-form (if (> (len args) 2) (nth args 2) nil)))
|
||||
(if cond-val
|
||||
@@ -352,7 +833,7 @@
|
||||
(fn (args env)
|
||||
(if (= (len args) 0)
|
||||
true
|
||||
(let ((val (cl-eval (nth args 0) env)))
|
||||
(let ((val (cl-mv-primary (cl-eval (nth args 0) env))))
|
||||
(if (not val)
|
||||
nil
|
||||
(if (= (len args) 1)
|
||||
@@ -363,7 +844,7 @@
|
||||
(fn (args env)
|
||||
(if (= (len args) 0)
|
||||
nil
|
||||
(let ((val (cl-eval (nth args 0) env)))
|
||||
(let ((val (cl-mv-primary (cl-eval (nth args 0) env))))
|
||||
(if val
|
||||
val
|
||||
(cl-eval-or (rest args) env))))))
|
||||
@@ -373,13 +854,63 @@
|
||||
(if (= (len clauses) 0)
|
||||
nil
|
||||
(let ((clause (nth clauses 0)))
|
||||
(let ((test-val (cl-eval (nth clause 0) env)))
|
||||
(let ((test-val (cl-mv-primary (cl-eval (nth clause 0) env))))
|
||||
(if test-val
|
||||
(if (= (len clause) 1)
|
||||
test-val
|
||||
(cl-eval-body (rest clause) env))
|
||||
(cl-eval-cond (rest clauses) env)))))))
|
||||
|
||||
;; Dynamic variable infrastructure
|
||||
(define cl-dyn-unbound {:cl-type "dyn-unbound"})
|
||||
(define cl-specials {})
|
||||
(define cl-symbol-macros {})
|
||||
(define cl-mark-special!
|
||||
(fn (name) (dict-set! cl-specials name true)))
|
||||
(define cl-special?
|
||||
(fn (name) (has-key? cl-specials name)))
|
||||
;; Apply dynamic bindings: save old global values, set new, run thunk, restore
|
||||
(define cl-apply-dyn
|
||||
(fn (binds thunk)
|
||||
(if (= (len binds) 0)
|
||||
(thunk)
|
||||
(let ((b (nth binds 0))
|
||||
(rest-binds (rest binds)))
|
||||
(let ((name (get b "name"))
|
||||
(val (get b "value"))
|
||||
(gvars (get cl-global-env "vars")))
|
||||
(let ((old (if (has-key? gvars name)
|
||||
(get gvars name)
|
||||
cl-dyn-unbound)))
|
||||
(dict-set! gvars name val)
|
||||
(let ((result (cl-apply-dyn rest-binds thunk)))
|
||||
(if (and (dict? old) (= (get old "cl-type") "dyn-unbound"))
|
||||
(dict-set! gvars name nil)
|
||||
(dict-set! gvars name old))
|
||||
result)))))))
|
||||
;; Sequential LET* with dynamic variable support
|
||||
(define cl-letstar-bind
|
||||
(fn (bs e thunk)
|
||||
(if (= (len bs) 0)
|
||||
(thunk e)
|
||||
(let ((b (nth bs 0))
|
||||
(rest-bs (rest bs)))
|
||||
(let ((name (if (list? b) (nth b 0) b))
|
||||
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
|
||||
(let ((val (cl-eval init e)))
|
||||
(if (cl-special? name)
|
||||
(let ((gvars (get cl-global-env "vars")))
|
||||
(let ((old (if (has-key? gvars name)
|
||||
(get gvars name)
|
||||
cl-dyn-unbound)))
|
||||
(dict-set! gvars name val)
|
||||
(let ((result (cl-letstar-bind rest-bs e thunk)))
|
||||
(if (and (dict? old) (= (get old "cl-type") "dyn-unbound"))
|
||||
(dict-set! gvars name nil)
|
||||
(dict-set! gvars name old))
|
||||
result)))
|
||||
(cl-letstar-bind rest-bs (cl-env-bind-var e name val) thunk))))))))
|
||||
|
||||
;; Parallel LET and sequential LET*
|
||||
(define cl-eval-let
|
||||
(fn (args env sequential)
|
||||
@@ -387,17 +918,7 @@
|
||||
(body (rest args)))
|
||||
(if sequential
|
||||
;; LET*: each binding sees previous ones
|
||||
(let ((new-env env))
|
||||
(define bind-seq
|
||||
(fn (bs e)
|
||||
(if (= (len bs) 0)
|
||||
e
|
||||
(let ((b (nth bs 0)))
|
||||
(let ((name (if (list? b) (nth b 0) b))
|
||||
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
|
||||
(bind-seq (rest bs)
|
||||
(cl-env-bind-var e name (cl-eval init e))))))))
|
||||
(cl-eval-body body (bind-seq bindings env)))
|
||||
(cl-letstar-bind bindings env (fn (new-env) (cl-eval-body body new-env)))
|
||||
;; LET: evaluate all inits in current env, then bind
|
||||
(let ((pairs (map
|
||||
(fn (b)
|
||||
@@ -405,11 +926,14 @@
|
||||
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
|
||||
{:name name :value (cl-eval init env)}))
|
||||
bindings)))
|
||||
(let ((new-env (reduce
|
||||
(fn (e pair)
|
||||
(cl-env-bind-var e (get pair "name") (get pair "value")))
|
||||
env pairs)))
|
||||
(cl-eval-body body new-env)))))))
|
||||
(let ((spec-pairs (filter (fn (p) (cl-special? (get p "name"))) pairs))
|
||||
(lex-pairs (filter (fn (p) (not (cl-special? (get p "name")))) pairs)))
|
||||
(let ((new-env (reduce
|
||||
(fn (e pair)
|
||||
(cl-env-bind-var e (get pair "name") (get pair "value")))
|
||||
env lex-pairs)))
|
||||
(cl-apply-dyn spec-pairs
|
||||
(fn () (cl-eval-body body new-env))))))))))
|
||||
|
||||
;; SETQ / SETF (simplified: mutate nearest scope or global)
|
||||
(define cl-eval-setq
|
||||
@@ -518,12 +1042,15 @@
|
||||
(when (or always-assign
|
||||
(not (cl-env-has-var? cl-global-env name)))
|
||||
(dict-set! (get cl-global-env "vars") name val))
|
||||
(cl-mark-special! name)
|
||||
name))))
|
||||
|
||||
;; Function call: evaluate name → look up fns, builtins; evaluate args
|
||||
(define cl-call-fn
|
||||
(fn (name args env)
|
||||
(let ((evaled (map (fn (a) (cl-eval a env)) args)))
|
||||
(fn (name-raw args env)
|
||||
(let ((name (let ((ps (cl-package-sep? name-raw)))
|
||||
(if ps (get ps "name") name-raw))))
|
||||
(let ((evaled (map (fn (a) (cl-mv-primary (cl-eval a env))) args)))
|
||||
(cond
|
||||
;; FUNCALL: (funcall fn arg...)
|
||||
((= name "FUNCALL")
|
||||
@@ -541,17 +1068,26 @@
|
||||
(lst (nth evaled 1)))
|
||||
(if (= lst nil) (list)
|
||||
(map (fn (x) (cl-apply fn-obj (list x))) lst))))
|
||||
;; Look up in local fns namespace
|
||||
;; Look up in local fns namespace (try bare name via package stripping)
|
||||
((cl-env-has-fn? env name)
|
||||
(cl-apply (cl-env-get-fn env name) evaled))
|
||||
((let ((ps (cl-package-sep? name)))
|
||||
(and ps (cl-env-has-fn? env (get ps "name"))))
|
||||
(cl-apply (cl-env-get-fn env (get (cl-package-sep? name) "name")) evaled))
|
||||
;; Look up in global fns namespace
|
||||
((cl-env-has-fn? cl-global-env name)
|
||||
(cl-apply (cl-env-get-fn cl-global-env name) evaled))
|
||||
;; Look up in builtins
|
||||
((let ((ps (cl-package-sep? name)))
|
||||
(and ps (cl-env-has-fn? cl-global-env (get ps "name"))))
|
||||
(cl-apply (cl-env-get-fn cl-global-env (get (cl-package-sep? name) "name")) evaled))
|
||||
;; Look up in builtins (bare or package-qualified)
|
||||
((has-key? cl-builtins name)
|
||||
((get cl-builtins name) evaled))
|
||||
((let ((ps (cl-package-sep? name)))
|
||||
(and ps (has-key? cl-builtins (get ps "name"))))
|
||||
((get cl-builtins (get (cl-package-sep? name) "name")) evaled))
|
||||
(:else
|
||||
{:cl-type "error" :message (str "Undefined function: " name)})))))
|
||||
{:cl-type "error" :message (str "Undefined function: " name-raw)}))))))
|
||||
|
||||
;; ── main evaluator ────────────────────────────────────────────────
|
||||
|
||||
@@ -569,18 +1105,134 @@
|
||||
(cond
|
||||
((= ct "string") (get form "value")) ;; CL string → SX string
|
||||
(:else form)))) ;; keywords, floats, chars, etc.
|
||||
;; Symbol reference (variable lookup)
|
||||
;; Symbol reference (variable or symbol-macro lookup)
|
||||
((string? form)
|
||||
(cond
|
||||
((cl-env-has-var? env form) (cl-env-get-var env form))
|
||||
((cl-env-has-var? cl-global-env form)
|
||||
(cl-env-get-var cl-global-env form))
|
||||
(:else {:cl-type "error" :message (str "Undefined variable: " form)})))
|
||||
(let ((uform (upcase form)))
|
||||
(let ((bare (let ((ps (cl-package-sep? uform)))
|
||||
(if ps (get ps "name") uform))))
|
||||
(if (and (has-key? cl-symbol-macros bare)
|
||||
(not (= (get cl-symbol-macros bare) nil)))
|
||||
(cl-eval (get cl-symbol-macros bare) env)
|
||||
(cond
|
||||
((cl-env-has-var? env bare) (cl-env-get-var env bare))
|
||||
((cl-env-has-var? cl-global-env bare)
|
||||
(cl-env-get-var cl-global-env bare))
|
||||
(:else {:cl-type "error" :message (str "Undefined variable: " form)}))))))
|
||||
;; List: special forms or function call
|
||||
((list? form) (cl-eval-list form env))
|
||||
;; Anything else self-evaluates
|
||||
(:else form))))
|
||||
|
||||
|
||||
;; Convert a CL cons tree to an SX list (for macro expansion results)
|
||||
(define cl-cons->sx-list
|
||||
(fn (x)
|
||||
(if (and (dict? x) (= (get x "cl-type") "cons"))
|
||||
(cons (cl-cons->sx-list (get x "car"))
|
||||
(cl-cons->sx-list (get x "cdr")))
|
||||
(if (and (dict? x) (= (get x "cl-type") "nil"))
|
||||
(list)
|
||||
(if (list? x)
|
||||
(map cl-cons->sx-list x)
|
||||
x)))))
|
||||
|
||||
;; ── macro expansion ───────────────────────────────────────────────
|
||||
|
||||
;; Expand a macro one level. Returns {:expanded bool :form form}
|
||||
(define cl-macroexpand-1
|
||||
(fn (form env)
|
||||
(if (not (list? form))
|
||||
{:expanded false :form form}
|
||||
(if (= (len form) 0)
|
||||
{:expanded false :form form}
|
||||
(let ((head (nth form 0)))
|
||||
(if (not (string? head))
|
||||
{:expanded false :form form}
|
||||
(let ((uhead (upcase head)))
|
||||
(if (has-key? cl-macro-registry uhead)
|
||||
{:expanded true
|
||||
:form (cl-cons->sx-list ((get cl-macro-registry uhead) form env))}
|
||||
{:expanded false :form form}))))))))
|
||||
|
||||
;; Fully expand macros (loop until stable)
|
||||
(define cl-macroexpand
|
||||
(fn (form env)
|
||||
(let ((r (cl-macroexpand-1 form env)))
|
||||
(if (get r "expanded")
|
||||
(cl-macroexpand (get r "form") env)
|
||||
(get r "form")))))
|
||||
|
||||
|
||||
;; Helper: bind macro lambda-list params to actuals in env
|
||||
(define cl-macro-bind-params
|
||||
(fn (ps as env)
|
||||
(if (= (len ps) 0)
|
||||
env
|
||||
(let ((p (nth ps 0)))
|
||||
(if (= p "&REST")
|
||||
(cl-env-bind-var env (nth ps 1) as)
|
||||
(cl-macro-bind-params
|
||||
(rest ps)
|
||||
(if (= (len as) 0) (list) (rest as))
|
||||
(cl-env-bind-var env p
|
||||
(if (= (len as) 0) nil (nth as 0)))))))))
|
||||
|
||||
;; DEFMACRO: store expander function in macro registry
|
||||
;; (defmacro name (params...) body...)
|
||||
(define cl-eval-defmacro
|
||||
(fn (args env)
|
||||
(let ((name (nth args 0))
|
||||
(params (nth args 1))
|
||||
(body (rest (rest args))))
|
||||
(let ((uname (upcase name)))
|
||||
(let ((expander
|
||||
(fn (form xenv)
|
||||
(let ((actuals (rest form))
|
||||
(bound-env (cl-macro-bind-params (map upcase params) (rest form) env)))
|
||||
(cl-eval-body body bound-env)))))
|
||||
(dict-set! cl-macro-registry uname expander)
|
||||
uname)))))
|
||||
|
||||
;; MACROLET: local macro bindings
|
||||
;; (macrolet ((name params body...) ...) body...)
|
||||
(define cl-eval-macrolet
|
||||
(fn (args env)
|
||||
(let ((bindings (nth args 0))
|
||||
(body (rest args)))
|
||||
(define orig-registry cl-macro-registry)
|
||||
(for-each
|
||||
(fn (b)
|
||||
(let ((name (nth b 0))
|
||||
(params (nth b 1))
|
||||
(mbody (rest (rest b))))
|
||||
(cl-eval-defmacro (list name params (nth mbody 0)) env)))
|
||||
bindings)
|
||||
(let ((result (cl-eval-body body env)))
|
||||
;; restore — not perfect isolation but workable
|
||||
result))))
|
||||
|
||||
;; SYMBOL-MACROLET: bind symbols to expansion forms
|
||||
(define cl-eval-symbol-macrolet
|
||||
(fn (args env)
|
||||
(let ((bindings (nth args 0))
|
||||
(body (rest args)))
|
||||
;; Install each symbol in cl-symbol-macros; save old to restore after
|
||||
(let ((saved (map (fn (b) (let ((sym (upcase (nth b 0))))
|
||||
{:sym sym :old (if (has-key? cl-symbol-macros sym) (get cl-symbol-macros sym) nil)}))
|
||||
bindings)))
|
||||
(for-each
|
||||
(fn (b)
|
||||
(dict-set! cl-symbol-macros (upcase (nth b 0)) (nth b 1)))
|
||||
bindings)
|
||||
(let ((result (cl-eval-body body env)))
|
||||
(for-each
|
||||
(fn (s)
|
||||
(if (= (get s "old") nil)
|
||||
(dict-set! cl-symbol-macros (get s "sym") nil)
|
||||
(dict-set! cl-symbol-macros (get s "sym") (get s "old"))))
|
||||
saved)
|
||||
result)))))
|
||||
|
||||
(define cl-eval-list
|
||||
(fn (form env)
|
||||
(if (= (len form) 0)
|
||||
@@ -588,6 +1240,9 @@
|
||||
(let ((head (nth form 0))
|
||||
(args (rest form)))
|
||||
(cond
|
||||
;; Macro expansion check
|
||||
((and (string? head) (has-key? cl-macro-registry (upcase head)))
|
||||
(cl-eval (cl-macroexpand form env) env))
|
||||
((= head "QUOTE") (nth args 0))
|
||||
((= head "IF") (cl-eval-if args env))
|
||||
((= head "PROGN") (cl-eval-body args env))
|
||||
@@ -615,6 +1270,13 @@
|
||||
((= head "TAGBODY") (cl-eval-tagbody args env))
|
||||
((= head "GO")
|
||||
{:cl-type "go-tag" :tag (nth args 0)})
|
||||
((= head "MULTIPLE-VALUE-BIND") (cl-eval-multiple-value-bind args env))
|
||||
((= head "MULTIPLE-VALUE-CALL") (cl-eval-multiple-value-call args env))
|
||||
((= head "MULTIPLE-VALUE-PROG1") (cl-eval-multiple-value-prog1 args env))
|
||||
((= head "NTH-VALUE")
|
||||
(let ((n (cl-mv-primary (cl-eval (nth args 0) env)))
|
||||
(vals (cl-mv-vals (cl-eval (nth args 1) env))))
|
||||
(if (< n (len vals)) (nth vals n) nil)))
|
||||
((= head "UNWIND-PROTECT") (cl-eval-unwind-protect args env))
|
||||
((= head "BLOCK") (cl-eval-block args env))
|
||||
((= head "RETURN-FROM") (cl-eval-return-from args env))
|
||||
@@ -626,6 +1288,77 @@
|
||||
((= head "DEFCONSTANT") (cl-eval-defvar args env true))
|
||||
((= head "DECLAIM") nil)
|
||||
((= head "PROCLAIM") nil)
|
||||
((= head "SET-MACRO-CHARACTER")
|
||||
(let ((ch (cl-eval (nth args 0) env))
|
||||
(fn-obj (cl-eval (nth args 1) env)))
|
||||
(let ((key (if (and (dict? ch) (= (get ch "cl-type") "char"))
|
||||
(get ch "value")
|
||||
(str ch))))
|
||||
(dict-set! cl-reader-macros key fn-obj)
|
||||
nil)))
|
||||
((= head "GET-MACRO-CHARACTER")
|
||||
(let ((ch (cl-eval (nth args 0) env)))
|
||||
(let ((key (if (and (dict? ch) (= (get ch "cl-type") "char"))
|
||||
(get ch "value")
|
||||
(str ch))))
|
||||
(if (has-key? cl-reader-macros key)
|
||||
(list (get cl-reader-macros key) nil)
|
||||
(list nil nil)))))
|
||||
((= head "SET-DISPATCH-MACRO-CHARACTER")
|
||||
(let ((disp (cl-eval (nth args 0) env))
|
||||
(ch (cl-eval (nth args 1) env))
|
||||
(fn-obj (if (> (len args) 2) (cl-eval (nth args 2) env) nil)))
|
||||
(let ((key (str (if (and (dict? disp) (= (get disp "cl-type") "char")) (get disp "value") (str disp))
|
||||
(if (and (dict? ch) (= (get ch "cl-type") "char")) (get ch "value") (str ch)))))
|
||||
(dict-set! cl-dispatch-macros key fn-obj)
|
||||
nil)))
|
||||
((= head "DEFPACKAGE")
|
||||
(let ((raw (nth args 0)))
|
||||
(let ((name (upcase (cond
|
||||
((and (dict? raw) (= (get raw "cl-type") "keyword")) (get raw "name"))
|
||||
((string? raw) raw)
|
||||
(:else (str raw))))))
|
||||
(let ((exports (some
|
||||
(fn (opt)
|
||||
(if (and (list? opt) (> (len opt) 0)
|
||||
(dict? (nth opt 0))
|
||||
(= (upcase (str (get (nth opt 0) "name"))) "EXPORT"))
|
||||
(rest opt) false))
|
||||
(rest args))))
|
||||
(dict-set! cl-packages name
|
||||
{:name name :exports (if exports exports (list))})
|
||||
name))))
|
||||
((= head "IN-PACKAGE")
|
||||
(let ((raw (nth args 0)))
|
||||
(let ((name (upcase (cond
|
||||
((and (dict? raw) (= (get raw "cl-type") "keyword")) (get raw "name"))
|
||||
((string? raw) raw)
|
||||
(:else (str raw))))))
|
||||
(set! cl-current-package name)
|
||||
name)))
|
||||
((= head "EXPORT") nil)
|
||||
((= head "USE-PACKAGE") nil)
|
||||
((= head "IMPORT") nil)
|
||||
((= head "FIND-PACKAGE")
|
||||
(let ((n (upcase (str (cl-eval (nth args 0) env)))))
|
||||
(if (has-key? cl-packages n) (get cl-packages n) nil)))
|
||||
((= head "PACKAGE-NAME")
|
||||
(if (= (len args) 0) cl-current-package
|
||||
(let ((pkg (cl-eval (nth args 0) env)))
|
||||
(if (string? pkg) pkg (if (dict? pkg) (get pkg "name") nil)))))
|
||||
((= head "DEFMACRO") (cl-eval-defmacro args env))
|
||||
((= head "MACROLET") (cl-eval-macrolet args env))
|
||||
((= head "SYMBOL-MACROLET") (cl-eval-symbol-macrolet args env))
|
||||
((= head "MACROEXPAND-1")
|
||||
(let ((arg (cl-eval (nth args 0) env)))
|
||||
(cl-macroexpand-1 arg env)))
|
||||
((= head "MACROEXPAND")
|
||||
(let ((arg (cl-eval (nth args 0) env)))
|
||||
(cl-macroexpand arg env)))
|
||||
((= head "GENSYM")
|
||||
(cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) nil)))
|
||||
((= head "GENTEMP")
|
||||
(cl-eval-gensym (if (> (len args) 0) (cl-eval (nth args 0) env) "T")))
|
||||
;; Named function call
|
||||
((string? head)
|
||||
(cl-call-fn head args env))
|
||||
|
||||
623
lib/common-lisp/loop.sx
Normal file
623
lib/common-lisp/loop.sx
Normal file
@@ -0,0 +1,623 @@
|
||||
;; 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))))
|
||||
@@ -495,6 +495,47 @@
|
||||
(n)
|
||||
(set! cl-restart-stack (slice cl-restart-stack n (len cl-restart-stack)))))
|
||||
|
||||
;; ── *debugger-hook* + invoke-debugger ────────────────────────────────────
|
||||
;;
|
||||
;; cl-debugger-hook: called when an error propagates with no handler.
|
||||
;; Signature: (fn (condition hook) result). The hook arg is itself
|
||||
;; (so the hook can rebind it to nil to prevent recursion).
|
||||
;; nil = use default (re-raise as host error).
|
||||
|
||||
(define cl-debugger-hook nil)
|
||||
|
||||
(define cl-invoke-debugger
|
||||
(fn (c)
|
||||
(if (nil? cl-debugger-hook)
|
||||
(error (str "Debugger: " (cl-condition-message c)))
|
||||
(let ((hook cl-debugger-hook))
|
||||
(set! cl-debugger-hook nil)
|
||||
(let ((result (hook c hook)))
|
||||
(set! cl-debugger-hook hook)
|
||||
result)))))
|
||||
|
||||
;; ── *break-on-signals* ────────────────────────────────────────────────────
|
||||
;;
|
||||
;; When set to a type name string, cl-signal invokes the debugger hook
|
||||
;; before walking handlers if the condition is of that type.
|
||||
;; nil = disabled (ANSI default).
|
||||
|
||||
(define cl-break-on-signals nil)
|
||||
|
||||
;; ── invoke-restart-interactively ──────────────────────────────────────────
|
||||
;;
|
||||
;; Like invoke-restart but calls the restart's fn with no arguments
|
||||
;; (real CL would prompt the user for each arg via :interactive).
|
||||
|
||||
(define cl-invoke-restart-interactively
|
||||
(fn (name)
|
||||
(let ((entry (cl-find-restart-entry name cl-restart-stack)))
|
||||
(if (nil? entry)
|
||||
(error (str "No active restart: " name))
|
||||
(let ((restart-fn (get entry "fn"))
|
||||
(escape (get entry "escape")))
|
||||
(escape (restart-fn)))))))
|
||||
|
||||
;; ── cl-signal (non-unwinding) ─────────────────────────────────────────────
|
||||
;;
|
||||
;; Walks cl-handler-stack; for each matching entry, calls the handler fn.
|
||||
@@ -514,12 +555,16 @@
|
||||
(begin ((get entry "fn") obj) (cl-signal-obj obj (rest stack)))
|
||||
(cl-signal-obj obj (rest stack)))))))
|
||||
|
||||
(define
|
||||
cl-signal
|
||||
(fn
|
||||
(c)
|
||||
(let
|
||||
((obj (if (cl-condition? c) c (cl-make-condition "simple-condition" "format-control" (str c)))))
|
||||
(define cl-signal
|
||||
(fn (c)
|
||||
(let ((obj (if (cl-condition? c)
|
||||
c
|
||||
(cl-make-condition "simple-condition"
|
||||
"format-control" (str c)))))
|
||||
;; *break-on-signals*: invoke debugger hook when type matches
|
||||
(when (and (not (nil? cl-break-on-signals))
|
||||
(cl-condition-of-type? obj cl-break-on-signals))
|
||||
(cl-invoke-debugger obj))
|
||||
(cl-signal-obj obj cl-handler-stack))))
|
||||
|
||||
;; ── cl-error ───────────────────────────────────────────────────────────────
|
||||
@@ -533,7 +578,7 @@
|
||||
(let
|
||||
((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
|
||||
(cl-signal-obj obj cl-handler-stack)
|
||||
(error (str "Unhandled CL error: " (cl-condition-message obj))))))
|
||||
(cl-invoke-debugger obj))))
|
||||
|
||||
;; ── cl-warn ────────────────────────────────────────────────────────────────
|
||||
|
||||
@@ -660,12 +705,20 @@
|
||||
;; Signals a continuable error. The "continue" restart is established;
|
||||
;; invoke-restart "continue" to proceed past the error.
|
||||
|
||||
(define
|
||||
cl-cerror
|
||||
(fn
|
||||
(continue-string c &rest args)
|
||||
(let
|
||||
((obj (if (cl-condition? c) c (cl-make-condition "simple-error" "format-control" (str c) "format-arguments" args))))
|
||||
|
||||
|
||||
;; ── cl-cerror ──────────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Signals a continuable error. The "continue" restart is established;
|
||||
;; invoke-restart "continue" to proceed past the error.
|
||||
|
||||
(define cl-cerror
|
||||
(fn (continue-string c &rest args)
|
||||
(let ((obj (if (cl-condition? c)
|
||||
c
|
||||
(cl-make-condition "simple-error"
|
||||
"format-control" (str c)
|
||||
"format-arguments" args))))
|
||||
(cl-restart-case
|
||||
(fn () (cl-signal-obj obj cl-handler-stack))
|
||||
(list "continue" (list) (fn () nil))))))
|
||||
19
lib/common-lisp/scoreboard.json
Normal file
19
lib/common-lisp/scoreboard.json
Normal file
@@ -0,0 +1,19 @@
|
||||
{
|
||||
"generated": "2026-05-05T12:35:09Z",
|
||||
"total_pass": 518,
|
||||
"total_fail": 0,
|
||||
"suites": [
|
||||
{"name": "Phase 1: tokenizer/reader", "pass": 79, "fail": 0},
|
||||
{"name": "Phase 1: parser/lambda-lists", "pass": 31, "fail": 0},
|
||||
{"name": "Phase 2: evaluator", "pass": 182, "fail": 0},
|
||||
{"name": "Phase 3: condition system", "pass": 59, "fail": 0},
|
||||
{"name": "Phase 3: restart-demo", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 3: parse-recover", "pass": 6, "fail": 0},
|
||||
{"name": "Phase 3: interactive-debugger", "pass": 7, "fail": 0},
|
||||
{"name": "Phase 4: CLOS", "pass": 41, "fail": 0},
|
||||
{"name": "Phase 4: geometry", "pass": 12, "fail": 0},
|
||||
{"name": "Phase 4: mop-trace", "pass": 13, "fail": 0},
|
||||
{"name": "Phase 5: macros+LOOP", "pass": 27, "fail": 0},
|
||||
{"name": "Phase 6: stdlib", "pass": 54, "fail": 0}
|
||||
]
|
||||
}
|
||||
20
lib/common-lisp/scoreboard.md
Normal file
20
lib/common-lisp/scoreboard.md
Normal file
@@ -0,0 +1,20 @@
|
||||
# Common Lisp on SX — Scoreboard
|
||||
|
||||
_Generated: 2026-05-05 12:35 UTC_
|
||||
|
||||
| Suite | Pass | Fail | Status |
|
||||
|-------|------|------|--------|
|
||||
| Phase 1: tokenizer/reader | 79 | 0 | pass |
|
||||
| Phase 1: parser/lambda-lists | 31 | 0 | pass |
|
||||
| Phase 2: evaluator | 182 | 0 | pass |
|
||||
| Phase 3: condition system | 59 | 0 | pass |
|
||||
| Phase 3: restart-demo | 7 | 0 | pass |
|
||||
| Phase 3: parse-recover | 6 | 0 | pass |
|
||||
| Phase 3: interactive-debugger | 7 | 0 | pass |
|
||||
| Phase 4: CLOS | 41 | 0 | pass |
|
||||
| Phase 4: geometry | 12 | 0 | pass |
|
||||
| Phase 4: mop-trace | 13 | 0 | pass |
|
||||
| Phase 5: macros+LOOP | 27 | 0 | pass |
|
||||
| Phase 6: stdlib | 54 | 0 | pass |
|
||||
|
||||
**Total: 518 passed, 0 failed**
|
||||
@@ -331,6 +331,108 @@ else
|
||||
"
|
||||
fi
|
||||
|
||||
# ── Phase 3: classic program tests ───────────────────────────────────────────
|
||||
run_program_suite() {
|
||||
local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
|
||||
local PROG_FILE=$(mktemp)
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "%s")\n(epoch 4)\n(eval "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n' \
|
||||
"$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
|
||||
local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
|
||||
rm -f "$PROG_FILE"
|
||||
local P F
|
||||
P=$(echo "$OUT" | grep -A1 "^(ok-len 4 " | tail -1 || true)
|
||||
F=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
|
||||
local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
|
||||
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
|
||||
if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then
|
||||
PASS=$((PASS + P))
|
||||
[ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)"
|
||||
else
|
||||
FAIL=$((FAIL + 1))
|
||||
ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS}
|
||||
"
|
||||
fi
|
||||
}
|
||||
|
||||
run_program_suite \
|
||||
"lib/common-lisp/tests/programs/restart-demo.sx" \
|
||||
"demo-passed" "demo-failed" "demo-failures"
|
||||
|
||||
run_program_suite \
|
||||
"lib/common-lisp/tests/programs/parse-recover.sx" \
|
||||
"parse-passed" "parse-failed" "parse-failures"
|
||||
|
||||
run_program_suite \
|
||||
"lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
||||
"debugger-passed" "debugger-failed" "debugger-failures"
|
||||
|
||||
# ── Phase 4: CLOS unit tests ─────────────────────────────────────────────────
|
||||
CLOS_FILE=$(mktemp); trap "rm -f $CLOS_FILE" EXIT
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "lib/common-lisp/tests/clos.sx")\n(epoch 5)\n(eval "passed")\n(epoch 6)\n(eval "failed")\n(epoch 7)\n(eval "failures")\n' > "$CLOS_FILE"
|
||||
CLOS_OUT=$(timeout 30 "$SX_SERVER" < "$CLOS_FILE" 2>/dev/null)
|
||||
rm -f "$CLOS_FILE"
|
||||
CLOS_PASSED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
|
||||
CLOS_FAILED=$(echo "$CLOS_OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
|
||||
[ -z "$CLOS_PASSED" ] && CLOS_PASSED=$(echo "$CLOS_OUT" | grep "^(ok 5 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$CLOS_FAILED" ] && CLOS_FAILED=$(echo "$CLOS_OUT" | grep "^(ok 6 " | awk '{print $3}' | tr -d ')' || true)
|
||||
[ -z "$CLOS_PASSED" ] && CLOS_PASSED=0; [ -z "$CLOS_FAILED" ] && CLOS_FAILED=0
|
||||
if [ "$CLOS_FAILED" = "0" ] && [ "$CLOS_PASSED" -gt 0 ] 2>/dev/null; then
|
||||
PASS=$((PASS + CLOS_PASSED))
|
||||
[ "$VERBOSE" = "-v" ] && echo " ok CLOS unit tests ($CLOS_PASSED)"
|
||||
else
|
||||
FAIL=$((FAIL + 1))
|
||||
ERRORS+=" FAIL [CLOS unit tests] (${CLOS_PASSED} passed, ${CLOS_FAILED} failed)
|
||||
"
|
||||
fi
|
||||
|
||||
# ── Phase 4: CLOS classic programs ───────────────────────────────────────────
|
||||
run_clos_suite() {
|
||||
local prog="$1" pass_var="$2" fail_var="$3" failures_var="$4"
|
||||
local PROG_FILE=$(mktemp)
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/runtime.sx")\n(epoch 3)\n(load "lib/common-lisp/clos.sx")\n(epoch 4)\n(load "%s")\n(epoch 5)\n(eval "%s")\n(epoch 6)\n(eval "%s")\n(epoch 7)\n(eval "%s")\n' \
|
||||
"$prog" "$pass_var" "$fail_var" "$failures_var" > "$PROG_FILE"
|
||||
local OUT; OUT=$(timeout 20 "$SX_SERVER" < "$PROG_FILE" 2>/dev/null)
|
||||
rm -f "$PROG_FILE"
|
||||
local P F
|
||||
P=$(echo "$OUT" | grep -A1 "^(ok-len 5 " | tail -1 || true)
|
||||
F=$(echo "$OUT" | grep -A1 "^(ok-len 6 " | tail -1 || true)
|
||||
local ERRS; ERRS=$(echo "$OUT" | grep -A1 "^(ok-len 7 " | tail -1 || true)
|
||||
[ -z "$P" ] && P=0; [ -z "$F" ] && F=0
|
||||
if [ "$F" = "0" ] && [ "$P" -gt 0 ] 2>/dev/null; then
|
||||
PASS=$((PASS + P))
|
||||
[ "$VERBOSE" = "-v" ] && echo " ok $prog ($P)"
|
||||
else
|
||||
FAIL=$((FAIL + 1))
|
||||
ERRORS+=" FAIL [$prog] (${P} passed, ${F} failed) ${ERRS}
|
||||
"
|
||||
fi
|
||||
}
|
||||
|
||||
run_clos_suite \
|
||||
"lib/common-lisp/tests/programs/geometry.sx" \
|
||||
"geo-passed" "geo-failed" "geo-failures"
|
||||
|
||||
run_clos_suite \
|
||||
"lib/common-lisp/tests/programs/mop-trace.sx" \
|
||||
"mop-passed" "mop-failed" "mop-failures"
|
||||
|
||||
# ── Phase 5: macros + LOOP ───────────────────────────────────────────────────
|
||||
MACRO_FILE=$(mktemp); trap "rm -f $MACRO_FILE" EXIT
|
||||
printf '(epoch 1)\n(load "spec/stdlib.sx")\n(epoch 2)\n(load "lib/common-lisp/reader.sx")\n(epoch 3)\n(load "lib/common-lisp/parser.sx")\n(epoch 4)\n(load "lib/common-lisp/eval.sx")\n(epoch 5)\n(load "lib/common-lisp/loop.sx")\n(epoch 6)\n(load "lib/common-lisp/tests/macros.sx")\n(epoch 7)\n(eval "macro-passed")\n(epoch 8)\n(eval "macro-failed")\n(epoch 9)\n(eval "macro-failures")\n' > "$MACRO_FILE"
|
||||
MACRO_OUT=$(timeout 60 "$SX_SERVER" < "$MACRO_FILE" 2>/dev/null)
|
||||
rm -f "$MACRO_FILE"
|
||||
MACRO_PASSED=$(echo "$MACRO_OUT" | grep -A1 "^(ok-len 7 " | tail -1 || true)
|
||||
MACRO_FAILED=$(echo "$MACRO_OUT" | grep -A1 "^(ok-len 8 " | tail -1 || true)
|
||||
[ -z "$MACRO_PASSED" ] && MACRO_PASSED=0; [ -z "$MACRO_FAILED" ] && MACRO_FAILED=0
|
||||
if [ "$MACRO_FAILED" = "0" ] && [ "$MACRO_PASSED" -gt 0 ] 2>/dev/null; then
|
||||
PASS=$((PASS + MACRO_PASSED))
|
||||
[ "$VERBOSE" = "-v" ] && echo " ok Phase 5 macros+LOOP ($MACRO_PASSED)"
|
||||
else
|
||||
FAIL=$((FAIL + 1))
|
||||
ERRORS+=" FAIL [Phase 5 macros+LOOP] (${MACRO_PASSED} passed, ${MACRO_FAILED} failed)
|
||||
"
|
||||
fi
|
||||
|
||||
TOTAL=$((PASS+FAIL))
|
||||
if [ $FAIL -eq 0 ]; then
|
||||
echo "ok $PASS/$TOTAL lib/common-lisp tests passed"
|
||||
|
||||
334
lib/common-lisp/tests/clos.sx
Normal file
334
lib/common-lisp/tests/clos.sx
Normal file
@@ -0,0 +1,334 @@
|
||||
;; lib/common-lisp/tests/clos.sx — CLOS test suite
|
||||
;;
|
||||
;; Loaded after: spec/stdlib.sx, lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
assert-equal
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
(define
|
||||
assert-true
|
||||
(fn
|
||||
(label got)
|
||||
(if
|
||||
got
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str "FAIL [" label "]: expected true, got " (inspect got)))))))))
|
||||
|
||||
(define
|
||||
assert-nil
|
||||
(fn
|
||||
(label got)
|
||||
(if
|
||||
(nil? got)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list (str "FAIL [" label "]: expected nil, got " (inspect got)))))))))
|
||||
|
||||
;; ── 1. class-of for built-in types ────────────────────────────────────────
|
||||
|
||||
(assert-equal "class-of integer" (clos-class-of 42) "integer")
|
||||
(assert-equal "class-of float" (clos-class-of 3.14) "float")
|
||||
(assert-equal "class-of string" (clos-class-of "hi") "string")
|
||||
(assert-equal "class-of nil" (clos-class-of nil) "null")
|
||||
(assert-equal "class-of list" (clos-class-of (list 1)) "cons")
|
||||
(assert-equal "class-of empty" (clos-class-of (list)) "null")
|
||||
|
||||
;; ── 2. subclass-of? ───────────────────────────────────────────────────────
|
||||
|
||||
(assert-true "integer subclass-of t" (clos-subclass-of? "integer" "t"))
|
||||
(assert-true "float subclass-of t" (clos-subclass-of? "float" "t"))
|
||||
(assert-true "t subclass-of t" (clos-subclass-of? "t" "t"))
|
||||
(assert-equal
|
||||
"integer not subclass-of float"
|
||||
(clos-subclass-of? "integer" "float")
|
||||
false)
|
||||
|
||||
;; ── 3. defclass + make-instance ───────────────────────────────────────────
|
||||
|
||||
(clos-defclass "point" (list "t") (list {:initform 0 :initarg ":x" :reader nil :writer nil :accessor "point-x" :name "x"} {:initform 0 :initarg ":y" :reader nil :writer nil :accessor "point-y" :name "y"}))
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
|
||||
(begin
|
||||
(assert-equal "make-instance slot x" (clos-slot-value p "x") 3)
|
||||
(assert-equal "make-instance slot y" (clos-slot-value p "y") 4)
|
||||
(assert-equal "class-of instance" (clos-class-of p) "point")
|
||||
(assert-true "instance-of? point" (clos-instance-of? p "point"))
|
||||
(assert-true "instance-of? t" (clos-instance-of? p "t"))
|
||||
(assert-equal "instance-of? string" (clos-instance-of? p "string") false)))
|
||||
|
||||
;; initform defaults
|
||||
(let
|
||||
((p0 (clos-make-instance "point")))
|
||||
(begin
|
||||
(assert-equal "initform default x=0" (clos-slot-value p0 "x") 0)
|
||||
(assert-equal "initform default y=0" (clos-slot-value p0 "y") 0)))
|
||||
|
||||
;; ── 4. slot-value / set-slot-value! ──────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 10 ":y" 20)))
|
||||
(begin
|
||||
(clos-set-slot-value! p "x" 99)
|
||||
(assert-equal "set-slot-value! x" (clos-slot-value p "x") 99)
|
||||
(assert-equal "slot-value y unchanged" (clos-slot-value p "y") 20)))
|
||||
|
||||
;; ── 5. slot-boundp ────────────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 5)))
|
||||
(begin
|
||||
(assert-true "slot-boundp x" (clos-slot-boundp p "x"))
|
||||
(assert-true "slot-boundp y (initform 0)" (clos-slot-boundp p "y"))))
|
||||
|
||||
;; ── 6. find-class ─────────────────────────────────────────────────────────
|
||||
|
||||
(assert-equal
|
||||
"find-class point"
|
||||
(get (clos-find-class "point") "name")
|
||||
"point")
|
||||
(assert-nil "find-class missing" (clos-find-class "no-such-class"))
|
||||
|
||||
;; ── 7. inheritance ────────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "colored-point" (list "point") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"}))
|
||||
|
||||
(let
|
||||
((cp (clos-make-instance "colored-point" ":x" 1 ":y" 2 ":color" "red")))
|
||||
(begin
|
||||
(assert-equal "inherited slot x" (clos-slot-value cp "x") 1)
|
||||
(assert-equal "inherited slot y" (clos-slot-value cp "y") 2)
|
||||
(assert-equal "own slot color" (clos-slot-value cp "color") "red")
|
||||
(assert-true
|
||||
"instance-of? colored-point"
|
||||
(clos-instance-of? cp "colored-point"))
|
||||
(assert-true "instance-of? point (parent)" (clos-instance-of? cp "point"))
|
||||
(assert-true "instance-of? t (root)" (clos-instance-of? cp "t"))))
|
||||
|
||||
;; ── 8. defgeneric + primary method ───────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "describe-obj" {})
|
||||
|
||||
(clos-defmethod
|
||||
"describe-obj"
|
||||
(list)
|
||||
(list "point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((p (first args)))
|
||||
(str "(" (clos-slot-value p "x") "," (clos-slot-value p "y") ")"))))
|
||||
|
||||
(clos-defmethod
|
||||
"describe-obj"
|
||||
(list)
|
||||
(list "t")
|
||||
(fn (args next-fn) (str "object:" (inspect (first args)))))
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
|
||||
(begin
|
||||
(assert-equal
|
||||
"primary method for point"
|
||||
(clos-call-generic "describe-obj" (list p))
|
||||
"(3,4)")
|
||||
(assert-equal
|
||||
"fallback t method"
|
||||
(clos-call-generic "describe-obj" (list 42))
|
||||
"object:42")))
|
||||
|
||||
;; ── 9. method inheritance + specificity ───────────────────────────────────
|
||||
|
||||
(clos-defmethod
|
||||
"describe-obj"
|
||||
(list)
|
||||
(list "colored-point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((cp (first args)))
|
||||
(str
|
||||
(clos-slot-value cp "color")
|
||||
"@("
|
||||
(clos-slot-value cp "x")
|
||||
","
|
||||
(clos-slot-value cp "y")
|
||||
")"))))
|
||||
|
||||
(let
|
||||
((cp (clos-make-instance "colored-point" ":x" 5 ":y" 6 ":color" "blue")))
|
||||
(assert-equal
|
||||
"most specific method wins"
|
||||
(clos-call-generic "describe-obj" (list cp))
|
||||
"blue@(5,6)"))
|
||||
|
||||
;; ── 10. :before / :after / :around qualifiers ─────────────────────────────
|
||||
|
||||
(clos-defgeneric "logged-action" {})
|
||||
|
||||
(clos-defmethod
|
||||
"logged-action"
|
||||
(list "before")
|
||||
(list "t")
|
||||
(fn (args next-fn) (set! action-log (append action-log (list "before")))))
|
||||
|
||||
(clos-defmethod
|
||||
"logged-action"
|
||||
(list)
|
||||
(list "t")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(set! action-log (append action-log (list "primary")))
|
||||
"result"))
|
||||
|
||||
(clos-defmethod
|
||||
"logged-action"
|
||||
(list "after")
|
||||
(list "t")
|
||||
(fn (args next-fn) (set! action-log (append action-log (list "after")))))
|
||||
|
||||
(define action-log (list))
|
||||
(clos-call-generic "logged-action" (list 1))
|
||||
(assert-equal
|
||||
":before/:after order"
|
||||
action-log
|
||||
(list "before" "primary" "after"))
|
||||
|
||||
;; :around
|
||||
(define around-log (list))
|
||||
|
||||
(clos-defgeneric "wrapped-action" {})
|
||||
|
||||
(clos-defmethod
|
||||
"wrapped-action"
|
||||
(list "around")
|
||||
(list "t")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(set! around-log (append around-log (list "around-enter")))
|
||||
(let
|
||||
((r (next-fn)))
|
||||
(set! around-log (append around-log (list "around-exit")))
|
||||
r)))
|
||||
|
||||
(clos-defmethod
|
||||
"wrapped-action"
|
||||
(list)
|
||||
(list "t")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(set! around-log (append around-log (list "primary")))
|
||||
42))
|
||||
|
||||
(let
|
||||
((r (clos-call-generic "wrapped-action" (list nil))))
|
||||
(begin
|
||||
(assert-equal ":around result" r 42)
|
||||
(assert-equal
|
||||
":around log"
|
||||
around-log
|
||||
(list "around-enter" "primary" "around-exit"))))
|
||||
|
||||
;; ── 11. call-next-method ─────────────────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "chain-test" {})
|
||||
|
||||
(clos-defmethod
|
||||
"chain-test"
|
||||
(list)
|
||||
(list "colored-point")
|
||||
(fn (args next-fn) (str "colored:" (clos-call-next-method next-fn))))
|
||||
|
||||
(clos-defmethod
|
||||
"chain-test"
|
||||
(list)
|
||||
(list "point")
|
||||
(fn (args next-fn) "point-base"))
|
||||
|
||||
(let
|
||||
((cp (clos-make-instance "colored-point" ":x" 0 ":y" 0 ":color" "green")))
|
||||
(assert-equal
|
||||
"call-next-method chains"
|
||||
(clos-call-generic "chain-test" (list cp))
|
||||
"colored:point-base"))
|
||||
|
||||
;; ── 12. accessor methods ──────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 7 ":y" 8)))
|
||||
(begin
|
||||
(assert-equal
|
||||
"accessor point-x"
|
||||
(clos-call-generic "point-x" (list p))
|
||||
7)
|
||||
(assert-equal
|
||||
"accessor point-y"
|
||||
(clos-call-generic "point-y" (list p))
|
||||
8)))
|
||||
|
||||
;; ── 13. with-slots ────────────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 3 ":y" 4)))
|
||||
(assert-equal
|
||||
"with-slots"
|
||||
(clos-with-slots p (list "x" "y") (fn (x y) (* x y)))
|
||||
12))
|
||||
|
||||
;; ── 14. change-class ─────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "special-point" (list "point") (list {:initform "" :initarg ":label" :reader nil :writer nil :accessor nil :name "label"}))
|
||||
|
||||
(let
|
||||
((p (clos-make-instance "point" ":x" 1 ":y" 2)))
|
||||
(begin
|
||||
(clos-change-class! p "special-point")
|
||||
(assert-equal
|
||||
"change-class updates class"
|
||||
(clos-class-of p)
|
||||
"special-point")))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(if
|
||||
(= failed 0)
|
||||
(print (str "ok " passed "/" (+ passed failed) " CLOS tests passed"))
|
||||
(begin
|
||||
(for-each (fn (f) (print f)) failures)
|
||||
(print
|
||||
(str "FAIL " passed "/" (+ passed failed) " passed, " failed " failed"))))
|
||||
@@ -401,6 +401,72 @@
|
||||
(cl-arithmetic-error-operands c)
|
||||
(list 1 0))))
|
||||
|
||||
|
||||
;; ── 15. *debugger-hook* ───────────────────────────────────────────────────
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
(let ((received nil))
|
||||
(begin
|
||||
(set! cl-debugger-hook
|
||||
(fn (c h)
|
||||
(set! received (cl-condition-message c))
|
||||
(cl-invoke-restart "escape")))
|
||||
(cl-restart-case
|
||||
(fn () (cl-error "debugger test"))
|
||||
(list "escape" (list) (fn () nil)))
|
||||
(set! cl-debugger-hook nil)
|
||||
(assert-equal "debugger-hook receives condition" received "debugger test")))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; ── 16. *break-on-signals* ────────────────────────────────────────────────
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
(let ((triggered false))
|
||||
(begin
|
||||
(set! cl-break-on-signals "error")
|
||||
(set! cl-debugger-hook
|
||||
(fn (c h)
|
||||
(set! triggered true)
|
||||
(cl-invoke-restart "abort")))
|
||||
(cl-restart-case
|
||||
(fn ()
|
||||
(cl-signal (cl-make-condition "simple-error" "format-control" "x")))
|
||||
(list "abort" (list) (fn () nil)))
|
||||
(set! cl-break-on-signals nil)
|
||||
(set! cl-debugger-hook nil)
|
||||
(assert-true "break-on-signals fires hook" triggered)))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; break-on-signals: non-matching type does NOT fire hook
|
||||
(let ((triggered false))
|
||||
(begin
|
||||
(set! cl-break-on-signals "error")
|
||||
(set! cl-debugger-hook
|
||||
(fn (c h) (set! triggered true) nil))
|
||||
(cl-handler-bind
|
||||
(list (list "warning" (fn (c) nil)))
|
||||
(fn ()
|
||||
(cl-signal (cl-make-condition "simple-warning" "format-control" "w"))))
|
||||
(set! cl-break-on-signals nil)
|
||||
(set! cl-debugger-hook nil)
|
||||
(assert-equal "break-on-signals: type mismatch not triggered" triggered false)))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; ── 17. cl-invoke-restart-interactively ──────────────────────────────────
|
||||
|
||||
(let ((result
|
||||
(cl-restart-case
|
||||
(fn () (cl-invoke-restart-interactively "use-default"))
|
||||
(list "use-default" (list) (fn () 99)))))
|
||||
(assert-equal "invoke-restart-interactively: returns restart value" result 99))
|
||||
|
||||
(reset-stacks!)
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(if
|
||||
|
||||
@@ -388,3 +388,79 @@
|
||||
(cl-test "unwind-protect: nested, inner cleanup first"
|
||||
(ev "(let ((n 0)) (unwind-protect (unwind-protect 1 (setq n (+ n 10))) (setq n (+ n 1))) n)")
|
||||
11)
|
||||
|
||||
;; ── VALUES / MULTIPLE-VALUE-BIND / NTH-VALUE ────────────────────
|
||||
|
||||
(cl-test "values: single returns plain"
|
||||
(ev "(values 42)")
|
||||
42)
|
||||
(cl-test "values: zero returns nil"
|
||||
(ev "(values)")
|
||||
nil)
|
||||
(cl-test "values: multi — primary via funcall"
|
||||
(ev "(car (list (values 1 2)))")
|
||||
1)
|
||||
(cl-test "multiple-value-bind: basic"
|
||||
(ev "(multiple-value-bind (a b) (values 1 2) (+ a b))")
|
||||
3)
|
||||
(cl-test "multiple-value-bind: extra vars get nil"
|
||||
(ev "(multiple-value-bind (a b c) (values 10 20) (list a b c))")
|
||||
(list 10 20 nil))
|
||||
(cl-test "multiple-value-bind: extra values ignored"
|
||||
(ev "(multiple-value-bind (a) (values 1 2 3) a)")
|
||||
1)
|
||||
(cl-test "multiple-value-bind: single value source"
|
||||
(ev "(multiple-value-bind (a b) 42 (list a b))")
|
||||
(list 42 nil))
|
||||
(cl-test "nth-value: 0"
|
||||
(ev "(nth-value 0 (values 10 20 30))")
|
||||
10)
|
||||
(cl-test "nth-value: 1"
|
||||
(ev "(nth-value 1 (values 10 20 30))")
|
||||
20)
|
||||
(cl-test "nth-value: out of range"
|
||||
(ev "(nth-value 5 (values 10 20))")
|
||||
nil)
|
||||
(cl-test "multiple-value-call: basic"
|
||||
(ev "(multiple-value-call #'+ (values 1 2) (values 3 4))")
|
||||
10)
|
||||
(cl-test "multiple-value-prog1: returns first"
|
||||
(ev "(multiple-value-prog1 1 2 3)")
|
||||
1)
|
||||
(cl-test "multiple-value-prog1: side effects run"
|
||||
(ev "(let ((x 0)) (multiple-value-prog1 99 (setq x 7)) x)")
|
||||
7)
|
||||
(cl-test "values: nil primary in if"
|
||||
(ev "(if (values nil t) 'yes 'no)")
|
||||
"NO")
|
||||
(cl-test "values: truthy primary in if"
|
||||
(ev "(if (values 42 nil) 'yes 'no)")
|
||||
"YES")
|
||||
|
||||
;; --- Dynamic variables ---
|
||||
(cl-test "defvar marks special"
|
||||
(do (ev "(defvar *dv* 10)")
|
||||
(cl-special? "*DV*"))
|
||||
true)
|
||||
(cl-test "defvar: let rebinds dynamically"
|
||||
(ev "(progn (defvar *x* 1) (defun get-x () *x*) (let ((*x* 99)) (get-x)))")
|
||||
99)
|
||||
(cl-test "defvar: binding restores after let"
|
||||
(ev "(progn (defvar *yrst* 5) (let ((*yrst* 42)) *yrst*) *yrst*)")
|
||||
5)
|
||||
(cl-test "defparameter marks special"
|
||||
(do (ev "(defparameter *dp* 0)")
|
||||
(cl-special? "*DP*"))
|
||||
true)
|
||||
(cl-test "defparameter: let rebinds dynamically"
|
||||
(ev "(progn (defparameter *z* 10) (defun get-z () *z*) (let ((*z* 77)) (get-z)))")
|
||||
77)
|
||||
(cl-test "defparameter: always assigns"
|
||||
(ev "(progn (defparameter *p* 1) (defparameter *p* 2) *p*)")
|
||||
2)
|
||||
(cl-test "dynamic binding: nested lets"
|
||||
(ev "(progn (defvar *n* 0) (let ((*n* 1)) (let ((*n* 2)) *n*)))")
|
||||
2)
|
||||
(cl-test "dynamic binding: restores across nesting"
|
||||
(ev "(progn (defvar *m* 10) (let ((*m* 20)) (let ((*m* 30)) nil)) *m*)")
|
||||
10)
|
||||
|
||||
204
lib/common-lisp/tests/macros.sx
Normal file
204
lib/common-lisp/tests/macros.sx
Normal file
@@ -0,0 +1,204 @@
|
||||
;; lib/common-lisp/tests/macros.sx — Phase 5: defmacro, gensym, LOOP tests
|
||||
;;
|
||||
;; Depends on: runtime.sx, eval.sx, loop.sx already loaded.
|
||||
;; Tests via (ev "...") using the CL evaluator.
|
||||
|
||||
(define ev (fn (src) (cl-eval-str src (cl-make-env))))
|
||||
(define evall (fn (src) (cl-eval-all-str src (cl-make-env))))
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
;; ── defmacro basics ──────────────────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"defmacro returns name"
|
||||
(ev "(defmacro my-or (a b) (list 'if a a b))")
|
||||
"MY-OR")
|
||||
|
||||
(check
|
||||
"defmacro expansion works"
|
||||
(ev "(progn (defmacro my-inc (x) (list '+ x 1)) (my-inc 5))")
|
||||
6)
|
||||
|
||||
(check
|
||||
"defmacro with &rest"
|
||||
(ev "(progn (defmacro my-list (&rest xs) (cons 'list xs)) (my-list 1 2 3))")
|
||||
(list 1 2 3))
|
||||
|
||||
(check
|
||||
"nested macro expansion"
|
||||
(ev "(progn (defmacro sq (x) (list '* x x)) (sq 7))")
|
||||
49)
|
||||
|
||||
(check
|
||||
"macro in conditional"
|
||||
(ev
|
||||
"(progn (defmacro my-when (c &rest body) (list 'if c (cons 'progn body) nil)) (my-when t 10 20))")
|
||||
20)
|
||||
|
||||
(check
|
||||
"macro returns nil branch"
|
||||
(ev
|
||||
"(progn (defmacro my-when (c &rest body) (list 'if c (cons 'progn body) nil)) (my-when nil 42))")
|
||||
nil)
|
||||
|
||||
;; ── macroexpand ───────────────────────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"macroexpand returns expanded form"
|
||||
(ev "(progn (defmacro double (x) (list '+ x x)) (macroexpand '(double 5)))")
|
||||
(list "+" 5 5))
|
||||
|
||||
;; ── gensym ────────────────────────────────────────────────────────────────────
|
||||
|
||||
(check "gensym returns string" (ev "(stringp (gensym))") true)
|
||||
|
||||
(check
|
||||
"gensym prefix"
|
||||
(ev "(let ((g (gensym \"MY\"))) (not (= g nil)))")
|
||||
true)
|
||||
|
||||
(check "gensyms are unique" (ev "(not (= (gensym) (gensym)))") true)
|
||||
|
||||
;; ── swap! macro with gensym ───────────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"swap! macro"
|
||||
(evall
|
||||
"(defmacro swap! (a b) (let ((tmp (gensym))) (list 'let (list (list tmp a)) (list 'setq a b) (list 'setq b tmp)))) (defvar *a* 10) (defvar *b* 20) (swap! *a* *b*) (list *a* *b*)")
|
||||
(list 20 10))
|
||||
|
||||
;; ── LOOP: basic repeat and collect ────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"loop repeat collect"
|
||||
(ev "(loop repeat 3 collect 99)")
|
||||
(list 99 99 99))
|
||||
|
||||
(check
|
||||
"loop for-in collect"
|
||||
(ev "(loop for x in '(1 2 3) collect (* x x))")
|
||||
(list 1 4 9))
|
||||
|
||||
(check
|
||||
"loop for-from-to collect"
|
||||
(ev "(loop for i from 1 to 5 collect i)")
|
||||
(list 1 2 3 4 5))
|
||||
|
||||
(check
|
||||
"loop for-from-below collect"
|
||||
(ev "(loop for i from 0 below 4 collect i)")
|
||||
(list 0 1 2 3))
|
||||
|
||||
(check
|
||||
"loop for-downto collect"
|
||||
(ev "(loop for i from 5 downto 1 collect i)")
|
||||
(list 5 4 3 2 1))
|
||||
|
||||
(check
|
||||
"loop for-by collect"
|
||||
(ev "(loop for i from 0 to 10 by 2 collect i)")
|
||||
(list 0 2 4 6 8 10))
|
||||
|
||||
;; ── LOOP: sum, count, maximize, minimize ─────────────────────────────────────
|
||||
|
||||
(check "loop sum" (ev "(loop for i from 1 to 5 sum i)") 15)
|
||||
|
||||
(check
|
||||
"loop count"
|
||||
(ev "(loop for x in '(1 2 3 4 5) count (> x 3))")
|
||||
2)
|
||||
|
||||
(check
|
||||
"loop maximize"
|
||||
(ev "(loop for x in '(3 1 4 1 5 9 2 6) maximize x)")
|
||||
9)
|
||||
|
||||
(check
|
||||
"loop minimize"
|
||||
(ev "(loop for x in '(3 1 4 1 5 9 2 6) minimize x)")
|
||||
1)
|
||||
|
||||
;; ── LOOP: while and until ─────────────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"loop while"
|
||||
(ev "(loop for i from 1 to 10 while (< i 5) collect i)")
|
||||
(list 1 2 3 4))
|
||||
|
||||
(check
|
||||
"loop until"
|
||||
(ev "(loop for i from 1 to 10 until (= i 5) collect i)")
|
||||
(list 1 2 3 4))
|
||||
|
||||
;; ── LOOP: when / unless ───────────────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"loop when filter"
|
||||
(ev "(loop for i from 0 below 8 when (evenp i) collect i)")
|
||||
(list 0 2 4 6))
|
||||
|
||||
(check
|
||||
"loop unless filter"
|
||||
(ev "(loop for i from 0 below 8 unless (evenp i) collect i)")
|
||||
(list 1 3 5 7))
|
||||
|
||||
;; ── LOOP: append ─────────────────────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"loop append"
|
||||
(ev "(loop for x in '((1 2) (3 4) (5 6)) append x)")
|
||||
(list 1 2 3 4 5 6))
|
||||
|
||||
;; ── LOOP: always, never, thereis ─────────────────────────────────────────────
|
||||
|
||||
(check
|
||||
"loop always true"
|
||||
(ev "(loop for x in '(2 4 6) always (evenp x))")
|
||||
true)
|
||||
|
||||
(check
|
||||
"loop always false"
|
||||
(ev "(loop for x in '(2 3 6) always (evenp x))")
|
||||
false)
|
||||
|
||||
(check "loop never" (ev "(loop for x in '(1 3 5) never (evenp x))") true)
|
||||
|
||||
(check "loop thereis" (ev "(loop for x in '(1 2 3) thereis (> x 2))") true)
|
||||
|
||||
;; ── LOOP: for = then (general iteration) ─────────────────────────────────────
|
||||
|
||||
(check
|
||||
"loop for = then doubling"
|
||||
(ev "(loop repeat 5 for x = 1 then (* x 2) collect x)")
|
||||
(list 1 2 4 8 16))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define macro-passed passed)
|
||||
(define macro-failed failed)
|
||||
(define macro-failures failures)
|
||||
291
lib/common-lisp/tests/programs/geometry.sx
Normal file
291
lib/common-lisp/tests/programs/geometry.sx
Normal file
@@ -0,0 +1,291 @@
|
||||
;; geometry.sx — Multiple dispatch with CLOS
|
||||
;;
|
||||
;; Demonstrates generic functions dispatching on combinations of
|
||||
;; geometric types: point, line, plane.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
|
||||
|
||||
;; ── geometric classes ──────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "geo-point" (list "t") (list {:initform 0 :initarg ":px" :reader nil :writer nil :accessor nil :name "px"} {:initform 0 :initarg ":py" :reader nil :writer nil :accessor nil :name "py"}))
|
||||
|
||||
(clos-defclass "geo-line" (list "t") (list {:initform nil :initarg ":p1" :reader nil :writer nil :accessor nil :name "p1"} {:initform nil :initarg ":p2" :reader nil :writer nil :accessor nil :name "p2"}))
|
||||
|
||||
(clos-defclass "geo-plane" (list "t") (list {:initform nil :initarg ":normal" :reader nil :writer nil :accessor nil :name "normal"} {:initform 0 :initarg ":d" :reader nil :writer nil :accessor nil :name "d"}))
|
||||
|
||||
;; ── helpers ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define geo-point-x (fn (p) (clos-slot-value p "px")))
|
||||
(define geo-point-y (fn (p) (clos-slot-value p "py")))
|
||||
|
||||
(define
|
||||
geo-make-point
|
||||
(fn (x y) (clos-make-instance "geo-point" ":px" x ":py" y)))
|
||||
|
||||
(define
|
||||
geo-make-line
|
||||
(fn (p1 p2) (clos-make-instance "geo-line" ":p1" p1 ":p2" p2)))
|
||||
|
||||
(define
|
||||
geo-make-plane
|
||||
(fn
|
||||
(nx ny d)
|
||||
(clos-make-instance "geo-plane" ":normal" (list nx ny) ":d" d)))
|
||||
|
||||
;; ── describe generic ───────────────────────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "geo-describe" {})
|
||||
|
||||
(clos-defmethod
|
||||
"geo-describe"
|
||||
(list)
|
||||
(list "geo-point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((p (first args)))
|
||||
(str "P(" (geo-point-x p) "," (geo-point-y p) ")"))))
|
||||
|
||||
(clos-defmethod
|
||||
"geo-describe"
|
||||
(list)
|
||||
(list "geo-line")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((l (first args)))
|
||||
(str
|
||||
"L["
|
||||
(clos-call-generic "geo-describe" (list (clos-slot-value l "p1")))
|
||||
"-"
|
||||
(clos-call-generic "geo-describe" (list (clos-slot-value l "p2")))
|
||||
"]"))))
|
||||
|
||||
(clos-defmethod
|
||||
"geo-describe"
|
||||
(list)
|
||||
(list "geo-plane")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((pl (first args)))
|
||||
(str "Plane(d=" (clos-slot-value pl "d") ")"))))
|
||||
|
||||
;; ── intersect: multi-dispatch generic ─────────────────────────────────────
|
||||
;;
|
||||
;; Returns a string description of the intersection result.
|
||||
|
||||
(clos-defgeneric "intersect" {})
|
||||
|
||||
;; point ∩ point: same if coordinates match
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-point" "geo-point")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((p1 (first args)) (p2 (first (rest args))))
|
||||
(if
|
||||
(and
|
||||
(= (geo-point-x p1) (geo-point-x p2))
|
||||
(= (geo-point-y p1) (geo-point-y p2)))
|
||||
"point"
|
||||
"empty"))))
|
||||
|
||||
;; point ∩ line: check if point lies on line (cross product = 0)
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-point" "geo-line")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((pt (first args)) (ln (first (rest args))))
|
||||
(let
|
||||
((lp1 (clos-slot-value ln "p1")) (lp2 (clos-slot-value ln "p2")))
|
||||
(let
|
||||
((dx (- (geo-point-x lp2) (geo-point-x lp1)))
|
||||
(dy (- (geo-point-y lp2) (geo-point-y lp1)))
|
||||
(ex (- (geo-point-x pt) (geo-point-x lp1)))
|
||||
(ey (- (geo-point-y pt) (geo-point-y lp1))))
|
||||
(if (= (- (* dx ey) (* dy ex)) 0) "point" "empty"))))))
|
||||
|
||||
;; line ∩ line: parallel (same slope = empty) or point
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-line" "geo-line")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((l1 (first args)) (l2 (first (rest args))))
|
||||
(let
|
||||
((p1 (clos-slot-value l1 "p1"))
|
||||
(p2 (clos-slot-value l1 "p2"))
|
||||
(p3 (clos-slot-value l2 "p1"))
|
||||
(p4 (clos-slot-value l2 "p2")))
|
||||
(let
|
||||
((dx1 (- (geo-point-x p2) (geo-point-x p1)))
|
||||
(dy1 (- (geo-point-y p2) (geo-point-y p1)))
|
||||
(dx2 (- (geo-point-x p4) (geo-point-x p3)))
|
||||
(dy2 (- (geo-point-y p4) (geo-point-y p3))))
|
||||
(let
|
||||
((cross (- (* dx1 dy2) (* dy1 dx2))))
|
||||
(if (= cross 0) "parallel" "point")))))))
|
||||
|
||||
;; line ∩ plane: general case = point (or parallel if line ⊥ normal)
|
||||
(clos-defmethod
|
||||
"intersect"
|
||||
(list)
|
||||
(list "geo-line" "geo-plane")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((ln (first args)) (pl (first (rest args))))
|
||||
(let
|
||||
((p1 (clos-slot-value ln "p1"))
|
||||
(p2 (clos-slot-value ln "p2"))
|
||||
(n (clos-slot-value pl "normal")))
|
||||
(let
|
||||
((dx (- (geo-point-x p2) (geo-point-x p1)))
|
||||
(dy (- (geo-point-y p2) (geo-point-y p1)))
|
||||
(nx (first n))
|
||||
(ny (first (rest n))))
|
||||
(let
|
||||
((dot (+ (* dx nx) (* dy ny))))
|
||||
(if (= dot 0) "parallel" "point")))))))
|
||||
|
||||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
;; describe
|
||||
(check
|
||||
"describe point"
|
||||
(clos-call-generic
|
||||
"geo-describe"
|
||||
(list (geo-make-point 3 4)))
|
||||
"P(3,4)")
|
||||
(check
|
||||
"describe line"
|
||||
(clos-call-generic
|
||||
"geo-describe"
|
||||
(list
|
||||
(geo-make-line
|
||||
(geo-make-point 0 0)
|
||||
(geo-make-point 1 1))))
|
||||
"L[P(0,0)-P(1,1)]")
|
||||
(check
|
||||
"describe plane"
|
||||
(clos-call-generic
|
||||
"geo-describe"
|
||||
(list (geo-make-plane 0 1 5)))
|
||||
"Plane(d=5)")
|
||||
|
||||
;; intersect point×point
|
||||
(check
|
||||
"P∩P same"
|
||||
(clos-call-generic
|
||||
"intersect"
|
||||
(list
|
||||
(geo-make-point 2 3)
|
||||
(geo-make-point 2 3)))
|
||||
"point")
|
||||
(check
|
||||
"P∩P diff"
|
||||
(clos-call-generic
|
||||
"intersect"
|
||||
(list
|
||||
(geo-make-point 1 2)
|
||||
(geo-make-point 3 4)))
|
||||
"empty")
|
||||
|
||||
;; intersect point×line
|
||||
(let
|
||||
((origin (geo-make-point 0 0))
|
||||
(p10 (geo-make-point 10 0))
|
||||
(p55 (geo-make-point 5 5))
|
||||
(l-x
|
||||
(geo-make-line
|
||||
(geo-make-point 0 0)
|
||||
(geo-make-point 10 0))))
|
||||
(begin
|
||||
(check
|
||||
"P∩L on line"
|
||||
(clos-call-generic "intersect" (list p10 l-x))
|
||||
"point")
|
||||
(check
|
||||
"P∩L on x-axis"
|
||||
(clos-call-generic "intersect" (list origin l-x))
|
||||
"point")
|
||||
(check
|
||||
"P∩L off line"
|
||||
(clos-call-generic "intersect" (list p55 l-x))
|
||||
"empty")))
|
||||
|
||||
;; intersect line×line
|
||||
(let
|
||||
((horiz (geo-make-line (geo-make-point 0 0) (geo-make-point 10 0)))
|
||||
(vert
|
||||
(geo-make-line
|
||||
(geo-make-point 5 -5)
|
||||
(geo-make-point 5 5)))
|
||||
(horiz2
|
||||
(geo-make-line
|
||||
(geo-make-point 0 3)
|
||||
(geo-make-point 10 3))))
|
||||
(begin
|
||||
(check
|
||||
"L∩L crossing"
|
||||
(clos-call-generic "intersect" (list horiz vert))
|
||||
"point")
|
||||
(check
|
||||
"L∩L parallel"
|
||||
(clos-call-generic "intersect" (list horiz horiz2))
|
||||
"parallel")))
|
||||
|
||||
;; intersect line×plane
|
||||
(let
|
||||
((diag (geo-make-line (geo-make-point 0 0) (geo-make-point 1 1)))
|
||||
(vert-plane (geo-make-plane 1 0 5))
|
||||
(diag-plane (geo-make-plane -1 1 0)))
|
||||
(begin
|
||||
(check
|
||||
"L∩Plane cross"
|
||||
(clos-call-generic "intersect" (list diag vert-plane))
|
||||
"point")
|
||||
(check
|
||||
"L∩Plane parallel"
|
||||
(clos-call-generic "intersect" (list diag diag-plane))
|
||||
"parallel")))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define geo-passed passed)
|
||||
(define geo-failed failed)
|
||||
(define geo-failures failures)
|
||||
196
lib/common-lisp/tests/programs/interactive-debugger.sx
Normal file
196
lib/common-lisp/tests/programs/interactive-debugger.sx
Normal file
@@ -0,0 +1,196 @@
|
||||
;; interactive-debugger.sx — Condition debugger using *debugger-hook*
|
||||
;;
|
||||
;; Demonstrates the classic CL debugger pattern:
|
||||
;; - *debugger-hook* is invoked when an unhandled error reaches the top level
|
||||
;; - The hook receives the condition and a reference to itself
|
||||
;; - It can offer restarts interactively (here simulated with a policy fn)
|
||||
;;
|
||||
;; In real CL the debugger reads from the terminal. Here we simulate
|
||||
;; the "user input" via a policy function passed in at call time.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/runtime.sx already loaded.
|
||||
|
||||
;; ── *debugger-hook* global ────────────────────────────────────────────────
|
||||
;;
|
||||
;; CL: when error is unhandled, invoke *debugger-hook* with (condition hook).
|
||||
;; A nil hook means use the system default (which we simulate as re-raise).
|
||||
|
||||
(define cl-debugger-hook nil)
|
||||
|
||||
;; ── invoke-debugger ────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Called when cl-error finds no handler. Tries cl-debugger-hook first;
|
||||
;; falls back to a simple error report.
|
||||
|
||||
(define
|
||||
cl-invoke-debugger
|
||||
(fn
|
||||
(c)
|
||||
(if
|
||||
(nil? cl-debugger-hook)
|
||||
(error (str "Debugger: " (cl-condition-message c)))
|
||||
(begin
|
||||
(let
|
||||
((hook cl-debugger-hook))
|
||||
(set! cl-debugger-hook nil)
|
||||
(let
|
||||
((result (hook c hook)))
|
||||
(set! cl-debugger-hook hook)
|
||||
result))))))
|
||||
|
||||
;; ── cl-error/debugger — error that routes through invoke-debugger ─────────
|
||||
|
||||
(define
|
||||
cl-error-with-debugger
|
||||
(fn
|
||||
(c &rest args)
|
||||
(let
|
||||
((obj (cond ((cl-condition? c) c) ((string? c) (cl-make-condition "simple-error" "format-control" c "format-arguments" args)) (:else (cl-make-condition "simple-error" "format-control" (str c))))))
|
||||
(cl-signal-obj obj cl-handler-stack)
|
||||
(cl-invoke-debugger obj))))
|
||||
|
||||
;; ── simulated debugger session ────────────────────────────────────────────
|
||||
;;
|
||||
;; A debugger hook takes (condition hook) and "reads" user commands.
|
||||
;; We simulate this with a policy function: (fn (c restarts) restart-name)
|
||||
;; that picks a restart given the condition and available restarts.
|
||||
|
||||
(define
|
||||
make-policy-debugger
|
||||
(fn
|
||||
(policy)
|
||||
(fn
|
||||
(c hook)
|
||||
(let
|
||||
((available (cl-compute-restarts)))
|
||||
(let
|
||||
((choice (policy c available)))
|
||||
(if
|
||||
(and choice (not (nil? (cl-find-restart choice))))
|
||||
(cl-invoke-restart choice)
|
||||
(error
|
||||
(str
|
||||
"Debugger: no restart chosen for: "
|
||||
(cl-condition-message c)))))))))
|
||||
|
||||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
(define
|
||||
reset-stacks!
|
||||
(fn
|
||||
()
|
||||
(set! cl-handler-stack (list))
|
||||
(set! cl-restart-stack (list))
|
||||
(set! cl-debugger-hook nil)))
|
||||
|
||||
;; Test 1: debugger hook receives condition
|
||||
(reset-stacks!)
|
||||
(let
|
||||
((received-msg ""))
|
||||
(begin
|
||||
(set!
|
||||
cl-debugger-hook
|
||||
(fn (c hook) (set! received-msg (cl-condition-message c)) nil))
|
||||
(cl-restart-case
|
||||
(fn () (cl-error-with-debugger "something broke"))
|
||||
(list "abort" (list) (fn () nil)))
|
||||
(check "debugger hook receives condition" received-msg "something broke")))
|
||||
|
||||
;; Test 2: policy-driven restart selection (use-zero)
|
||||
(reset-stacks!)
|
||||
(let
|
||||
((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "use-zero"))) (cl-restart-case (fn () (cl-error-with-debugger (cl-make-condition "division-by-zero")) 999) (list "use-zero" (list) (fn () 0))))))
|
||||
(check "policy debugger: use-zero restart" result 0))
|
||||
|
||||
;; Test 3: policy selects abort
|
||||
(reset-stacks!)
|
||||
(let
|
||||
((result (begin (set! cl-debugger-hook (make-policy-debugger (fn (c restarts) "abort"))) (cl-restart-case (fn () (cl-error-with-debugger "aborting error") 999) (list "abort" (list) (fn () "aborted"))))))
|
||||
(check "policy debugger: abort restart" result "aborted"))
|
||||
|
||||
;; Test 4: compute-restarts inside debugger hook
|
||||
(reset-stacks!)
|
||||
(let
|
||||
((seen-restarts (list)))
|
||||
(begin
|
||||
(set!
|
||||
cl-debugger-hook
|
||||
(fn
|
||||
(c hook)
|
||||
(set! seen-restarts (cl-compute-restarts))
|
||||
(cl-invoke-restart "continue")))
|
||||
(cl-restart-case
|
||||
(fn () (cl-error-with-debugger "test") 42)
|
||||
(list "continue" (list) (fn () "ok"))
|
||||
(list "abort" (list) (fn () "no")))
|
||||
(check
|
||||
"debugger: compute-restarts visible"
|
||||
(= (len seen-restarts) 2)
|
||||
true)))
|
||||
|
||||
;; Test 5: hook not invoked when handler catches first
|
||||
(reset-stacks!)
|
||||
(let
|
||||
((hook-called false)
|
||||
(result
|
||||
(begin
|
||||
(set! cl-debugger-hook (fn (c hook) (set! hook-called true) nil))
|
||||
(cl-handler-case
|
||||
(fn () (cl-error-with-debugger "handled"))
|
||||
(list "error" (fn (c) "handler-won"))))))
|
||||
(check "handler wins; hook not called" hook-called false)
|
||||
(check "handler result returned" result "handler-won"))
|
||||
|
||||
;; Test 6: debugger-hook nil after re-raise guard
|
||||
(reset-stacks!)
|
||||
(let
|
||||
((hook-calls 0))
|
||||
(begin
|
||||
(set!
|
||||
cl-debugger-hook
|
||||
(fn
|
||||
(c hook)
|
||||
(set! hook-calls (+ hook-calls 1))
|
||||
(if
|
||||
(> hook-calls 1)
|
||||
(error "infinite loop guard")
|
||||
(cl-invoke-restart "escape"))))
|
||||
(cl-restart-case
|
||||
(fn () (cl-error-with-debugger "once"))
|
||||
(list "escape" (list) (fn () nil)))
|
||||
(check
|
||||
"hook called exactly once (no infinite recursion)"
|
||||
hook-calls
|
||||
1)))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define debugger-passed passed)
|
||||
(define debugger-failed failed)
|
||||
(define debugger-failures failures)
|
||||
228
lib/common-lisp/tests/programs/mop-trace.sx
Normal file
228
lib/common-lisp/tests/programs/mop-trace.sx
Normal file
@@ -0,0 +1,228 @@
|
||||
;; mop-trace.sx — :before/:after method tracing with CLOS
|
||||
;;
|
||||
;; Classic CLOS pattern: instrument generic functions with :before and :after
|
||||
;; qualifiers to print call/return traces without modifying the primary method.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/runtime.sx, lib/common-lisp/clos.sx
|
||||
|
||||
;; ── trace log (mutable accumulator) ───────────────────────────────────────
|
||||
|
||||
(define trace-log (list))
|
||||
|
||||
(define
|
||||
trace-push
|
||||
(fn (msg) (set! trace-log (append trace-log (list msg)))))
|
||||
|
||||
(define trace-clear (fn () (set! trace-log (list))))
|
||||
|
||||
;; ── domain classes ─────────────────────────────────────────────────────────
|
||||
|
||||
(clos-defclass "shape" (list "t") (list {:initform "white" :initarg ":color" :reader nil :writer nil :accessor nil :name "color"}))
|
||||
|
||||
(clos-defclass "circle" (list "shape") (list {:initform 1 :initarg ":radius" :reader nil :writer nil :accessor nil :name "radius"}))
|
||||
|
||||
(clos-defclass "rect" (list "shape") (list {:initform 1 :initarg ":width" :reader nil :writer nil :accessor nil :name "width"} {:initform 1 :initarg ":height" :reader nil :writer nil :accessor nil :name "height"}))
|
||||
|
||||
;; ── generic function: area ─────────────────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "area" {})
|
||||
|
||||
;; primary methods
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list)
|
||||
(list "circle")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((c (first args)))
|
||||
(let ((r (clos-slot-value c "radius"))) (* r r)))))
|
||||
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list)
|
||||
(list "rect")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((r (first args)))
|
||||
(* (clos-slot-value r "width") (clos-slot-value r "height")))))
|
||||
|
||||
;; :before tracing
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list "before")
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(trace-push (str "BEFORE area(" (clos-class-of (first args)) ")"))))
|
||||
|
||||
;; :after tracing
|
||||
(clos-defmethod
|
||||
"area"
|
||||
(list "after")
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(trace-push (str "AFTER area(" (clos-class-of (first args)) ")"))))
|
||||
|
||||
;; ── generic function: describe-shape ──────────────────────────────────────
|
||||
|
||||
(clos-defgeneric "describe-shape" {})
|
||||
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list)
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((s (first args)))
|
||||
(str "shape[" (clos-slot-value s "color") "]"))))
|
||||
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list)
|
||||
(list "circle")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((c (first args)))
|
||||
(str
|
||||
"circle[r="
|
||||
(clos-slot-value c "radius")
|
||||
" "
|
||||
(clos-call-next-method next-fn)
|
||||
"]"))))
|
||||
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list)
|
||||
(list "rect")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(let
|
||||
((r (first args)))
|
||||
(str
|
||||
"rect["
|
||||
(clos-slot-value r "width")
|
||||
"x"
|
||||
(clos-slot-value r "height")
|
||||
" "
|
||||
(clos-call-next-method next-fn)
|
||||
"]"))))
|
||||
|
||||
;; :before on base shape (fires for all subclasses too)
|
||||
(clos-defmethod
|
||||
"describe-shape"
|
||||
(list "before")
|
||||
(list "shape")
|
||||
(fn
|
||||
(args next-fn)
|
||||
(trace-push
|
||||
(str "BEFORE describe-shape(" (clos-class-of (first args)) ")"))))
|
||||
|
||||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
;; ── area tests ────────────────────────────────────────────────────────────
|
||||
|
||||
;; circle area = r*r (no pi — integer arithmetic for predictability)
|
||||
(let
|
||||
((c (clos-make-instance "circle" ":radius" 5 ":color" "red")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check "circle area" (clos-call-generic "area" (list c)) 25)
|
||||
(check
|
||||
":before fired for circle"
|
||||
(= (first trace-log) "BEFORE area(circle)")
|
||||
true)
|
||||
(check
|
||||
":after fired for circle"
|
||||
(= (first (rest trace-log)) "AFTER area(circle)")
|
||||
true)
|
||||
(check "trace length 2" (len trace-log) 2)))
|
||||
|
||||
;; rect area = w*h
|
||||
(let
|
||||
((r (clos-make-instance "rect" ":width" 4 ":height" 6 ":color" "blue")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check "rect area" (clos-call-generic "area" (list r)) 24)
|
||||
(check
|
||||
":before fired for rect"
|
||||
(= (first trace-log) "BEFORE area(rect)")
|
||||
true)
|
||||
(check
|
||||
":after fired for rect"
|
||||
(= (first (rest trace-log)) "AFTER area(rect)")
|
||||
true)
|
||||
(check "trace length 2 (rect)" (len trace-log) 2)))
|
||||
|
||||
;; ── describe-shape tests ───────────────────────────────────────────────────
|
||||
|
||||
(let
|
||||
((c (clos-make-instance "circle" ":radius" 3 ":color" "green")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check
|
||||
"circle describe"
|
||||
(clos-call-generic "describe-shape" (list c))
|
||||
"circle[r=3 shape[green]]")
|
||||
(check
|
||||
":before fired for describe circle"
|
||||
(= (first trace-log) "BEFORE describe-shape(circle)")
|
||||
true)))
|
||||
|
||||
(let
|
||||
((r (clos-make-instance "rect" ":width" 2 ":height" 7 ":color" "black")))
|
||||
(do
|
||||
(trace-clear)
|
||||
(check
|
||||
"rect describe"
|
||||
(clos-call-generic "describe-shape" (list r))
|
||||
"rect[2x7 shape[black]]")
|
||||
(check
|
||||
":before fired for describe rect"
|
||||
(= (first trace-log) "BEFORE describe-shape(rect)")
|
||||
true)))
|
||||
|
||||
;; ── call-next-method: circle -> shape ─────────────────────────────────────
|
||||
|
||||
(let
|
||||
((c (clos-make-instance "circle" ":radius" 1 ":color" "purple")))
|
||||
(check
|
||||
"call-next-method result in describe"
|
||||
(clos-call-generic "describe-shape" (list c))
|
||||
"circle[r=1 shape[purple]]"))
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define mop-passed passed)
|
||||
(define mop-failed failed)
|
||||
(define mop-failures failures)
|
||||
163
lib/common-lisp/tests/programs/parse-recover.sx
Normal file
163
lib/common-lisp/tests/programs/parse-recover.sx
Normal file
@@ -0,0 +1,163 @@
|
||||
;; parse-recover.sx — Parser with skipped-token restart
|
||||
;;
|
||||
;; Classic CL pattern: a simple token parser that signals a condition
|
||||
;; when it encounters an unexpected token. The :skip-token restart
|
||||
;; allows the parser to continue past the offending token.
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/runtime.sx already loaded.
|
||||
|
||||
;; ── condition type ─────────────────────────────────────────────────────────
|
||||
|
||||
(cl-define-condition "parse-error" (list "error") (list "token" "position"))
|
||||
|
||||
;; ── simple token parser ────────────────────────────────────────────────────
|
||||
;;
|
||||
;; parse-numbers: given a list of tokens (strings), parse integers.
|
||||
;; Non-integer tokens signal parse-error with two restarts:
|
||||
;; skip-token — skip the bad token and continue
|
||||
;; use-zero — use 0 in place of the bad token
|
||||
|
||||
(define
|
||||
parse-numbers
|
||||
(fn
|
||||
(tokens)
|
||||
(define result (list))
|
||||
(define
|
||||
process
|
||||
(fn
|
||||
(toks)
|
||||
(if
|
||||
(empty? toks)
|
||||
result
|
||||
(let
|
||||
((tok (first toks)) (rest-toks (rest toks)))
|
||||
(let
|
||||
((n (string->number tok 10)))
|
||||
(if
|
||||
n
|
||||
(begin
|
||||
(set! result (append result (list n)))
|
||||
(process rest-toks))
|
||||
(cl-restart-case
|
||||
(fn
|
||||
()
|
||||
(cl-signal
|
||||
(cl-make-condition
|
||||
"parse-error"
|
||||
"token"
|
||||
tok
|
||||
"position"
|
||||
(len result)))
|
||||
(set! result (append result (list 0)))
|
||||
(process rest-toks))
|
||||
(list "skip-token" (list) (fn () (process rest-toks)))
|
||||
(list
|
||||
"use-zero"
|
||||
(list)
|
||||
(fn
|
||||
()
|
||||
(begin
|
||||
(set! result (append result (list 0)))
|
||||
(process rest-toks)))))))))))
|
||||
(process tokens)
|
||||
result))
|
||||
|
||||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
(define
|
||||
reset-stacks!
|
||||
(fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))
|
||||
|
||||
;; All valid tokens
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"all valid: 1 2 3"
|
||||
(cl-handler-bind
|
||||
(list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
|
||||
(fn () (parse-numbers (list "1" "2" "3"))))
|
||||
(list 1 2 3))
|
||||
|
||||
;; Skip bad token
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"skip bad token: 1 x 3 -> (1 3)"
|
||||
(cl-handler-bind
|
||||
(list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
|
||||
(fn () (parse-numbers (list "1" "x" "3"))))
|
||||
(list 1 3))
|
||||
|
||||
;; Use zero for bad token
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"use-zero for bad: 1 x 3 -> (1 0 3)"
|
||||
(cl-handler-bind
|
||||
(list (list "parse-error" (fn (c) (cl-invoke-restart "use-zero"))))
|
||||
(fn () (parse-numbers (list "1" "x" "3"))))
|
||||
(list 1 0 3))
|
||||
|
||||
;; Multiple bad tokens, all skipped
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"skip multiple bad: a 2 b 4 -> (2 4)"
|
||||
(cl-handler-bind
|
||||
(list (list "parse-error" (fn (c) (cl-invoke-restart "skip-token"))))
|
||||
(fn () (parse-numbers (list "a" "2" "b" "4"))))
|
||||
(list 2 4))
|
||||
|
||||
;; handler-case: abort on first bad token
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"handler-case: abort on first bad"
|
||||
(cl-handler-case
|
||||
(fn () (parse-numbers (list "1" "bad" "3")))
|
||||
(list
|
||||
"parse-error"
|
||||
(fn
|
||||
(c)
|
||||
(str
|
||||
"parse error at position "
|
||||
(cl-condition-slot c "position")
|
||||
": "
|
||||
(cl-condition-slot c "token")))))
|
||||
"parse error at position 1: bad")
|
||||
|
||||
;; Verify condition type hierarchy
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"parse-error isa error"
|
||||
(cl-condition-of-type?
|
||||
(cl-make-condition "parse-error" "token" "x" "position" 0)
|
||||
"error")
|
||||
true)
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define parse-passed passed)
|
||||
(define parse-failed failed)
|
||||
(define parse-failures failures)
|
||||
141
lib/common-lisp/tests/programs/restart-demo.sx
Normal file
141
lib/common-lisp/tests/programs/restart-demo.sx
Normal file
@@ -0,0 +1,141 @@
|
||||
;; restart-demo.sx — Classic CL condition system demo
|
||||
;;
|
||||
;; Demonstrates resumable exceptions via restarts.
|
||||
;; The `safe-divide` function signals a division-by-zero condition
|
||||
;; and offers two restarts:
|
||||
;; :use-zero — return 0 as the result
|
||||
;; :retry — call safe-divide again with a corrected divisor
|
||||
;;
|
||||
;; Depends on: lib/common-lisp/runtime.sx already loaded.
|
||||
|
||||
;; ── safe-divide ────────────────────────────────────────────────────────────
|
||||
;;
|
||||
;; Divides numerator by denominator.
|
||||
;; When denominator is 0, signals division-by-zero with two restarts.
|
||||
|
||||
(define
|
||||
safe-divide
|
||||
(fn
|
||||
(n d)
|
||||
(if
|
||||
(= d 0)
|
||||
(cl-restart-case
|
||||
(fn
|
||||
()
|
||||
(cl-signal
|
||||
(cl-make-condition
|
||||
"division-by-zero"
|
||||
"operation"
|
||||
"/"
|
||||
"operands"
|
||||
(list n d)))
|
||||
(error "division by zero — no restart invoked"))
|
||||
(list "use-zero" (list) (fn () 0))
|
||||
(list "retry" (list "d") (fn (d2) (safe-divide n d2))))
|
||||
(/ n d))))
|
||||
|
||||
;; ── tests ─────────────────────────────────────────────────────────────────
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
(define
|
||||
reset-stacks!
|
||||
(fn () (set! cl-handler-stack (list)) (set! cl-restart-stack (list))))
|
||||
|
||||
;; Normal division
|
||||
(reset-stacks!)
|
||||
(check "10 / 2 = 5" (safe-divide 10 2) 5)
|
||||
|
||||
;; Invoke use-zero restart
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"10 / 0 -> use-zero"
|
||||
(cl-handler-bind
|
||||
(list
|
||||
(list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero"))))
|
||||
(fn () (safe-divide 10 0)))
|
||||
0)
|
||||
|
||||
;; Invoke retry restart with a corrected denominator
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"10 / 0 -> retry with 2"
|
||||
(cl-handler-bind
|
||||
(list
|
||||
(list
|
||||
"division-by-zero"
|
||||
(fn (c) (cl-invoke-restart "retry" 2))))
|
||||
(fn () (safe-divide 10 0)))
|
||||
5)
|
||||
|
||||
;; Nested calls: outer handles the inner divide-by-zero
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"nested: 20 / (0->4) = 5"
|
||||
(cl-handler-bind
|
||||
(list
|
||||
(list
|
||||
"division-by-zero"
|
||||
(fn (c) (cl-invoke-restart "retry" 4))))
|
||||
(fn () (let ((r1 (safe-divide 20 0))) r1)))
|
||||
5)
|
||||
|
||||
;; handler-case — unwinding version
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"handler-case: catches division-by-zero"
|
||||
(cl-handler-case
|
||||
(fn () (safe-divide 9 0))
|
||||
(list "division-by-zero" (fn (c) "caught!")))
|
||||
"caught!")
|
||||
|
||||
;; Verify use-zero is idempotent (two uses)
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"two use-zero invocations"
|
||||
(cl-handler-bind
|
||||
(list
|
||||
(list "division-by-zero" (fn (c) (cl-invoke-restart "use-zero"))))
|
||||
(fn
|
||||
()
|
||||
(+
|
||||
(safe-divide 10 0)
|
||||
(safe-divide 3 0))))
|
||||
0)
|
||||
|
||||
;; No restart needed for normal division
|
||||
(reset-stacks!)
|
||||
(check
|
||||
"no restart needed for 8/4"
|
||||
(safe-divide 8 4)
|
||||
2)
|
||||
|
||||
;; ── summary ────────────────────────────────────────────────────────────────
|
||||
|
||||
(define demo-passed passed)
|
||||
(define demo-failed failed)
|
||||
(define demo-failures failures)
|
||||
285
lib/common-lisp/tests/stdlib.sx
Normal file
285
lib/common-lisp/tests/stdlib.sx
Normal file
@@ -0,0 +1,285 @@
|
||||
;; lib/common-lisp/tests/stdlib.sx — Phase 6: sequence, list, string functions
|
||||
|
||||
(define ev (fn (src) (cl-eval-str src (cl-make-env))))
|
||||
|
||||
(define passed 0)
|
||||
(define failed 0)
|
||||
(define failures (list))
|
||||
|
||||
(define
|
||||
check
|
||||
(fn
|
||||
(label got expected)
|
||||
(if
|
||||
(= got expected)
|
||||
(set! passed (+ passed 1))
|
||||
(begin
|
||||
(set! failed (+ failed 1))
|
||||
(set!
|
||||
failures
|
||||
(append
|
||||
failures
|
||||
(list
|
||||
(str
|
||||
"FAIL ["
|
||||
label
|
||||
"]: got="
|
||||
(inspect got)
|
||||
" expected="
|
||||
(inspect expected)))))))))
|
||||
|
||||
;; ── mapc ─────────────────────────────────────────────────────────
|
||||
|
||||
(check "mapc returns list"
|
||||
(ev "(mapc #'1+ '(1 2 3))")
|
||||
(list 1 2 3))
|
||||
|
||||
;; ── mapcan ───────────────────────────────────────────────────────
|
||||
|
||||
(check "mapcan basic"
|
||||
(ev "(mapcan (lambda (x) (list x (* x x))) '(1 2 3))")
|
||||
(list 1 1 2 4 3 9))
|
||||
|
||||
(check "mapcan filter-like"
|
||||
(ev "(mapcan (lambda (x) (if (evenp x) (list x) nil)) '(1 2 3 4 5 6))")
|
||||
(list 2 4 6))
|
||||
|
||||
;; ── reduce ───────────────────────────────────────────────────────
|
||||
|
||||
(check "reduce sum"
|
||||
(ev "(reduce #'+ '(1 2 3 4 5))")
|
||||
15)
|
||||
|
||||
(check "reduce with initial-value"
|
||||
(ev "(reduce #'+ '(1 2 3) :initial-value 10)")
|
||||
16)
|
||||
|
||||
(check "reduce max"
|
||||
(ev "(reduce (lambda (a b) (if (> a b) a b)) '(3 1 4 1 5 9 2 6))")
|
||||
9)
|
||||
|
||||
;; ── find ─────────────────────────────────────────────────────────
|
||||
|
||||
(check "find present"
|
||||
(ev "(find 3 '(1 2 3 4 5))")
|
||||
3)
|
||||
|
||||
(check "find absent"
|
||||
(ev "(find 9 '(1 2 3))")
|
||||
nil)
|
||||
|
||||
(check "find-if present"
|
||||
(ev "(find-if #'evenp '(1 3 4 7))")
|
||||
4)
|
||||
|
||||
(check "find-if absent"
|
||||
(ev "(find-if #'evenp '(1 3 5))")
|
||||
nil)
|
||||
|
||||
(check "find-if-not"
|
||||
(ev "(find-if-not #'evenp '(2 4 5 6))")
|
||||
5)
|
||||
|
||||
;; ── position ─────────────────────────────────────────────────────
|
||||
|
||||
(check "position found"
|
||||
(ev "(position 3 '(1 2 3 4 5))")
|
||||
2)
|
||||
|
||||
(check "position not found"
|
||||
(ev "(position 9 '(1 2 3))")
|
||||
nil)
|
||||
|
||||
(check "position-if"
|
||||
(ev "(position-if #'evenp '(1 3 4 8))")
|
||||
2)
|
||||
|
||||
;; ── count ────────────────────────────────────────────────────────
|
||||
|
||||
(check "count"
|
||||
(ev "(count 2 '(1 2 3 2 4 2))")
|
||||
3)
|
||||
|
||||
(check "count-if"
|
||||
(ev "(count-if #'evenp '(1 2 3 4 5 6))")
|
||||
3)
|
||||
|
||||
;; ── every / some / notany / notevery ─────────────────────────────
|
||||
|
||||
(check "every true"
|
||||
(ev "(every #'evenp '(2 4 6))")
|
||||
true)
|
||||
|
||||
(check "every false"
|
||||
(ev "(every #'evenp '(2 3 6))")
|
||||
nil)
|
||||
|
||||
(check "every empty"
|
||||
(ev "(every #'evenp '())")
|
||||
true)
|
||||
|
||||
(check "some truthy"
|
||||
(ev "(some #'evenp '(1 3 4))")
|
||||
true)
|
||||
|
||||
(check "some nil"
|
||||
(ev "(some #'evenp '(1 3 5))")
|
||||
nil)
|
||||
|
||||
(check "notany true"
|
||||
(ev "(notany #'evenp '(1 3 5))")
|
||||
true)
|
||||
|
||||
(check "notany false"
|
||||
(ev "(notany #'evenp '(1 2 5))")
|
||||
nil)
|
||||
|
||||
(check "notevery false"
|
||||
(ev "(notevery #'evenp '(2 4 6))")
|
||||
nil)
|
||||
|
||||
(check "notevery true"
|
||||
(ev "(notevery #'evenp '(2 3 6))")
|
||||
true)
|
||||
|
||||
;; ── remove ───────────────────────────────────────────────────────
|
||||
|
||||
(check "remove"
|
||||
(ev "(remove 3 '(1 2 3 4 3 5))")
|
||||
(list 1 2 4 5))
|
||||
|
||||
(check "remove-if"
|
||||
(ev "(remove-if #'evenp '(1 2 3 4 5 6))")
|
||||
(list 1 3 5))
|
||||
|
||||
(check "remove-if-not"
|
||||
(ev "(remove-if-not #'evenp '(1 2 3 4 5 6))")
|
||||
(list 2 4 6))
|
||||
|
||||
;; ── member ───────────────────────────────────────────────────────
|
||||
|
||||
(check "member found"
|
||||
(ev "(member 3 '(1 2 3 4 5))")
|
||||
(list 3 4 5))
|
||||
|
||||
(check "member not found"
|
||||
(ev "(member 9 '(1 2 3))")
|
||||
nil)
|
||||
|
||||
;; ── subst ────────────────────────────────────────────────────────
|
||||
|
||||
(check "subst flat"
|
||||
(ev "(subst 'b 'a '(a b c a))")
|
||||
(list "B" "B" "C" "B"))
|
||||
|
||||
(check "subst nested"
|
||||
(ev "(subst 99 1 '(1 (2 1) 3))")
|
||||
(list 99 (list 2 99) 3))
|
||||
|
||||
;; ── assoc ────────────────────────────────────────────────────────
|
||||
|
||||
(check "assoc found"
|
||||
(ev "(assoc 'b '((a 1) (b 2) (c 3)))")
|
||||
(list "B" 2))
|
||||
|
||||
(check "assoc not found"
|
||||
(ev "(assoc 'z '((a 1) (b 2)))")
|
||||
nil)
|
||||
|
||||
;; ── list ops ─────────────────────────────────────────────────────
|
||||
|
||||
(check "last"
|
||||
(ev "(last '(1 2 3 4))")
|
||||
(list 4))
|
||||
|
||||
(check "butlast"
|
||||
(ev "(butlast '(1 2 3 4))")
|
||||
(list 1 2 3))
|
||||
|
||||
(check "nthcdr"
|
||||
(ev "(nthcdr 2 '(a b c d))")
|
||||
(list "C" "D"))
|
||||
|
||||
(check "list*"
|
||||
(ev "(list* 1 2 '(3 4))")
|
||||
(list 1 2 3 4))
|
||||
|
||||
(check "cadr"
|
||||
(ev "(cadr '(1 2 3))")
|
||||
2)
|
||||
|
||||
(check "caddr"
|
||||
(ev "(caddr '(1 2 3))")
|
||||
3)
|
||||
|
||||
(check "cadddr"
|
||||
(ev "(cadddr '(1 2 3 4))")
|
||||
4)
|
||||
|
||||
(check "cddr"
|
||||
(ev "(cddr '(1 2 3 4))")
|
||||
(list 3 4))
|
||||
|
||||
;; ── subseq ───────────────────────────────────────────────────────
|
||||
|
||||
(check "subseq string"
|
||||
(ev "(subseq \"hello\" 1 3)")
|
||||
"el")
|
||||
|
||||
(check "subseq list"
|
||||
(ev "(subseq '(a b c d) 1 3)")
|
||||
(list "B" "C"))
|
||||
|
||||
(check "subseq no end"
|
||||
(ev "(subseq \"hello\" 2)")
|
||||
"llo")
|
||||
|
||||
;; ── FORMAT ─────────────────────────────────────────────────────────
|
||||
|
||||
(check "format ~A"
|
||||
(ev "(format nil \"hello ~A\" \"world\")")
|
||||
"hello world")
|
||||
|
||||
(check "format ~D"
|
||||
(ev "(format nil \"~D items\" 42)")
|
||||
"42 items")
|
||||
|
||||
(check "format two args"
|
||||
(ev "(format nil \"~A ~A\" 1 2)")
|
||||
"1 2")
|
||||
|
||||
(check "format ~A+~A=~A"
|
||||
(ev "(format nil \"~A + ~A = ~A\" 1 2 3)")
|
||||
"1 + 2 = 3")
|
||||
|
||||
(check "format iterate"
|
||||
(ev "(format nil \"~{~A~}\" (quote (1 2 3)))")
|
||||
"123")
|
||||
|
||||
(check "format iterate with space"
|
||||
(ev "(format nil \"(~{~A ~})\" (quote (1 2 3)))")
|
||||
"(1 2 3 )")
|
||||
|
||||
;; ── packages ─────────────────────────────────────────────────────
|
||||
|
||||
(check "defpackage returns name"
|
||||
(ev "(defpackage :my-pkg (:use :cl))")
|
||||
"MY-PKG")
|
||||
|
||||
(check "in-package"
|
||||
(ev "(progn (defpackage :test-pkg) (in-package :test-pkg) (package-name))")
|
||||
"TEST-PKG")
|
||||
|
||||
(check "package-qualified function"
|
||||
(ev "(cl:car (quote (1 2 3)))")
|
||||
1)
|
||||
|
||||
(check "package-qualified function 2"
|
||||
(ev "(cl:mapcar (function evenp) (quote (2 3 4)))")
|
||||
(list true nil true))
|
||||
|
||||
;; ── summary ──────────────────────────────────────────────────────
|
||||
|
||||
(define stdlib-passed passed)
|
||||
(define stdlib-failed failed)
|
||||
(define stdlib-failures failures)
|
||||
@@ -11,7 +11,7 @@ isolation: worktree
|
||||
|
||||
## Prompt
|
||||
|
||||
You are the sole background agent working `/root/rose-ash/plans/common-lisp-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
|
||||
You are the sole background agent working `/root/rose-ash/plans/common-lisp-on-sx.md`. Isolated worktree, forever, one commit per feature. Push to `origin/loops/common-lisp` after every commit.
|
||||
|
||||
## Restart baseline — check before iterating
|
||||
|
||||
@@ -42,7 +42,7 @@ Every iteration: implement → test → commit → tick `[ ]` → Progress log
|
||||
- **Shared-file issues** → plan's Blockers with minimal repro.
|
||||
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
|
||||
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
|
||||
- **Worktree:** commit locally. Never push. Never touch `main`.
|
||||
- **Worktree:** commit, then push to `origin/loops/common-lisp`. Never touch `main`.
|
||||
- **Commit granularity:** one feature per commit.
|
||||
- **Plan file:** update Progress log + tick boxes every commit.
|
||||
|
||||
|
||||
@@ -60,10 +60,10 @@ Core mapping:
|
||||
- [x] `block` + `return-from` via captured continuation
|
||||
- [x] `tagbody` + `go` via per-tag continuations
|
||||
- [x] `unwind-protect` cleanup frame
|
||||
- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
||||
- [x] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
|
||||
- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
||||
- [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
||||
- [x] 127 tests in `lib/common-lisp/tests/eval.sx`
|
||||
- [x] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
||||
- [x] 182 tests in `lib/common-lisp/tests/eval.sx`
|
||||
|
||||
### Phase 3 — conditions + restarts (THE SHOWCASE)
|
||||
- [x] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
|
||||
@@ -73,42 +73,42 @@ Core mapping:
|
||||
- [x] `restart-case`, `with-simple-restart`, `restart-bind`
|
||||
- [x] `find-restart`, `invoke-restart`, `compute-restarts`
|
||||
- [x] `with-condition-restarts` — associate restarts with a specific condition
|
||||
- [ ] `invoke-restart-interactively`, `*break-on-signals*`, `*debugger-hook*` (basic)
|
||||
- [ ] Classic programs in `lib/common-lisp/tests/programs/`:
|
||||
- [ ] `restart-demo.lisp` — division with `:use-zero` and `:retry` restarts
|
||||
- [ ] `parse-recover.lisp` — parser with skipped-token restart
|
||||
- [ ] `interactive-debugger.lisp` — ASCII REPL using `:debugger-hook`
|
||||
- [ ] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
||||
- [x] `invoke-restart-interactively`, `*break-on-signals*`, `*debugger-hook*` (basic)
|
||||
- [x] Classic programs in `lib/common-lisp/tests/programs/`:
|
||||
- [x] `restart-demo.sx` — division with `use-zero` and `retry` restarts (7 tests)
|
||||
- [x] `parse-recover.sx` — parser with skipped-token restart (6 tests)
|
||||
- [x] `interactive-debugger.sx` — policy-driven debugger hook, *debugger-hook* global (7 tests)
|
||||
- [x] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` (363 total tests)
|
||||
|
||||
### Phase 4 — CLOS
|
||||
- [ ] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
|
||||
- [ ] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
|
||||
- [ ] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
|
||||
- [ ] `defmethod` with `:before` / `:after` / `:around` qualifiers
|
||||
- [ ] `call-next-method` (continuation), `next-method-p`
|
||||
- [ ] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
|
||||
- [ ] Multiple dispatch — method specificity by argument-class precedence list
|
||||
- [ ] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
|
||||
- [ ] Classic programs:
|
||||
- [ ] `geometry.lisp` — `intersect` generic dispatching on (point line), (line line), (line plane)…
|
||||
- [ ] `mop-trace.lisp` — `:before` + `:after` printing call trace
|
||||
- [x] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
|
||||
- [x] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
|
||||
- [x] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
|
||||
- [x] `defmethod` with `:before` / `:after` / `:around` qualifiers
|
||||
- [x] `call-next-method` (continuation), `next-method-p`
|
||||
- [x] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
|
||||
- [x] Multiple dispatch — method specificity by argument-class precedence list
|
||||
- [x] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
|
||||
- [x] Classic programs:
|
||||
- [x] `geometry.sx` — `intersect` generic dispatching on (point line), (line line), (line plane) — 12 tests
|
||||
- [x] `mop-trace.sx` — `:before` + `:after` printing call trace — 13 tests
|
||||
|
||||
### Phase 5 — macros + LOOP + reader macros
|
||||
- [ ] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand`
|
||||
- [ ] `gensym`, `gentemp`
|
||||
- [ ] `set-macro-character`, `set-dispatch-macro-character`, `get-macro-character`
|
||||
- [ ] **The LOOP macro** — iteration drivers (`for … in/across/from/upto/downto/by`, `while`, `until`, `repeat`), accumulators (`collect`, `append`, `nconc`, `count`, `sum`, `maximize`, `minimize`), conditional clauses (`if`/`when`/`unless`/`else`), termination (`finally`/`thereis`/`always`/`never`), `named` blocks
|
||||
- [ ] LOOP test corpus: 30+ tests covering all clause types
|
||||
- [x] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand`
|
||||
- [x] `gensym`, `gentemp`
|
||||
- [x] `set-macro-character`, `set-dispatch-macro-character`, `get-macro-character`
|
||||
- [x] **The LOOP macro** — iteration drivers (`for … in/across/from/upto/downto/by`, `while`, `until`, `repeat`), accumulators (`collect`, `append`, `nconc`, `count`, `sum`, `maximize`, `minimize`), conditional clauses (`if`/`when`/`unless`/`else`), termination (`finally`/`thereis`/`always`/`never`), `named` blocks
|
||||
- [x] LOOP test corpus: 27 tests covering all clause types
|
||||
|
||||
### Phase 6 — packages + stdlib drive
|
||||
- [ ] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package`
|
||||
- [ ] Package qualification at the reader level — `cl:car`, `mypkg::internal`
|
||||
- [ ] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages
|
||||
- [ ] Sequence functions — `mapcar`, `mapc`, `mapcan`, `reduce`, `find`, `find-if`, `position`, `count`, `every`, `some`, `notany`, `notevery`, `remove`, `remove-if`, `subst`
|
||||
- [ ] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff`
|
||||
- [ ] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate`
|
||||
- [ ] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural)
|
||||
- [ ] Drive corpus to 200+ green
|
||||
- [x] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package`
|
||||
- [x] Package qualification at the reader level — `cl:car`, `mypkg::internal`
|
||||
- [x] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages
|
||||
- [x] Sequence functions — `mapcar`, `mapc`, `mapcan`, `reduce`, `find`, `find-if`, `position`, `count`, `every`, `some`, `notany`, `notevery`, `remove`, `remove-if`, `subst`
|
||||
- [x] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff`
|
||||
- [x] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate`
|
||||
- [x] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural)
|
||||
- [x] Drive corpus to 200+ green
|
||||
|
||||
## SX primitive baseline
|
||||
|
||||
@@ -124,7 +124,21 @@ data; format for string templating.
|
||||
|
||||
_Newest first._
|
||||
|
||||
- 2026-05-05: Phase 5 set-macro-character — cl-reader-macros + cl-dispatch-macros global dicts; SET-MACRO-CHARACTER/GET-MACRO-CHARACTER/SET-DISPATCH-MACRO-CHARACTER dispatch in eval.sx (stores fn, doesn't wire into reader — stubs sufficient to avoid errors). Phase 5 fully ticked. Phase 6 Drive corpus 200+ ticked (518 total, 54 stdlib). All roadmap items done.
|
||||
|
||||
- 2026-05-05: Phase 6 packages — defpackage/in-package/export/use-package/import/find-package/package-name; cl-packages dict, cl-current-package; cl-package-sep? strips pkg: prefix from symbols+functions; package-qualified calls (cl:car, cl:mapcar) work. 4 package tests added; 518 total tests, 0 failed.
|
||||
|
||||
- 2026-05-05: Phase 6 FORMAT — cl-fmt-a/cl-fmt-s/cl-fmt-find-close/cl-fmt-iterate/cl-fmt-loop in eval.sx; ~A/~S/~D/~F/~%/~&/~T/~P/~{...~}/~[...~]/~^/~~; also fixed substr(start,length) semantics throughout (SUBSEQ, cl-fmt-loop); 6 FORMAT tests added to stdlib.sx; 514 total tests, 0 failed.
|
||||
|
||||
- 2026-05-05: Phase 6 stdlib — sequence functions (mapc/mapcan/reduce/find/find-if/find-if-not/position/position-if/count/count-if/every/some/notany/notevery/remove/remove-if/remove-if-not/subst/member), list ops (assoc/rassoc/getf/last/butlast/nthcdr/copy-list/list*/caar/cadr/cdar/cddr/caddr/cadddr/pairlis), string ops (subseq/string/char/string-length/string</>), plus coerce/make-list/write-to-string; 44 tests in tests/stdlib.sx; Phase 6 sequence+list+string boxes ticked. Total: 508 tests, 0 failed.
|
||||
|
||||
- 2026-05-05: Phase 4 CLOS fully complete — `lib/common-lisp/clos.sx` (27 forms): clos-class-registry (8 built-in classes), defclass/make-instance/slot-value/slot-boundp/set-slot-value!/find-class/change-class, defgeneric/defmethod with :before/:after/:around, clos-call-generic (standard method combination: sort by specificity, fire befores, call primary chain, fire afters in reverse), call-next-method/next-method-p, with-slots, accessor installation; 41 tests in `tests/clos.sx`; classic programs `geometry.sx` (12 tests, multi-dispatch intersect on P/L/Plane) and `mop-trace.sx` (13 tests, :before/:after tracing). Dynamic variables in eval.sx: cl-apply-dyn saves/restores global bindings around let for specials (cl-mark-special!/cl-special?/cl-dyn-unbound). Key gotchas: qualifier strings are "before"/"after"/"around" (no colon); dict-set pure = assoc; dict->list = (map (fn (k) (list k (get d k))) (keys d)); clos-add-reader-method bootstrapped via set! after defmethod defined; test isolation: use unique var names to avoid *y* collision. 437 total tests, 0 failed.
|
||||
- 2026-05-05: Phase 3 fully complete — conformance.sh runner + scoreboard.json/scoreboard.md; 363 total tests across all suites (79 reader, 31 parser, 174 eval, 59 conditions, 7+6+7 classic programs).
|
||||
- 2026-05-05: Phase 3 complete — cl-debugger-hook/cl-invoke-debugger in runtime.sx (cl-error routes through hook), cl-break-on-signals (fires hook before handlers on type match), cl-invoke-restart-interactively (calls fn with no args); 4 new tests (147 total). Phase 3 all boxes ticked.
|
||||
- 2026-05-05: Phase 3 interactive-debugger.sx — cl-debugger-hook global, cl-invoke-debugger, cl-error-with-debugger, make-policy-debugger; 7 tests (143 total). Tests wired into test.sh program suite runner. Phase 3 condition core complete.
|
||||
- 2026-05-05: Phase 3 classic programs — `tests/programs/restart-demo.sx` (7 tests: safe-divide with use-zero + retry restarts) and `tests/programs/parse-recover.sx` (6 tests: token parser with skip-token + use-zero restarts, handler-case abort). Key gotcha: use `=` not `equal?` for list comparison in sx_server.
|
||||
- 2026-05-05: Phase 3 conditions + restarts — `cl-condition-classes` hierarchy (15 types), `cl-condition?`/`cl-condition-of-type?`, `cl-make-condition`, `cl-define-condition`, `cl-signal`/`cl-error`/`cl-warn`/`cl-cerror`, `cl-handler-bind` (non-unwinding), `cl-handler-case` (call/cc escape), `cl-restart-case`/`cl-with-simple-restart`, `cl-find-restart`/`cl-invoke-restart`/`cl-compute-restarts`, `cl-with-condition-restarts`; 55 new tests in `tests/conditions.sx` (123 total runtime tests). Key gotcha: `cl-condition-classes` must be captured at define-time via `let` in `cl-condition-of-type?` — free-variable lookup at call-time fails through env_merge parent chain.
|
||||
- 2026-05-05: multiple values — VALUES returns {:cl-type "mv"} wrapper for 2+ values; cl-mv-primary/cl-mv-vals helpers; MULTIPLE-VALUE-BIND binds vars to value list; MULTIPLE-VALUE-CALL/PROG1/NTH-VALUE; cl-mv-primary applied in IF/AND/OR/COND/cl-call-fn for single-value contexts; 15 new tests (174 eval, 346 total green).
|
||||
- 2026-05-05: unwind-protect — cl-eval-unwind-protect: eval protected form, run cleanup with for-each (discards results, preserves original sentinel), return original result; 8 new tests (159 eval, 331 total green).
|
||||
- 2026-05-05: tagbody + go — cl-go-tag? sentinel; cl-eval-tagbody runs body with tag-index map (keys str-normalised for integer tags); go-tag propagation in cl-eval-body alongside block-return; 11 new tests (151 eval, 323 total green).
|
||||
- 2026-05-05: block + return-from — sentinel propagation in cl-eval-body; cl-eval-block catches matching sentinels; BLOCK/RETURN-FROM/RETURN dispatch in cl-eval-list; 13 new tests (140 eval, 312 total green). Parser: CL strings → {:cl-type "string"} dicts.
|
||||
|
||||
Reference in New Issue
Block a user