Metaclass & McCLIM revisited
"Paul Werkowski (as pw at snoopy dot qozzy dot com)" <[email protected]>
| Newsgroups | gmane.lisp.lispworks.general |
|---|---|
| Message-ID | <[email protected]> |
Back in May I wrote that the new release of open source CLIM, McCLIM, failed to compile on Lispworks. The main problem was the inclusion in the source code a new file, dynamic-vars.lisp, which introduced a CLOS class with a non standard metaclass, CLASS-WITH-DYNAMIC-SLOTS. This was to implement an object slot scheme in which the slot-value of specified slots were initialized to be an instance of class DYNAMIC-VARIABLE which would contain the actual value of interest. The idea being that cl:slot-value and (setf slot-value) would access (dynamic-variable-value object slot-name), not the container instance. All of this to support the concept of thread-local slots. An instance of class TLS-RECORD-CONTEXT would contain graphic context info needed by the graphics backend for drawing to screen. It seemed that LispWorks could not deal with that metaclass stuff. It was suggested to me by the author of that code that LispWorks's implementation of the ANSI MetaObject Protocol was somehow deficient. I decided to find out what it would take to get that system to work in LispWorks. I began by chasing symptoms. The issues encountered were: * 1. Slot Initialization. * 2. Slot-value customization via slot-value-using-class. * 3. Automatic slot-accessor generation. The first was very puzzling, the second easy. The third at first crazy but finally interesting. So I came up with something that worked. McCLIM compiled and worked properly as before. Tread-Local slots worked as designed. I was not at all pleased with the results. The name of old Rube Goldberg and his wacky inventions came to my mind. Nested ENSURE-CLASS-USING-CLASS :AFTER methods, first to insert the metaclass name as an explicit superclass to a user class in order to get initialize-instance to be called, then creating a new class metaobject after removing slot accessor methods and then re-installing new methods, all to supress anoying method redefinition warnings. I decided I needed to take a break for awhile and went off to visit an old friend, CMUCL. In 1994, I spent four or five months of nights and weekends finishing the port from RISC workstations to x86 CISC PC running on FreeBSD Unix. That effort eventually led to a fork resulting in SBCL. This time I assisted current cmucl maintainers attempting to get McCLIM running on that CL. So, the result of all that is: there is nothing deficient with LispWorks' CLOS. All(?) the free CL implentations use Portable Common Loops (PCL) for an object system. PCL was created by Xerox cica 1986 and was one of several lisp object system to influence the CLOS of the ANSI spec, a predecessor to or prototype of CLOS. The "closer-mop" quicklisp package tries to bridge the difference. What I remember most of PCL in the 90's is that it took about 4 hours to compile on my minimally configured 486 PC. McCLIM is only portable among Lisps that use PCL for an object system. ------ What's the difference between PCL and LW CLOS? Start at the beginning with object initialization. The DV code starts with CL:ALLOCATE-INSTANCE. From CLHS, "The generic function allocate-instance creates and returns a new instance of the class, without initializing it. When the class is a standard class, this means that the slots are unbound; when the class is a structure class, this means the slots' values are unspecified." Also, " The consequences of adding methods to allocate-instance is unspecified. This capability might be added by the Metaobject Protocol." The DV code (written for PCL) uses generic-function cl:allocate-instance, specialized to the metaclass (class-with-dynamic-slots), to install instances of Dynamic-Variable in specified slots. Lispworks executes that code and then ensures the slots are unbound. So, what to do? First thought was to move that code to initialize-instance :after only to find that initialize-instance was not called at all by LW (or PCL). Apparently, I-I is a thing that only metaclasses STANDARD-CLASS and STRUCTURE-CLASS know about. I found that installing the metaclass name as an explicit superclass, eg. (defclass myclass (class-with-dynamic-slots) ...) got past that obstacle. More correct is to use MAKE-INSTANCE specialized to the metaclass name. A bonus here is that on entry to make-instance, default and specified :intargs have been resolved and all that is needed is to insert those values into a new DV instance and install that in the slot. Second, SLOT-VALUE. The CLOS spec suggest implementations have function SLOT-VALUE call GF SLOT-VALUE-USING-CLASS. PCL does this for the function and also for default accessor methods specified in DEFCLASS slots. PCL's slot-value-using-class expects the second argument to be a SLOT-DEFINITION metaobject. LispWorks second argument to slot-value is slot-name (a symbol), and uses CLOS::STANDARD-INSTANCE-ACCESS or (CLOS::FAST-STANDARD-INSTANCE-ACCESS) for both slot-value and default acccessor methods. Thus slot-value of a DV slot picks up the DV instance instead of its imbedded value. Closer-mop arranges to find the proper slot-definition metaobject by name and passes that to slot-value-using-class. Third, Slot Accessor Methods. So, how to get those optimized accessor methods to do the right thing. It turns out that LW's CLOS has the MOPery to do that. CLOS:READER-METHOD-CLASS, CLOS:MAKE-READER-METHOD, CLOS:WRITER-METHOD-CLASS and CLOS:MAKE-WRITER-METHOD do the job. A downside is that a few things neither documented nor exported from :CLOS are needed. Finally, attached is build-mcclim.lisp which, when loaded, generates an environment and and a function of that name that will (with a bit of luck) fetch (via quicklisp) all the needed software, compile, load and patch McCLIM and optionally the clim demo/examples system. This presents a table of 68 push-buttons, each of which will produce a possibly interactive graphic. All but the last three, starting with the word 'concurrent', appear to work. There is also a test suite, "mcclim/test" with results: Did 2200 checks. Pass: 2191 (99%) Skip: 0 ( 0%) Fail: 9 ( 0%) NOTE! A working X11 server must be installed. I use "VcXsrv X Server" on Windows 10 which can be obtained from vcxsrv.sourceforge.net.
build-mcclim.lisp
(text/plain, 8 KB)
;;; the new boot-mcclim?
(in-package :user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(cl:unless (cl:find-package :clim-internals)
(cl:defpackage :clim-internals
(:use :cl :cl-user)
(:nicknames :climi))
(cl:defpackage :clim
(:use :cl :clim-internals)
(:export
#:invoke-with-output-to-output-record
#:delete-output-record
#:text-size
))
))
(in-package :clim-internals)
;;; setup compile time environment of dynamic-vars
(eval-when (:compile-toplevel :load-toplevel :execute)
(cl:unless (cl:find-class 'climi::class-with-dynamic-slots nil)
(cl:defclass climi::class-with-dynamic-slots (cl:standard-class) ())
(cl:defclass dynamic-direct-slot (clos:standard-direct-slot-definition)
((dynamic :initform nil :initarg :dynamic :reader dynamic-variable-type)))
(defmethod clos:validate-superclass
((class climi::class-with-dynamic-slots)
(super standard-class)) t)))
;;; mcclim uses MOP as local nickname for C2MOP
#-:closer-mop
(ql:quickload "closer-mop")
;;; supress inline warnings
(ql:quickload "alexandria")
(proclaim '(notinline alexandria:assoc-value))
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package :mop)
(hcl:add-package-local-nickname :mop :c2mop))
)
;;;;;;;;; LispWorks CLOS MOP features for McCLIM Dynamic Variables metaclass
(in-package :clim-internals)
(defun raw-slot-value (object slot-name)
(clos::standard-instance-access object slot-name))
(defun (setf raw-slot-value)(new-value object slot-name)
(setf (clos::standard-instance-access object slot-name) new-value))
(defun %slotd (object slot-name)
"Slot-definition from name"
(let ((class (class-of object)))
(find slot-name (clos:class-slots class)
:key #'mop:slot-definition-name)))
;;; replace mcclim function for test suite
#+mcclim
(defun slot-dvar* (object slot-name)
;; ensure dv slot has a dv in it
;; returns existing DV or installs a new one
(let ((slotd (%slotd object slot-name)))
(when (typep slotd 'dynamic-effective-slot)
(if (slot-boundp object slot-name)
(let* ((raw-value (raw-slot-value object slot-name)))
(if (typep raw-value 'dynamic-variable) raw-value
;; else an initial :initarg value, fix it
(let ((dv (make-dynamic-variable-using-key slotd))) ; unbound
(setf (dynamic-variable-value dv) raw-value)
(setf (raw-slot-value object slot-name) dv))))
(make-dynamic-variable-using-key slotd)))))
(defmethod clos:slot-value-using-class
((class class-with-dynamic-slots) object slot)
(let* ((slotd (%slotd object slot))
(raw-value (call-next-method)))
(cond ((typep slotd 'dynamic-effective-slot)
;; pass to DV code
(clos:slot-value-using-class class object slotd))
(t raw-value))))
(defmethod (setf clos:slot-value-using-class)
(new-value (class class-with-dynamic-slots) object slot)
(let* ((slotd (%slotd object slot))
(slot-name (clos:slot-definition-name slotd))
(raw-value (raw-slot-value object slot-name)))
(cond ((and (typep slotd 'dynamic-effective-slot)
(typep raw-value 'dynamic-variable))
(setf (dynamic-variable-value raw-value) new-value))
(t (call-next-method)))))
(defmethod make-instance ((class class-with-dynamic-slots)
&rest class-initargs &key &allow-other-keys)
"install object container in appropriate slots"
(let ((object (call-next-method)))
(dolist (slotd (mop:class-slots class) object)
(if (typep slotd 'dynamic-effective-slot)
(let* ((slot-name (mop:slot-definition-name slotd))
(slot-initargs (mop:slot-definition-initargs slotd))
(DV (make-dynamic-variable-using-key slotd)))
(setf (raw-slot-value object slot-name) DV)
;; initialize to class-initargs if any
(loop for (key val) on class-initargs by #'cddr
when (member key slot-initargs)
do (setf (dynamic-variable-value DV) val)))
(call-next-method)))))
;;; These cause DV accessors specified in TLS-RECORD-CONTEXT to
;;; use normal SLOT-VALUE instead of LW's optimized STANDARD-INSTANCE-ACCESS
;;; which then redirects to SLOT-VALUE-USING-CLASS.
(defclass dynamic-reader-method (mop:standard-reader-method)())
(defmethod mop:reader-method-class
((class class-with-dynamic-slots)
(slotd dynamic-direct-slot) &rest initargs)
(let ((stype (dynamic-variable-type slotd)))
(if stype
'dynamic-reader-method
'mop:standard-reader-method)))
(defmethod clos:make-reader-method
((class class-with-dynamic-slots) (slotd dynamic-direct-slot)
slot-name sxhash reader reader-fcn-type)
(if (dynamic-variable-type slotd)
(call-next-method
class slotd slot-name sxhash reader
'clos::standard-reader-std-class-using-slot-value)
(call-next-method)))
(defclass dynamic-writer-method (mop:standard-writer-method)())
(defmethod mop:writer-method-class
((class class-with-dynamic-slots)
(slotd dynamic-direct-slot) &rest initargs)
(let ((stype (dynamic-variable-type slotd)))
(if stype
'dynamic-writer-method
'mop:standard-writer-method)))
(defmethod clos:make-writer-method
((class class-with-dynamic-slots) (slotd dynamic-direct-slot)
slot-name sxhash writer writer-fcn-type)
(if (dynamic-variable-type slotd)
(call-next-method
class slotd slot-name sxhash writer
'clos::standard-writer-std-class-using-slot-value)
(call-next-method)))
;;;;;;;;;
;;; Deferred patch
(defun fix-mcclim ()
;; To keep this to one file
(let* ((code
'("(in-package :climi)"
;; adds &key &allow-other-keys
"(cl:defgeneric invoke-with-output-to-output-record"
" (cl:stream continuation record-type &rest initargs"
" &key &allow-other-keys))"
;; primary methods needed by CLOS
"(cl:defgeneric clim:text-size (medium string &key text-style start end)"
" (:method (medium string &key text-style start end)"
" (declare (ignore medium string text-style start end))))"
"(cl:defgeneric delete-output-record (child record &optional errorp)"
" (:method (child record &optional error))"
" (declare (ignore child record error)))"
;; patch CLX
"(cl:defun xlib::getenv (name)(lw:environment-variable name))"
))
(tpn (hcl:create-temp-file :prefix "XXX")))
(unwind-protect
(with-open-file (stream tpn :direction :output :if-exists :supersede)
(loop for line in code do (write-line line stream)))
(load tpn))
(delete-file tpn)))
(in-package :user)
(defun build-mcclim (&optional examples-too)
(let ((lw:*handle-warn-on-redefinition* :quiet))
(ql:quickload "mcclim")
;; Some patches
(climi::fix-mcclim) ; above
;; LW ensures instance is uninitialized
;; and deletes what McCLIM does to initialize slots.
;; Use make-instance instead (above).
(let ((method (cl:find-method
#'allocate-instance ()
(mapcar #'find-class
'(climi::class-with-dynamic-slots))
nil)))
(when method
(cl:remove-method #'allocate-instance method)))
(when examples-too
(ql:quickload "clim-examples")
;; Try (clim-demo:demodemo)
)))
(defun clean-mcclim ()
(let* ((fasl-root
(pathname-location
(uiop/lisp-build:compile-file-pathname*
(merge-pathnames "mcclim/" (car ql:*local-project-directories*)))))
(fasl-files
(directory (merge-pathnames "**/*.64ofasl" fasl-root))))
(dolist (pn fasl-files)
(delete-file pn))))