Skip to content

Instantly share code, notes, and snippets.

@g000001
Created May 4, 2023 12:45
Show Gist options
  • Save g000001/6a4f37023d6916ecbb531ffc129e2029 to your computer and use it in GitHub Desktop.
Save g000001/6a4f37023d6916ecbb531ffc129e2029 to your computer and use it in GitHub Desktop.
lunar-object.lisp
;;; -*- mode: Lisp; coding: utf-8 -*-
#||
Lunar
http://users.rcn.com/david-moon/Lunar/data.html#slots
The last slot in a datum can be a multi-slot whose value is a special kind of succession that is embedded in the datum rather than being a separate datum. This enables variable-length classes. The value of each member of a multi-slot must be a member of the slot's declared type.
The Consistent Slot Order Rule also states that only the last slot in the list can be a multi-slot. Thus no class that contains a multi-slot can have a subclass that adds more slots.
slot_name [ "[" length_expression "]" ]
http://users.rcn.com/david-moon/Lunar/definitions.html#class_definition
A slot is a multi-slot if a length_expression is specified. In this case the result of the length_expression is the length of the slot and the result of initial_value_expression is a sequence of initial values. That sequence must have at least as many members as the length of the slot. The type_expression is the type of the individual values. The result of reading a multi-slot is a succession of that type whose keys are consecutive integers starting at zero, similar to a list. Only the last slot can be a multi-slot.
||#
;(load "~/quicklisp/setup")
(ql:quickload '(1am))
(cl:defpackage lunar
#+(or lispworks ecl)
(:use cl clos 1am)
#+sbcl
(:use cl sb-mop 1am)
#+allegro
(:use cl clos 1am mop))
(cl:in-package lunar)
(setq *tests* nil)
(defclass lunar-class (standard-class)
((instance-vector-size :accessor %class-instance-vector-size)
(multi-slot :accessor %class-multi-slot)
(multi-slot-offset :accessor %class-multi-slot-offset)))
(defmethod validate-superclass ((c lunar-class) (s standard-class))
T)
(defclass lunar-object (standard-object)
()
(:metaclass lunar-class))
(test ?validate-superclass
(is (validate-superclass (find-class 'lunar-class) (find-class 'standard-class))))
(defun simple-vector-typespec-size (typespec)
(and (typep typespec '(cons * (cons (integer 0 *))))
(elt typespec 1)))
(test ?simple-vector-typespec-size
(is (= 42 (simple-vector-typespec-size '(simple-vector 42))))
(is (null (simple-vector-typespec-size 'simple-vector))))
(defmethod compute-slots ((class lunar-class))
(let* ((slots (call-next-method)))
(unless (null slots)
(let* ((last-slot (car (last slots)))
(last-slot-typespec (slot-definition-type last-slot)))
(when (typep last-slot-typespec '(cons * (cons (integer 1 *))))
(setf (%class-instance-vector-size class)
(+ (length slots)
-1
(simple-vector-typespec-size last-slot-typespec)))
(setf (%class-multi-slot class) last-slot)
(setf (%class-multi-slot-offset class)
(position last-slot slots)))))
slots))
(test ?compute-slots
(is (let ((class (eval `(defclass ,(gensym) (lunar-object)
()
(:metaclass lunar-class)))))
(finalize-inheritance class)
(null (compute-slots class))))
(is (let ((class (eval `(defclass ,(gensym) (lunar-object)
((x)
(y :type (simple-vector 42)))
(:metaclass lunar-class)))))
(finalize-inheritance class)
(compute-slots class)
(and (slot-boundp class 'multi-slot)
(slot-boundp class 'multi-slot-offset)
(%class-multi-slot class)
(%class-multi-slot-offset class)
(= 43 (%class-instance-vector-size class))))))
(defun class-has-multi-slot-p (class)
(and (slot-exists-p class 'multi-slot)
(slot-boundp class 'multi-slot)))
(test ?class-has-multi-slot-p
(is (let ((class (eval `(defclass ,(gensym) (lunar-object)
((x)
(y :type (simple-vector 42)))
(:metaclass lunar-class)))))
(finalize-inheritance class)
(compute-slots class)))
(is (let ((class (eval `(defclass ,(gensym) (lunar-object)
((x)
(y :type (simple-vector 42)))
(:metaclass lunar-class)))))
(finalize-inheritance class)
(compute-slots class)
(class-has-multi-slot-p class))))
(defmacro %make-unbound-marker ()
#+lispworks 'clos::*slot-unbound*
#+sbcl '(sb-kernel:make-unbound-marker)
#+allegro 'excl::*slot-unbound*
#+ecl '(SI:UNBOUND))
(defun %class-wrapper (class)
#+allegro (excl::class-wrapper class)
#+lispworks (clos::class-wrapper class)
#+sbcl (sb-pcl::class-wrapper class)
#+ccl (ccl::instance-class-wrapper class))
#+ecl
(defun %%instance-slots (inst)
(ffi:c-inline (inst) (:object) :object
"{
cl_object* slots = #0->instance.slots;
int len = #0->instance.length;
cl_object ans = si_make_pure_array(ECL_T, ecl_make_fixnum(len), ECL_NIL, ECL_NIL, ECL_NIL, ecl_make_fixnum(0));
for(int i = 0; i< len; i++) {
ecl_aset1(ans,i,slots[i]);
}
@(return 0)=ans;
}
"
:side-effects nil))
(defun %%set-instance-slots (inst vec &optional (offset 0))
(ffi:c-inline (inst vec offset) (:object :object :int) :object
"{
cl_object* slots = #0->instance.slots;
int len = #0->instance.length;
for(int i = #2; i< len; i++) {
slots[i] = ecl_aref1(#1, i-#2);
}
@(return 0)=#1;
}
"
:side-effects nil))
(defmacro %instance-vector (instance)
#+allegro `(excl::std-instance-slots ,instance)
#+lispworks `(clos::standard-instance-static-slots ,instance)
#+sbcl `(sb-pcl::std-instance-slots ,instance)
#+ccl `(ccl::instance.slots ,instance)
#+ecl `(%%instance-slots ,instance))
(test ?%instance-vector
(is (vectorp (%instance-vector (make-instance 'standard-class)))))
(defun %allocate-instance-slots-storage (size &optional (initial-value (%make-unbound-marker)))
#+lispworks (sys:alloc-g-vector$fixnum size initial-value)
#-lispworks (make-sequence 'vector size :initial-element initial-value))
(defun %ensure-class-finalized (class)
#+lispworks (clos::ensure-class-finalized class)
#+sbcl (sb-pcl:ensure-class-finalized class)
#+allegro (unless (class-finalized-p class) (finalize-inheritance class))
#+ecl (unless (class-finalized-p class) (finalize-inheritance class))
class)
(defmethod allocate-instance ((class lunar-class) &key &allow-other-keys)
(let ((class (%ensure-class-finalized class)))
(if (class-has-multi-slot-p class)
#-ecl
(let ((cw (%class-wrapper class))
(ss (%allocate-instance-slots-storage (%class-instance-vector-size class))))
#+lispworks
(sys:alloc-fix-instance cw ss)
#+sbcl
(let* ((instance (sb-pcl::%make-instance (1+ sb-vm:instance-data-start))))
(sb-kernel:%set-instance-layout instance cw)
(setf (sb-pcl::std-instance-slots instance) ss)
instance)
#+allegro
(excl::.primcall 'sys::new-standard-instance cw ss))
#+ecl
(let ((x (si::allocate-raw-instance nil class (%class-instance-vector-size class))))
(si::instance-sig-set x)
x)
(call-next-method))))
(test ?allocate-instance
(is (let ((multi (eval `(defclass ,(gensym) (lunar-object)
((x)
(y :type (simple-vector 42)))
(:metaclass lunar-class))))
(single (eval `(defclass ,(gensym) (lunar-object)
((x)
(y))
(:metaclass lunar-class)))))
(equal
'(43 2)
(list (length (%instance-vector (allocate-instance multi)))
(length (%instance-vector (allocate-instance single))))))))
(defun lunar-instance-access (instance index)
#-ecl (svref (%instance-vector instance) index)
#+ecl (si:instance-ref instance index))
(defun (setf lunar-instance-access) (value instance index)
#-ecl (setf (svref (%instance-vector instance) index) value)
#+ecl (setf (si:instance-ref instance index) value))
(test ?lunar-instance-access
(is (let* ((class (eval `(defclass ,(gensym) (lunar-object)
((x)
(y :type (simple-vector 42)))
(:metaclass lunar-class))))
(inst (make-instance class))
(sum 0))
(dotimes (idx (%class-instance-vector-size class))
(setf (lunar-instance-access inst idx) 1))
(dotimes (idx (%class-instance-vector-size class))
(incf sum (lunar-instance-access inst idx)))
(= 43 sum))))
#+lispworks
(defmethod slot-value-using-class ((class lunar-class)
obj
name)
(if (eq name (slot-definition-name (%class-multi-slot class)))
(subseq (%instance-vector obj)
(%class-multi-slot-offset class))
(call-next-method)))
#-lispworks
(defmethod slot-value-using-class ((class lunar-class)
obj
slotd)
(if (eq slotd (%class-multi-slot class))
(subseq (%instance-vector obj)
(%class-multi-slot-offset class))
(call-next-method)))
#+lispworks
(defmethod (setf slot-value-using-class) (vector (class lunar-class)
obj
name)
(if (eq name (slot-definition-name (%class-multi-slot class)))
(setf (subseq (%instance-vector obj)
(%class-multi-slot-offset class))
vector)
(call-next-method)))
#-lispworks
(defmethod (setf slot-value-using-class) (vector (class lunar-class)
obj
slotd)
(if (eq slotd (%class-multi-slot class))
#-ecl
(setf (subseq (%instance-vector obj)
(%class-multi-slot-offset class))
vector)
#+ecl
(%%set-instance-slots obj vector (%class-multi-slot-offset class))
(call-next-method)))
(test ?slot-value-using-class
(is (let* ((class (eval `(defclass ,(gensym) (lunar-object)
((x)
(y :type (simple-vector 42)))
(:metaclass lunar-class))))
(inst (make-instance class)))
(setf (slot-value inst 'y)
(make-sequence 'vector 42 :initial-element 1))
(= 42 (reduce #'+ (slot-value inst 'y))))))
;; deoptimized
#+lispworks
(defmethod shared-initialize ((instance lunar-object) slot-names &rest initargs)
(let ((class (class-of instance)))
(flet ((initialize-slot-from-initarg (instance slotd)
(let ((slot-initargs (slot-definition-initargs slotd))
(name (slot-definition-name slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (slot-value-using-class class instance name)
value)
(return t)))))
(initialize-slot-from-initfunction (instance slotd)
(let ((initfun (slot-definition-initfunction slotd))
(name (slot-definition-name slotd)))
(unless (not initfun)
(setf (slot-value-using-class class instance name)
(funcall initfun))))))
(dolist (slotd (class-slots class))
(unless (initialize-slot-from-initarg instance slotd)
(when (or (eq T slot-names)
(member (slot-definition-name slotd) slot-names))
(initialize-slot-from-initfunction instance slotd)))))
instance))
(test ?shared-initialize
(is (let* ((vec (make-sequence 'vector 42 :initial-element 1))
(checksum (reduce #'+ vec))
(by-initform
(eval `(defclass ,(gensym) (lunar-object)
((x :initform 0)
(y :type (simple-vector 42)
:initform ,vec))
(:metaclass lunar-class))))
(by-initarg
(eval `(defclass ,(gensym) (lunar-object)
((x :initform 0)
(y :type (simple-vector 42) :initarg y))
(:metaclass lunar-class)))))
(= checksum
(reduce #'+ (%instance-vector (make-instance by-initform)))
(reduce #'+ (%instance-vector (make-instance by-initarg 'y vec)))))))
(defmethod update-instance-for-different-class ((pre lunar-object) (cur standard-object)
&key &allow-other-keys)
(let ((cur-class (class-of cur))
(pre-class (class-of pre)))
(if (class-has-multi-slot-p pre-class)
(dolist (slotd (class-slots cur-class))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name))))))
(call-next-method)))
(defun multi-slottable-class-p (class)
(let ((slots (class-slots class)))
(if (null slots)
nil
(let* ((last-slot (car (last slots)))
(last-slot-typespec (slot-definition-type last-slot)))
(typep last-slot-typespec '(cons * (cons (integer 1 *))))))))
(defmethod update-instance-for-different-class ((pre standard-object) (cur lunar-object)
&key &allow-other-keys)
(let ((cur-class (class-of cur))
(pre-class (class-of pre)))
(if (multi-slottable-class-p pre-class)
(let ((slots (class-slots cur-class)))
#-ecl
(setf (%instance-vector cur)
(%allocate-instance-slots-storage (%class-instance-vector-size cur-class)))
#+ecl
(%%set-instance-slots cur
(%allocate-instance-slots-storage (%class-instance-vector-size cur-class)))
(dolist (slotd slots)
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name))))))
(call-next-method))))
(test ?change-class
(is (let* ((lunar (eval `(defclass ,(gensym) (lunar-object)
((x :initform 0)
(y :type (simple-vector 42)
:initform (make-sequence 'vector 42
:initial-element 1)))
(:metaclass lunar-class))))
(std (eval `(defclass ,(gensym) ()
((x)
(y)))))
(inst (make-instance lunar)))
(change-class inst std)
(and (eq std (class-of inst))
(= 2 (length (%instance-vector inst)))
(= 0 (slot-value inst 'x))
(= 42 (reduce #'+ (slot-value inst 'y))))))
#-ecl
(is (let* ((std (eval `(defclass ,(gensym) ()
((x :initform 0)
(y :type (simple-vector 42)
:initform (make-sequence 'vector 42
:initial-element 1)))
(:metaclass standard-class))))
(lunar (eval `(defclass ,(gensym) (lunar-object)
((x)
(y :type (simple-vector 42)))
(:metaclass lunar-class))))
(inst (make-instance std)))
(change-class inst lunar)
(and (eq lunar (class-of inst))
(= 43 (length (%instance-vector inst)))
(= 0 (slot-value inst 'x))
(slot-value inst 'y)
(= 42 (reduce #'+ (slot-value inst 'y)))))))
(run)
;;; *EOF*
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment