lunar-object.lisp

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*