Compare commits
8 Commits
4cd8773766
...
loops/comm
| Author | SHA1 | Date | |
|---|---|---|---|
| 6d53d36495 | |||
| c311d4ebc4 | |||
| 99f8ccb30e | |||
| 4f9da65b3d | |||
| 025ddbebdd | |||
| f449f82fdd | |||
| 0e426cfea8 | |||
| 71c4b5e33f |
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))
|
(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-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-has-var? (fn (env name) (has-key? (get env "vars") name)))
|
||||||
(define cl-env-get-fn (fn (env name) (get (get env "fns") name)))
|
(define cl-env-get-fn (fn (env name) (get (get env "fns") name)))
|
||||||
@@ -177,6 +208,174 @@
|
|||||||
(let ((e5 (cl-bind-aux aux-specs e4)))
|
(let ((e5 (cl-bind-aux aux-specs e4)))
|
||||||
(cl-eval-body body e5)))))))))))))
|
(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 ────────────────────────────────────────────
|
;; ── built-in functions ────────────────────────────────────────────
|
||||||
|
|
||||||
(define cl-builtins
|
(define cl-builtins
|
||||||
@@ -202,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))
|
||||||
">=" (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))
|
"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))
|
"NUMBERP" (fn (args) (if (number? (nth args 0)) true nil))
|
||||||
"STRINGP" (fn (args) (if (string? (nth args 0)) true nil))
|
"STRINGP" (fn (args) (if (string? (nth args 0)) true nil))
|
||||||
"SYMBOLP" (fn (args) nil)
|
"SYMBOLP" (fn (args) nil)
|
||||||
"LISTP" (fn (args)
|
"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)
|
"CONSP" (fn (args)
|
||||||
(let ((x (nth args 0)))
|
(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)
|
"ATOM" (fn (args)
|
||||||
(let ((x (nth args 0)))
|
(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)
|
"FUNCTIONP" (fn (args)
|
||||||
(let ((x (nth args 0)))
|
(let ((x (nth args 0)))
|
||||||
(if (and (dict? x) (= (get x "cl-type") "function")) true nil)))
|
(if (and (dict? x) (= (get x "cl-type") "function")) true nil)))
|
||||||
@@ -276,7 +484,235 @@
|
|||||||
"CONCATENATE" (fn (args) (reduce (fn (a b) (str a b)) "" (rest args)))
|
"CONCATENATE" (fn (args) (reduce (fn (a b) (str a b)) "" (rest args)))
|
||||||
"EQ" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
"EQ" (fn (args) (if (= (nth args 0) (nth args 1)) true nil))
|
||||||
"EQL" (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
|
;; Register builtins in cl-global-env so (function #'name) resolves them
|
||||||
(for-each
|
(for-each
|
||||||
@@ -425,6 +861,56 @@
|
|||||||
(cl-eval-body (rest clause) env))
|
(cl-eval-body (rest clause) env))
|
||||||
(cl-eval-cond (rest clauses) 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*
|
;; Parallel LET and sequential LET*
|
||||||
(define cl-eval-let
|
(define cl-eval-let
|
||||||
(fn (args env sequential)
|
(fn (args env sequential)
|
||||||
@@ -432,17 +918,7 @@
|
|||||||
(body (rest args)))
|
(body (rest args)))
|
||||||
(if sequential
|
(if sequential
|
||||||
;; LET*: each binding sees previous ones
|
;; LET*: each binding sees previous ones
|
||||||
(let ((new-env env))
|
(cl-letstar-bind bindings env (fn (new-env) (cl-eval-body body new-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)))
|
|
||||||
;; LET: evaluate all inits in current env, then bind
|
;; LET: evaluate all inits in current env, then bind
|
||||||
(let ((pairs (map
|
(let ((pairs (map
|
||||||
(fn (b)
|
(fn (b)
|
||||||
@@ -450,11 +926,14 @@
|
|||||||
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
|
(init (if (and (list? b) (> (len b) 1)) (nth b 1) nil)))
|
||||||
{:name name :value (cl-eval init env)}))
|
{:name name :value (cl-eval init env)}))
|
||||||
bindings)))
|
bindings)))
|
||||||
(let ((new-env (reduce
|
(let ((spec-pairs (filter (fn (p) (cl-special? (get p "name"))) pairs))
|
||||||
(fn (e pair)
|
(lex-pairs (filter (fn (p) (not (cl-special? (get p "name")))) pairs)))
|
||||||
(cl-env-bind-var e (get pair "name") (get pair "value")))
|
(let ((new-env (reduce
|
||||||
env pairs)))
|
(fn (e pair)
|
||||||
(cl-eval-body body new-env)))))))
|
(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)
|
;; SETQ / SETF (simplified: mutate nearest scope or global)
|
||||||
(define cl-eval-setq
|
(define cl-eval-setq
|
||||||
@@ -563,11 +1042,14 @@
|
|||||||
(when (or always-assign
|
(when (or always-assign
|
||||||
(not (cl-env-has-var? cl-global-env name)))
|
(not (cl-env-has-var? cl-global-env name)))
|
||||||
(dict-set! (get cl-global-env "vars") name val))
|
(dict-set! (get cl-global-env "vars") name val))
|
||||||
|
(cl-mark-special! name)
|
||||||
name))))
|
name))))
|
||||||
|
|
||||||
;; Function call: evaluate name → look up fns, builtins; evaluate args
|
;; Function call: evaluate name → look up fns, builtins; evaluate args
|
||||||
(define cl-call-fn
|
(define cl-call-fn
|
||||||
(fn (name args env)
|
(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)))
|
(let ((evaled (map (fn (a) (cl-mv-primary (cl-eval a env))) args)))
|
||||||
(cond
|
(cond
|
||||||
;; FUNCALL: (funcall fn arg...)
|
;; FUNCALL: (funcall fn arg...)
|
||||||
@@ -586,17 +1068,26 @@
|
|||||||
(lst (nth evaled 1)))
|
(lst (nth evaled 1)))
|
||||||
(if (= lst nil) (list)
|
(if (= lst nil) (list)
|
||||||
(map (fn (x) (cl-apply fn-obj (list x))) lst))))
|
(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-env-has-fn? env name)
|
||||||
(cl-apply (cl-env-get-fn env name) evaled))
|
(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
|
;; Look up in global fns namespace
|
||||||
((cl-env-has-fn? cl-global-env name)
|
((cl-env-has-fn? cl-global-env name)
|
||||||
(cl-apply (cl-env-get-fn cl-global-env name) evaled))
|
(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)
|
((has-key? cl-builtins name)
|
||||||
((get cl-builtins name) evaled))
|
((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
|
(:else
|
||||||
{:cl-type "error" :message (str "Undefined function: " name)})))))
|
{:cl-type "error" :message (str "Undefined function: " name-raw)}))))))
|
||||||
|
|
||||||
;; ── main evaluator ────────────────────────────────────────────────
|
;; ── main evaluator ────────────────────────────────────────────────
|
||||||
|
|
||||||
@@ -614,18 +1105,134 @@
|
|||||||
(cond
|
(cond
|
||||||
((= ct "string") (get form "value")) ;; CL string → SX string
|
((= ct "string") (get form "value")) ;; CL string → SX string
|
||||||
(:else form)))) ;; keywords, floats, chars, etc.
|
(:else form)))) ;; keywords, floats, chars, etc.
|
||||||
;; Symbol reference (variable lookup)
|
;; Symbol reference (variable or symbol-macro lookup)
|
||||||
((string? form)
|
((string? form)
|
||||||
(cond
|
(let ((uform (upcase form)))
|
||||||
((cl-env-has-var? env form) (cl-env-get-var env form))
|
(let ((bare (let ((ps (cl-package-sep? uform)))
|
||||||
((cl-env-has-var? cl-global-env form)
|
(if ps (get ps "name") uform))))
|
||||||
(cl-env-get-var cl-global-env form))
|
(if (and (has-key? cl-symbol-macros bare)
|
||||||
(:else {:cl-type "error" :message (str "Undefined variable: " form)})))
|
(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: special forms or function call
|
||||||
((list? form) (cl-eval-list form env))
|
((list? form) (cl-eval-list form env))
|
||||||
;; Anything else self-evaluates
|
;; Anything else self-evaluates
|
||||||
(:else form))))
|
(: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
|
(define cl-eval-list
|
||||||
(fn (form env)
|
(fn (form env)
|
||||||
(if (= (len form) 0)
|
(if (= (len form) 0)
|
||||||
@@ -633,6 +1240,9 @@
|
|||||||
(let ((head (nth form 0))
|
(let ((head (nth form 0))
|
||||||
(args (rest form)))
|
(args (rest form)))
|
||||||
(cond
|
(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 "QUOTE") (nth args 0))
|
||||||
((= head "IF") (cl-eval-if args env))
|
((= head "IF") (cl-eval-if args env))
|
||||||
((= head "PROGN") (cl-eval-body args env))
|
((= head "PROGN") (cl-eval-body args env))
|
||||||
@@ -678,6 +1288,77 @@
|
|||||||
((= head "DEFCONSTANT") (cl-eval-defvar args env true))
|
((= head "DEFCONSTANT") (cl-eval-defvar args env true))
|
||||||
((= head "DECLAIM") nil)
|
((= head "DECLAIM") nil)
|
||||||
((= head "PROCLAIM") 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
|
;; Named function call
|
||||||
((string? head)
|
((string? head)
|
||||||
(cl-call-fn head args env))
|
(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))))
|
||||||
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**
|
||||||
@@ -366,6 +366,73 @@ run_program_suite \
|
|||||||
"lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
"lib/common-lisp/tests/programs/interactive-debugger.sx" \
|
||||||
"debugger-passed" "debugger-failed" "debugger-failures"
|
"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))
|
TOTAL=$((PASS+FAIL))
|
||||||
if [ $FAIL -eq 0 ]; then
|
if [ $FAIL -eq 0 ]; then
|
||||||
echo "ok $PASS/$TOTAL lib/common-lisp tests passed"
|
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"))))
|
||||||
@@ -436,3 +436,31 @@
|
|||||||
(cl-test "values: truthy primary in if"
|
(cl-test "values: truthy primary in if"
|
||||||
(ev "(if (values 42 nil) 'yes 'no)")
|
(ev "(if (values 42 nil) 'yes 'no)")
|
||||||
"YES")
|
"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)
|
||||||
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)
|
||||||
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
|
## 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
|
## 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.
|
- **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.
|
- **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.
|
- **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.
|
- **Commit granularity:** one feature per commit.
|
||||||
- **Plan file:** update Progress log + tick boxes every commit.
|
- **Plan file:** update Progress log + tick boxes every commit.
|
||||||
|
|
||||||
|
|||||||
@@ -62,8 +62,8 @@ Core mapping:
|
|||||||
- [x] `unwind-protect` cleanup frame
|
- [x] `unwind-protect` cleanup frame
|
||||||
- [x] `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)
|
- [x] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
|
||||||
- [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
- [x] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
|
||||||
- [x] 127 tests in `lib/common-lisp/tests/eval.sx`
|
- [x] 182 tests in `lib/common-lisp/tests/eval.sx`
|
||||||
|
|
||||||
### Phase 3 — conditions + restarts (THE SHOWCASE)
|
### 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`
|
- [x] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
|
||||||
@@ -78,37 +78,37 @@ Core mapping:
|
|||||||
- [x] `restart-demo.sx` — division with `use-zero` and `retry` restarts (7 tests)
|
- [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] `parse-recover.sx` — parser with skipped-token restart (6 tests)
|
||||||
- [x] `interactive-debugger.sx` — policy-driven debugger hook, *debugger-hook* global (7 tests)
|
- [x] `interactive-debugger.sx` — policy-driven debugger hook, *debugger-hook* global (7 tests)
|
||||||
- [ ] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
|
- [x] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md` (363 total tests)
|
||||||
|
|
||||||
### Phase 4 — CLOS
|
### Phase 4 — CLOS
|
||||||
- [ ] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
|
- [x] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
|
||||||
- [ ] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
|
- [x] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
|
||||||
- [ ] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
|
- [x] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
|
||||||
- [ ] `defmethod` with `:before` / `:after` / `:around` qualifiers
|
- [x] `defmethod` with `:before` / `:after` / `:around` qualifiers
|
||||||
- [ ] `call-next-method` (continuation), `next-method-p`
|
- [x] `call-next-method` (continuation), `next-method-p`
|
||||||
- [ ] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
|
- [x] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
|
||||||
- [ ] Multiple dispatch — method specificity by argument-class precedence list
|
- [x] Multiple dispatch — method specificity by argument-class precedence list
|
||||||
- [ ] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
|
- [x] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
|
||||||
- [ ] Classic programs:
|
- [x] Classic programs:
|
||||||
- [ ] `geometry.lisp` — `intersect` generic dispatching on (point line), (line line), (line plane)…
|
- [x] `geometry.sx` — `intersect` generic dispatching on (point line), (line line), (line plane) — 12 tests
|
||||||
- [ ] `mop-trace.lisp` — `:before` + `:after` printing call trace
|
- [x] `mop-trace.sx` — `:before` + `:after` printing call trace — 13 tests
|
||||||
|
|
||||||
### Phase 5 — macros + LOOP + reader macros
|
### Phase 5 — macros + LOOP + reader macros
|
||||||
- [ ] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand`
|
- [x] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand`
|
||||||
- [ ] `gensym`, `gentemp`
|
- [x] `gensym`, `gentemp`
|
||||||
- [ ] `set-macro-character`, `set-dispatch-macro-character`, `get-macro-character`
|
- [x] `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
|
- [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
|
||||||
- [ ] LOOP test corpus: 30+ tests covering all clause types
|
- [x] LOOP test corpus: 27 tests covering all clause types
|
||||||
|
|
||||||
### Phase 6 — packages + stdlib drive
|
### Phase 6 — packages + stdlib drive
|
||||||
- [ ] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package`
|
- [x] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package`
|
||||||
- [ ] Package qualification at the reader level — `cl:car`, `mypkg::internal`
|
- [x] Package qualification at the reader level — `cl:car`, `mypkg::internal`
|
||||||
- [ ] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages
|
- [x] `: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`
|
- [x] 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`
|
- [x] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff`
|
||||||
- [ ] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate`
|
- [x] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate`
|
||||||
- [ ] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural)
|
- [x] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural)
|
||||||
- [ ] Drive corpus to 200+ green
|
- [x] Drive corpus to 200+ green
|
||||||
|
|
||||||
## SX primitive baseline
|
## SX primitive baseline
|
||||||
|
|
||||||
@@ -124,6 +124,16 @@ data; format for string templating.
|
|||||||
|
|
||||||
_Newest first._
|
_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 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 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 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.
|
||||||
|
|||||||
Reference in New Issue
Block a user