clos mop
"Paul Werkowski (as pw at snoopy dot qozzy dot com)" <[email protected]>
| Newsgroups | gmane.lisp.lispworks.general |
|---|---|
| Message-ID | <[email protected]> |
I've known about the MOP ever since I bought Kickzales et al "The Art of the Metaobject Protocol" in 1992 or so, and even read some of it, but never had any opportunity to use it or even seen an example of its use. Now I have. At https://turtleware.eu/tag/mop.html there are three articles on Dynamic-Variables that make heavy use of the MOP. The author of these posts, Daniel Kochmanski, aka jackdaniels, aka jd, is also the most active contributor to the McCLIM project for the past few years and has recently tagged the repo with its second release ,"OSTRA", which has Dynamic-Variables integrated into its core. Apparently the major use of DVs is to implement thread-safe drawing to screen. I've been following McCLIM development since Mike MacDonald started it over 20 years ago and have been working on an experimental CAPI backend for it for a year or so. McCLIM now is entirely broken on LispWorks. The culprit appears to be DVs. Daniel says all is well using SBCL and other open source CL and believes something is wrong with Lispworks MOP. I have a seldom used installation of SBCL with Emacs & Slime available. I have now tested Dynamic-Vars.lisp (which can be downloaded from the McCLIM repo on codeberg.org in the folder mcclim/core/system/ ) on SBCL, and yes, work fine! I now have discovered how to get DVs working on LWW 8.1 but not without modifying code. See below. DVs are pretty interesting in their own right. Consider a class (as documented in the posts) (defclass C1 () ((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)) Slot3 is a thread-local-slot. An instance of C1 can be shared among several threads with slot3 being unique to each thread. Other uses are described in the posts. Also, according to jd, use of DV's is transparent (but not with LW). So, it appears the SBCL's implementation of C::SLOT-VALUE is significantly different from LW's. My work-around is to use MACROLET to shadow cl:slot-value as shown in the attached file. The function test-dv4 contains some portions of a test suit (ql:quickload "mcclim/test") that now work fine when modified using these forms. (defmacro with-dynamic-slots* (&body body) `(macrolet ((slot-value (o s)`(dynamic-slot-value ,o ,s))) (progn ,@body))) (defmacro with-dynamic-slots (slotnames form &body body) `(macrolet ((slot-value (o s)`(dynamic-slot-value ,o ,s))) (with-slots ,slotnames ,form ,@body))) I also needed an iniitialize-instance :around method to handle :initargs and still need to add code somewhere to add :accessor methods. I thought that LW's DEFADVICE facility might work for slot-value, but the manual discourages using it for low level functions. Trying to mess with changing slot-value directly was clearly foolish! SBCL was very unhappy with me messing with shadowing its slot-value warning loudly about violating PACKAGE-LOCK protocols. So, Common-Lisp's goal was to minimize such difference of result. What does anyone think is going on? Paul
dv.lisp
(text/plain, 9.1 KB)
#-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)
;;;;;;;;;;;;;;;;;
;;Finally we can define a class with slots that do not share the top value:
(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))
(defvar *object* (make-instance 'c1))
;;;;;;;;;;; These work! cl:slot-value returns dvars in s2 & s3
(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)
#+lispworks ;; not needed for SBCL
(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 (dynamic-slot-value obj slot-name)
(cadr initarg)))))))))
;;;;;;;;; do not try to change cl:slot-value
#+lispworks
(defmacro with-dynamic-slots* (&body body)
`(macrolet ((slot-value (o s)`(dynamic-slot-value ,o ,s)))
(progn ,@body)))
#+lispworks
(defmacro with-dynamic-slots (slotnames form &body body)
`(macrolet ((slot-value (o s)`(dynamic-slot-value ,o ,s)))
(with-slots ,slotnames ,form
,@body)))
(defun test-dv0 ()
(macrolet ((slot-value (o s)`(dynamic-slot-value ,o ,s)))
(let* ((obj (with-dynamic-slots*
(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-dynamic-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-dynamic-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-dynamic-slots*
(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 (clos: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
;;; changes for LW noted by ; <<<
(defun test-dv4 ()
;; this breaks as in METACLASS.2.BINDINGS
(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))
(with-dynamic-slots* ; <<<
;; 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-dynamic-slots (slot1 slot2 slot3) o1 ; <<<
(is (eq :a slot1))
(is (eq :b slot2))
(is (eq :c slot3)))
(with-dynamic-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))
(with-dynamic-slots* ; <<<
(slot-dlet (((o1 'slot2) :k))
(is (eq :k (slot-value o1 'slot2))) ; :B
(is (eq :y (slot-value o2 'slot2)))); :Y
(slot-dlet (((o1 'slot3) :l))
(is (eq :l (slot-value o1 'slot3))) ; :C
(is (eq :z (slot-value o2 'slot3))))))) ;Z
;;;(test metaclass.3.concurrent - OK
;;; a test of :accessor functions which uses compiled slot-value
(with-dynamic-slot-variants ()
(macrolet ((slot1 (o)`(dynamic-slot-value ,o 'slot1)) ; <<<
(slot2 (o)`(dynamic-slot-value ,o 'slot2)) ; <<<
(slot3 (o)`(dynamic-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)))))))
))