giles
0e426cfea8
- lib/common-lisp/clos.sx (27 forms): class registry (8 built-in classes), defclass/make-instance/slot-value/slot-boundp/change-class, defgeneric/defmethod with :before/:after/:around, clos-call-generic (standard combination: sort by specificity, fire befores, call primary chain, fire afters reversed), call-next-method/next-method-p, with-slots, deferred accessor installation - lib/common-lisp/tests/clos.sx: 41 tests (class-of, subclass-of?, defclass, make-instance, slot ops, inheritance, method specificity, qualifiers, accessors, with-slots, change-class) - lib/common-lisp/tests/programs/geometry.sx: 12 tests — intersect generic dispatching on geo-point×geo-point, geo-point×geo-line, geo-line×geo-line, geo-line×geo-plane (multi-dispatch by class precedence) - lib/common-lisp/tests/programs/mop-trace.sx: 13 tests — :before/:after tracing on area and describe-shape generics, call-next-method in circle/rect - eval.sx: dynamic variables — cl-apply-dyn saves/restores global slot for specials; cl-mark-special!/cl-special?/cl-dyn-unbound; defvar now marks specials; let/let* rebind via cl-apply-dyn; 8 new tests (182 eval total) - conformance.sh + test.sh: Phase 4 suites wired in - plans/common-lisp-on-sx.md: Phase 4 + dynamic variable boxes ticked Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
500 lines
17 KiB
Plaintext
500 lines
17 KiB
Plaintext
;; 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)))) |