X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/7479d92c2e0ee576d0d376bbbbb72a9dcb948e4b..8efffde05a67910364634e0d1b9d99b4724a39d1:/glib/proxy.lisp diff --git a/glib/proxy.lisp b/glib/proxy.lisp index b4ff7a3..fa1e518 100644 --- a/glib/proxy.lisp +++ b/glib/proxy.lisp @@ -15,109 +15,127 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -;; $Id: proxy.lisp,v 1.2 2001-04-30 11:25:25 espen Exp $ +;; $Id: proxy.lisp,v 1.8 2004-10-27 14:59:00 espen Exp $ (in-package "GLIB") +(import +'(pcl::initialize-internal-slot-functions + pcl::compute-effective-slot-definition-initargs + pcl::compute-slot-accessor-info + pcl::reader-function pcl::writer-function pcl::boundp-function)) ;;;; Superclass for all metaclasses implementing some sort of virtual slots (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass virtual-class (pcl::standard-class)) + (defclass virtual-slot-class (standard-class) + ()) (defclass direct-virtual-slot-definition (standard-direct-slot-definition) - ((location - :reader slot-definition-location - :initarg :location))) + ((setter :reader slot-definition-setter :initarg :setter) + (getter :reader slot-definition-getter :initarg :getter) + (boundp :reader slot-definition-boundp :initarg :boundp))) - (defclass effective-virtual-slot-definition - (standard-effective-slot-definition))) + (defclass effective-virtual-slot-definition (standard-effective-slot-definition) + ((setter :reader slot-definition-setter :initarg :setter) + (getter :reader slot-definition-getter :initarg :getter) + (boundp :reader slot-definition-boundp :initarg :boundp))) + + (defun most-specific-slot-value (instances slot &optional default) + (let ((object (find-if + #'(lambda (ob) + (and (slot-exists-p ob slot) (slot-boundp ob slot))) + instances))) + (if object + (slot-value object slot) + default))) +) + -(defmethod direct-slot-definition-class ((class virtual-class) initargs) +(defmethod direct-slot-definition-class ((class virtual-slot-class) &rest initargs) (if (eq (getf initargs :allocation) :virtual) (find-class 'direct-virtual-slot-definition) (call-next-method))) - -(defmethod effective-slot-definition-class ((class virtual-class) initargs) +(defmethod effective-slot-definition-class ((class virtual-slot-class) &rest initargs) (if (eq (getf initargs :allocation) :virtual) (find-class 'effective-virtual-slot-definition) (call-next-method))) -(defun %direct-slot-definitions-slot-value (slotds slot &optional default) - (let ((slotd - (find-if - #'(lambda (slotd) - (and - (slot-exists-p slotd slot) - (slot-boundp slotd slot))) - slotds))) - (if slotd - (slot-value slotd slot) - default))) - - -(defgeneric compute-virtual-slot-location (class slotd direct-slotds)) - -(defmethod compute-virtual-slot-location - ((class virtual-class) - (slotd effective-virtual-slot-definition) - direct-slotds) - (let ((location - (%direct-slot-definitions-slot-value direct-slotds 'location))) - (if (and location (symbolp location)) - (list location `(setf ,location)) - location))) - - -(defmethod compute-effective-slot-definition - ((class virtual-class) direct-slotds) - (let ((slotd (call-next-method))) - (when (typep slotd 'effective-virtual-slot-definition) - (setf - (slot-value slotd 'pcl::location) - (compute-virtual-slot-location class slotd direct-slotds))) - slotd)) +(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition)) + (with-slots (getter setter boundp) slotd + (unless (slot-boundp slotd 'reader-function) + (setf + (slot-value slotd 'reader-function) + (etypecase getter + (function getter) + (null #'(lambda (object) + (declare (ignore object)) + (error "Can't read slot: ~A" (slot-definition-name slotd)))) + (symbol #'(lambda (object) + (funcall getter object)))))) + + (unless (slot-boundp slotd 'writer-function) + (setf + (slot-value slotd 'writer-function) + (etypecase setter + (function setter) + (null #'(lambda (object) + (declare (ignore object)) + (error "Can't set slot: ~A" (slot-definition-name slotd)))) + ((or symbol cons) #'(lambda (value object) + (funcall (fdefinition setter) value object)))))) + + (unless (slot-boundp slotd 'boundp-function) + (setf + (slot-value slotd 'boundp-function) + (etypecase boundp + (function boundp) + (null #'(lambda (object) + (declare (ignore object)) + t)) + (symbol #'(lambda (object) + (funcall boundp object))))))) + (initialize-internal-slot-gfs (slot-definition-name slotd))) + + + +(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) + type gf) + nil) + +(defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class) direct-slotds) + (if (eq (most-specific-slot-value direct-slotds 'allocation) :virtual) + (nconc + (list :getter (most-specific-slot-value direct-slotds 'getter) + :setter (most-specific-slot-value direct-slotds 'setter) + :boundp (most-specific-slot-value direct-slotds 'boundp)) + (call-next-method)) + (call-next-method))) (defmethod slot-value-using-class - ((class virtual-class) (object standard-object) + ((class virtual-slot-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (let ((reader (first (slot-definition-location slotd)))) - (if reader - (funcall reader object) - (slot-unbound class object (slot-definition-name slotd))))) - + (if (funcall (slot-value slotd 'boundp-function) object) + (funcall (slot-value slotd 'reader-function) object) + (slot-unbound class object (slot-definition-name slotd)))) (defmethod slot-boundp-using-class - ((class virtual-class) (object standard-object) + ((class virtual-slot-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (and (first (slot-definition-location slotd)) t)) - - - -(defmethod (setf slot-value-using-class) - (value (class virtual-class) (object standard-object) + (funcall (slot-value slotd 'boundp-function) object)) + +(defmethod (setf slot-value-using-class) + (value (class virtual-slot-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (let ((writer (second (slot-definition-location slotd)))) - (cond - ((null writer) - (error - "Can't set read-only slot ~A in ~A" - (slot-definition-name slotd) - object)) - ((or (functionp writer) (symbolp writer)) - (funcall writer value object) - value) - (t - (funcall (fdefinition writer) value object) - value)))) - + (funcall (slot-value slotd 'writer-function) value object)) + (defmethod validate-superclass - ((class virtual-class) (super pcl::standard-class)) + ((class virtual-slot-class) (super standard-class)) t) @@ -145,9 +163,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass proxy () - ((location - :reader proxy-location - :type system-area-pointer))) + ((location :reader proxy-location :type system-area-pointer))) (defgeneric initialize-proxy (object &rest initargs)) (defgeneric instance-finalizer (object))) @@ -159,17 +175,28 @@ (cache-instance instance) (ext:finalize instance (instance-finalizer instance))) - (defmethod initialize-proxy ((instance proxy) - &rest initargs) + &rest initargs &key location weak-ref) (declare (ignore initargs)) - (cache-instance instance)) - + (setf + (slot-value instance 'location) + (if weak-ref + (funcall + (proxy-class-copy (class-of instance)) + (type-of instance) location) + location)) + (cache-instance instance) + (ext:finalize instance (instance-finalizer instance))) (defmethod instance-finalizer ((instance proxy)) - (let ((location (proxy-location instance))) - #'(lambda () - (remove-cached-instance location)))) + (let ((class (class-of instance)) + (type (type-of instance)) + (location (proxy-location instance))) + (declare (type symbol type) (type system-area-pointer location)) + (let ((free (proxy-class-free class))) + #'(lambda () + (funcall free type location) + (remove-cached-instance location))))) (deftype-method translate-type-spec proxy (type-spec) @@ -186,148 +213,176 @@ (unless (null-pointer-p location) (ensure-proxy-instance ',type-spec location ,weak-ref)))) +(deftype-method translate-to-alien + proxy (type-spec instance &optional weak-ref) + (if weak-ref + `(proxy-location ,instance) + (let ((copy (proxy-class-copy (find-class type-spec)))) + (if (symbolp copy) + `(,copy ',type-spec (proxy-location ,instance)) + `(funcall ',copy ',type-spec (proxy-location ,instance)))))) +(deftype-method unreference-alien proxy (type-spec location) + (let ((free (proxy-class-free (find-class type-spec)))) + (if (symbolp free) + `(,free ',type-spec ,location) + `(funcall ',free ',type-spec ,location)))) + +;; (defun proxy-instance-size (proxy) +;; (proxy-class-size (class-of proxy))) ;;;; Metaclass used for subclasses of proxy (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass proxy-class (virtual-class) - ((size :reader proxy-class-instance-size))) + (defclass proxy-class (virtual-slot-class) + ((size :reader proxy-class-size) + (copy :reader proxy-class-copy) + (free :reader proxy-class-free))) (defclass direct-alien-slot-definition (direct-virtual-slot-definition) - ((allocation - :initform :alien) - (offset - :reader slot-definition-offset - :initarg :offset - :initform 0))) + ((allocation :initform :alien) + (offset :reader slot-definition-offset :initarg :offset))) (defclass effective-alien-slot-definition (effective-virtual-slot-definition) - ((offset :reader slot-definition-offset))) + ((offset :reader slot-definition-offset :initarg :offset))) - (defclass effective-virtual-alien-slot-definition - (effective-virtual-slot-definition)) - + (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition) + ()) + (defmethod most-specific-proxy-superclass ((class proxy-class)) (find-if #'(lambda (class) (subtypep (class-name class) 'proxy)) - (cdr (pcl::compute-class-precedence-list class)))) - - + (cdr (compute-class-precedence-list class)))) + + (defmethod direct-proxy-superclass ((class proxy-class)) + (find-if + #'(lambda (class) + (subtypep (class-name class) 'proxy)) + (class-direct-superclasses class))) + (defmethod shared-initialize ((class proxy-class) names - &rest initargs &key size name) + &rest initargs &key size copy free) (declare (ignore initargs)) (call-next-method) - (when size - (setf (slot-value class 'size) (first size)))) - - - (defmethod shared-initialize :after ((class proxy-class) names - &rest initargs &key) - (declare (ignore initargs names)) - (let* ((super (most-specific-proxy-superclass class)) - (actual-size - (if (eq (class-name super) 'proxy) - 0 - (proxy-class-instance-size super)))) - (dolist (slotd (class-slots class)) - (when (eq (slot-definition-allocation slotd) :alien) - (with-slots (offset type) slotd - (setq actual-size (max actual-size (+ offset (size-of type))))))) - (cond - ((not (slot-boundp class 'size)) - (setf (slot-value class 'size) actual-size)) - ((> actual-size (slot-value class 'size)) - (warn "The actual size of class ~A is lager than specified" class))))) - - - (defmethod direct-slot-definition-class ((class proxy-class) initargs) + (cond + (size (setf (slot-value class 'size) (first size))) + ((slot-boundp class 'size) (slot-makunbound class 'size))) + (cond + (copy (setf (slot-value class 'copy) (first copy))) + ((slot-boundp class 'copy) (slot-makunbound class 'copy))) + (cond + (free (setf (slot-value class 'free) (first free))) + ((slot-boundp class 'free) (slot-makunbound class 'free)))) + +;; (defmethod finalize-inheritance ((class proxy-class)) +;; (call-next-method) + (defmethod shared-initialize :after ((class proxy-class) names &rest initargs) + (let ((super (most-specific-proxy-superclass class))) + (unless (or (not super) (eq super (find-class 'proxy))) + (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy))) + (setf (slot-value class 'copy) (proxy-class-copy super))) + (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free))) + (setf (slot-value class 'free) (proxy-class-free super)))))) + + (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs) (case (getf initargs :allocation) ((nil :alien) (find-class 'direct-alien-slot-definition)) -; (:instance (error "Allocation :instance not allowed in class ~A" class)) (t (call-next-method)))) - - - (defmethod effective-slot-definition-class ((class proxy-class) initargs) + + (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs) (case (getf initargs :allocation) (:alien (find-class 'effective-alien-slot-definition)) (:virtual (find-class 'effective-virtual-alien-slot-definition)) (t (call-next-method)))) - (defmethod compute-virtual-slot-location - ((class proxy-class) (slotd effective-alien-slot-definition) - direct-slotds) - (with-slots (offset type) slotd - (setf offset (%direct-slot-definitions-slot-value direct-slotds 'offset)) - (let ((reader (intern-reader-function type)) - (writer (intern-writer-function type)) - (destroy (intern-destroy-function type))) - (list - #'(lambda (object) - (funcall reader (proxy-location object) offset)) - #'(lambda (value object) - (let ((location (proxy-location object))) - (funcall destroy location offset) - (funcall writer value location offset))))))) - + (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds) + (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien) + (nconc + (list :offset (most-specific-slot-value direct-slotds 'offset)) + (call-next-method)) + (call-next-method))) - (defmethod compute-virtual-slot-location - ((class proxy-class) - (slotd effective-virtual-alien-slot-definition) - direct-slotds) - (let ((location (call-next-method)) - (class-name (class-name class))) - (if (or (stringp location) (consp location)) - (destructuring-bind (reader &optional writer) (mklist location) - (with-slots (type) slotd - (list - (if (stringp reader) - (mkbinding reader type class-name) - reader) - (if (stringp writer) - (let ((writer (mkbinding writer 'nil class-name type))) - #'(lambda (value object) - (funcall writer object value))) - writer)))) - location))) - - (defmethod compute-slots ((class proxy-class)) - ;; Translating the user supplied relative (to previous slot) offsets - ;; to absolute offsets. - ;; This code is broken and have to be fixed. - (with-slots (direct-slots) class - (let* ((super (most-specific-proxy-superclass class)) - (slot-offset - (if (eq (class-name super) 'proxy) - 0 - (proxy-class-instance-size super)))) - (dolist (slotd direct-slots) - (when (eq (slot-definition-allocation slotd) :alien) - (with-slots (offset type) slotd - (setf - offset (+ slot-offset offset) - slot-offset (+ offset (size-of type))))))) - - ;; Reverse the direct slot definitions so the effective slots - ;; will be in correct order. - (setf direct-slots (reverse direct-slots)) - ;; This nreverse caused me so much frustration that I leave it - ;; here just as a reminder of what not to do. -; (setf direct-slots (nreverse direct-slots)) - ) + (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition)) + (with-slots (offset) slotd + (let* ((type (slot-definition-type slotd)) + (reader (intern-reader-function type)) + (writer (intern-writer-function type)) + (destroy (intern-destroy-function type))) + (unless (slot-boundp slotd 'reader-function) + (setf + (slot-value slotd 'reader-function) + #'(lambda (object) + (funcall reader (proxy-location object) offset)))) + + (unless (slot-boundp slotd 'writer-function) + (setf + (slot-value slotd 'writer-function) + #'(lambda (value object) + (let ((location (proxy-location object))) + (funcall destroy location offset) + (funcall writer value location offset))))) + + (unless (slot-boundp slotd 'boundp-function) + (setf + (slot-value slotd 'boundp-function) + #'(lambda (object) + (declare (ignore object)) + t))))) (call-next-method)) + + (defmethod initialize-internal-slot-functions ((slotd effective-virtual-alien-slot-definition)) + (with-slots (getter setter type) slotd + (when (and (not (slot-boundp slotd 'reader-function)) (stringp getter)) + (let ((reader (mkbinding-late getter type 'pointer))) + (setf (slot-value slotd 'reader-function) + #'(lambda (object) + (funcall reader (proxy-location object)))))) + + (when (and (not (slot-boundp slotd 'writer-function)) (stringp setter)) + (let ((writer (mkbinding-late setter 'nil 'pointer type))) + (setf (slot-value slotd 'writer-function) + #'(lambda (value object) + (funcall writer (proxy-location object) value)))))) + (call-next-method)) - (defmethod validate-superclass ((class proxy-class) - (super pcl::standard-class)) - (subtypep (class-name super) 'proxy)) + ;; TODO: call some C code to detect this a compile time + (defconstant +struct-alignmen+ 4) - (defgeneric make-proxy-instance (class location weak-ref &rest initargs &key))) + (defmethod compute-slots ((class proxy-class)) + ;; This stuff should really go somewhere else + (loop + with offset = (proxy-class-size (most-specific-proxy-superclass class)) + with size = offset + for slotd in (class-direct-slots class) + when (eq (slot-definition-allocation slotd) :alien) + do (if (not (slot-boundp slotd 'offset)) + (setf (slot-value slotd 'offset) offset) + (setq offset (slot-value slotd 'offset))) + + (incf offset (size-of (slot-definition-type slotd))) + (incf offset (mod offset +struct-alignmen+)) + (setq size (max size offset)) + + finally (unless (slot-boundp class 'size) + (setf (slot-value class 'size) size))) + (call-next-method)) + + (defmethod validate-superclass ((class proxy-class) (super standard-class)) + (subtypep (class-name super) 'proxy)) + + (defmethod proxy-class-size (class) + (declare (ignore class)) + 0) +) + +(defgeneric make-proxy-instance (class location weak-ref + &rest initargs &key));) (defmethod make-proxy-instance ((class symbol) location weak-ref &rest initargs &key) @@ -347,52 +402,43 @@ (apply #'make-proxy-instance class location weak-ref initargs))) -;;;; Superclass for wrapping of C structures + +;;;; Superclasses for wrapping of C structures (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass alien-structure (proxy) + (defclass struct (proxy) () (:metaclass proxy-class) - (:size 0))) + (:copy %copy-struct) + (:free %free-struct))) - -(defmethod initialize-instance ((structure alien-structure) - &rest initargs) +(defmethod initialize-instance ((structure struct) &rest initargs) (declare (ignore initargs)) (setf (slot-value structure 'location) - (allocate-memory (proxy-class-instance-size (class-of structure)))) + (allocate-memory (proxy-class-size (class-of structure)))) (call-next-method)) -(defmethod initialize-proxy ((structure alien-structure) - &rest initargs &key location weak-ref) - (declare (ignore initargs)) - (setf - (slot-value structure 'location) - (if weak-ref - (copy-memory location (proxy-class-instance-size (class-of structure))) - location)) - (call-next-method)) - +(defun %copy-struct (type location) + (copy-memory location (proxy-class-size (find-class type)))) -(defmethod instance-finalizer ((structure alien-structure)) - (let ((location (proxy-location structure))) - (declare (type system-area-pointer location)) - #'(lambda () - (deallocate-memory location) - (remove-cached-instance location)))) +(defun %free-struct (type location) + (declare (ignore type)) + (deallocate-memory location)) -(deftype-method translate-to-alien - alien-structure (type-spec object &optional weak-ref) - (if weak-ref - `(proxy-location ,object) - `(copy-memory - (proxy-location ,object) - ,(proxy-class-instance-size (find-class type-spec))))) +;(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass static (struct) + () + (:metaclass proxy-class) + (:copy %copy-static) + (:free %free-static));) +(defun %copy-static (type location) + (declare (ignore type)) + location) -(deftype-method unreference-alien alien-structure (type-spec c-struct) - (declare (ignore type-spec)) - `(deallocate-memory ,c-struct)) +(defun %free-static (type location) + (declare (ignore type location)) + nil)