clos mop - customizing slot-value

#-mcclim
(cl:unless (cl:find-package :climi)
  (cl:defpackage :clim-internals
    (:use :cl :cl-user)
    (:nicknames :climi)))
(cl:in-package :clim-internals)

(eval-when (:compile-toplevel :load-toplevel :execute)
  #-:mcclim
  (progn 
  #-:bordeaux-threads
  (ql:quickload "bordeaux-threads")
  #-:closer-mop
  (ql:quickload "closer-mop")
  (unless (find-package :mop)
    (hcl:add-package-local-nickname :mop :c2mop))
  ))
  ;;; load dynamic-vars first
(defvar *gitd* #P"U:/git/mcclim/core/system/")

#-mcclim
(defun load-dvars ()
  (load (merge-pathnames "dynamic-vars" *gitd*)))
#-mcclim
(load-dvars)

;;;;;;;;;;;;;;;;;

(defclass c1 (class-with-dynamic-slots)
  ((slot1 :initarg :slot1 :dynamic nil  :accessor slot1)
   (slot2 :initarg :slot2 :dynamic t    :accessor slot2)
   (slot3 :initarg :slot3 :dynamic :tls :accessor slot3))
  (:metaclass class-with-dynamic-slots))

;;; variation
(defclass c2 (class-with-dynamic-slots)
 ;; all slots must have some :dynamic attribute
  ((slot1 :initarg :slot1 :dynamic nil  :accessor slot1)
   (slotb :initarg :slotb :dynamic :tls :accessor slotb))
  (:metaclass class-with-dynamic-slots))

#+()
(defclass c3 (c1)
  () ;; useless instance with no slots inherited from super
  (:metaclass class-with-dynamic-slots)
  )

;;;;;;;;;;;


#+() ; from dynamic-vars.lisp
(defmethod allocate-instance ((class class-with-dynamic-slots) &rest initargs)
  (let ((object (call-next-method)))
    (loop for slotd in (clos:class-slots class)
          when (typep slotd 'dynamic-effective-slot) do
            (setf (mop:standard-instance-access ; <<<< not external in clos
                   object
                   (clos:slot-definition-location slotd))
                  (apply #'make-dynamic-variable-using-key slotd initargs)))
    object))

(defmethod initialize-instance :around
  ((obj class-with-dynamic-slots) &rest initargs)
  (call-next-method obj) ; strip off initargs
  (let ((slots (clos:class-direct-slots (class-of obj))))
    (dolist (slot slots)
      (let ((type (dynamic-variable-type slot)) ; nil t :tls
            (slot-name (clos:slot-definition-name slot))
            (slot-initargs (clos:slot-definition-initargs slot)))
        (declare (ignore type))
        (dolist (arg slot-initargs)
          (let ((initarg (member arg initargs)))
            (when initarg
              (setf (slot-value obj slot-name)
                    (cadr initarg)))))))))

(defmethod clos:slot-value-using-class :around
  ((class class-with-dynamic-slots) object slot-name)
  (let* ((class (class-of object))
         (slotd (find slot-name (clos:class-slots class)
                      :key #'clos:slot-definition-name)))
    (cond ((typep slotd 'dynamic-effective-slot)
           (let ((dvar (clos::fast-standard-instance-access ; <<<
                        object (hcl:slot-definition-location slotd))))
             (assert (typep dvar 'dynamic-variable))
             (if (dynamic-variable-bound-p dvar)
               (dynamic-variable-value dvar)
               (slot-unbound class object slot-name))))
          (t (call-next-method)))))

(defmethod (setf clos:slot-value-using-class) :around
  (new-value
   (class class-with-dynamic-slots) object slot-name)
  (let* ((class (class-of object))
         (slotd (find slot-name (clos:class-slots class)
                      :key #'clos:slot-definition-name)))
    (cond ((typep slotd 'dynamic-effective-slot)
           (let ((dvar (clos::fast-standard-instance-access ; <<<
                        object (hcl:slot-definition-location slotd))))
             (setf (dynamic-variable-value dvar) new-value)))
          (t (call-next-method)))))
         
(defvar *object* (make-instance 'c1 :slot1 :foo :slot2 :bar))


#+()
(progn ; superceded by above
(defun dynamic-slot-value (object slot-name)
  (let* ((class (class-of object))
         (slotd (find slot-name (clos:class-slots class)
                      :key #'clos:slot-definition-name)))
    ;; above a.k.a. (slot-dvar* instance slot-name)
    (clos:slot-value-using-class class object slotd)))

(defun %set-dvar-value (object slot-name new-value)
  (let* ((class (class-of object))
         (slotd (find slot-name (clos:class-slots class)
                      :key #'clos:slot-definition-name)))
    (setf (clos:slot-value-using-class class object slotd) new-value)))

(defsetf dynamic-slot-value %set-dvar-value)
)

(defun test-dv0 ()
  ;; note cl:slot-value uses clos:slot-value-using-class
  ;; maybe try :around method there?
  (let* ((obj (make-instance 'c1 :slot1 :S1 :slot2 :s2))
         (dsvs2 (slot-value obj 'slot2))
         (accessor (slot2 obj))) ; returns DV
      (values dsvs2 accessor)))


(defun test-dv1 ()
  (let ((res (with-slots (slot1 slot2) *object*
               (setq slot1 :slot1 slot2 :slot2)
               (list slot1 slot2))))
    (assert (typep (slot2 *object*) 'dynamic-variable))
    res))

;;;;;;;;;
(defun test-dv2 () ;; OK
  (flet ((fcn ()
           (with-slots (slot1 slot2 slot3) *object*
               (setf slot1 :i slot2 :j slot3 :k)
               (print (list slot1 slot2 slot3)
                      #+lispworks
                      mp:*background-standard-output*))))
    #+lispworks
    (mp:process-run-function "test-dv2" () #'fcn)
    #-lispworks
    (bt:make-thread (fcn))
    (sleep .1)
    (assert (not (dynamic-variable-bound-p (slot3 *object*))))
    (with-slots (slot1 Slot2 slot3) *object*
      (declare (ignorable slot3))
      (print (list slot1 slot2)))
    (progn)
    (with-slots (slot1 slot2 slot3) *object*
      (declare (ignorable slot1 slot2 slot3))
      (list slot1 slot2 #+()slot3))
      ;; :I :J
      ))

(defun test-dv3 () ; OK
  (let* ((object (make-instance 'c1 :slot1 :I :slot2 :j  :slot3 :k))
         (class (class-of object)))
    (values
     (clos:slot-boundp-using-class class object 'slot1)
     (clos:slot-value-using-class  class object 'slot1)
     (setf (c2mop:slot-value-using-class class object 'slot1) :z)
     )
    ;; T :I :Z
    ))

(progn ; for test suite (from jd)
(defmacro with-normal-variable-classes (() &body body)
  `(dolist (*default-dynamic-variable-class*
            '(standard-dynamic-variable surrogate-dynamic-variable))
     ,@body))

(defmacro with-thread-local-variable-classes (() &body body)
  `(dolist (*default-thread-local-variable-class*
            '(standard-thread-local-variable surrogate-thread-local-variable))
     ,@body))

(defmacro with-dynamic-slot-variants (() &body body)
  `(with-normal-variable-classes ()
     (with-thread-local-variable-classes ()
       ,@body)))
)

;;; this references mcclim/test

(defun test-dv4 ()
  (macrolet ((is (&body body)
               `(progn
                  (format *debug-io* "Trying ~s... " ',body)
                  (assert (progn ,@body))
                  (format *debug-io* "OK~%"))))

   ;; from  METACLASS.2.BINDING 

   (with-dynamic-slot-variants ()
     (let ((o1 (make-instance 'c1 :slot1 :a :slot2 :b :slot3 :c))
           (o2 (make-instance 'c1 :slot1 :x :slot2 :y :slot3 :z)))
       ;(5am:signals error (slot-dlet (((o1 'slot1) 1)) nil))
       (progn ; <<<
         ;; OK with class-with-dynamic-slots as superclass
         ;; otherwise initialize-instance :after not called
        (slot-dlet (((o1 'slot2) :k))
          (is (eq :k (slot-value o1 'slot2)))
          (is (eq :y (slot-value o2 'slot2))))
        (slot-dlet (((o1 'slot3) :l))
          (is (eq :l (slot-value o1 'slot3)))
          (is (eq :z (slot-value o2 'slot3)))))))

   ;; from  metaclass.1.smoke - OK here

   (with-dynamic-slot-variants ()
     (let ((o1 (make-instance 'c1 :slot1 :a :slot2 :b :slot3 :c))
           (o2 (make-instance 'c1 :slot1 :x :slot2 :y :slot3 :z)))
       (with-slots (slot1 slot2 slot3) o1
         (is (eq :a slot1))
         (is (eq :b slot2))
         (is (eq :c slot3)))
       (with-slots (slot1 slot2 slot3) o2
         (is (eq :x slot1))
         (is (eq :y slot2))
         (is (eq :z slot3)))))

  ;; from test metaclass.2.binding - OK

  (with-dynamic-slot-variants () ;
    (let ((o1 (make-instance 'c1 :slot1 :a :slot2 :b :slot3 :c))
          (o2 (make-instance 'c1 :slot1 :x :slot2 :y :slot3 :z)))
      ;(5am:signals error (slot-dlet (((o1 'slot1) 1)) nil))
      (slot-dlet (((o1 'slot2) :k))
        (is (eq :k (slot-value o1 'slot2)))
        (is (eq :y (slot-value o2 'slot2))))
      (slot-dlet (((o1 'slot3) :l))
        (is (eq :l (slot-value o1 'slot3)))
        (is (eq :z (slot-value o2 'slot3))))))

;;; test metaclass.3.concurrent - OK
;;; a test of :accessor functions which uses compiled slot-value
;;; but here the accessors currently return the dynamic-variable
 (with-dynamic-slot-variants ()
    (macrolet ((slot1 (o)`(slot-value ,o 'slot1)) ; <<<
               (slot2 (o)`(slot-value ,o 'slot2)) ; <<<
               (slot3 (o)`(slot-value ,o 'slot3)) ; <<<
               )
    (let ((o1 (make-instance 'c1 :slot1 :a :slot2 :b :slot3 :c))
          (fail nil)
          (pass nil))
      (is (eq (slot1 o1) :a))
      (is (eq (slot2 o1) :b))
      (is (eq (slot3 o1) :c))
      
      (flet ((make-runner (values)
               (lambda ()
                 (setf (slot1 o1) :x
                       (slot2 o1) :y
                       (slot3 o1) :z)
                 (setf pass (and (eq (slot1 o1) :x)
                                 (eq (slot2 o1) :y)
                                 (eq (slot3 o1) :z)))
                 (slot-dlet (((o1 'slot2) :start))
                   (let ((value (slot2 o1)))
                     (unless (eq value :start)
                       (setf fail value)))
                   (loop repeat 1024 do
                     (setf (slot2 o1) (elt values (random (length values))))
                     (let ((value (slot2 o1)))
                       (unless (member value values)
                         (setf fail value))))))))
        (let ((threads (loop for i from 0 below 64
                             for v = (list (make-symbol (format nil "A~d" i))
                                           (make-symbol (format nil "B~d" i))
                                           (make-symbol (format nil "C~d" i)))
                             collect (bt:make-thread (make-runner v)))))
          (map nil #'bt:join-thread threads)
          (is (eq (slot1 o1) :x))
          (is (eq (slot2 o1) :y))
          (is (eq (slot3 o1) :c))       ; <- tls variable
          (is (not (null pass)))
          (is (null fail)))))))
  ))