From 12d0437e21817bebb5a4f4dd8b880418c50ac503 Mon Sep 17 00:00:00 2001 Message-Id: <12d0437e21817bebb5a4f4dd8b880418c50ac503.1714390056.git.mdw@distorted.org.uk> From: Mark Wooding Date: Fri, 4 May 2001 16:56:34 +0000 Subject: [PATCH] Changed PROXY-CLASS to work with forward referneced superclasses. Organization: Straylight/Edgeware From: espen --- glib/proxy.lisp | 296 +++++++++++++++++++++++------------------------- 1 file changed, 141 insertions(+), 155 deletions(-) diff --git a/glib/proxy.lisp b/glib/proxy.lisp index b4ff7a3..6484cac 100644 --- a/glib/proxy.lisp +++ b/glib/proxy.lisp @@ -15,7 +15,7 @@ ;; 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.3 2001-05-04 16:56:34 espen Exp $ (in-package "GLIB") @@ -23,30 +23,27 @@ (in-package "GLIB") ;;;; 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 (pcl::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))) (defclass effective-virtual-slot-definition (standard-effective-slot-definition))) -(defmethod direct-slot-definition-class ((class virtual-class) initargs) +(defmethod direct-slot-definition-class ((class virtual-slot-class) 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) 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) +(defun %most-specific-slot-value (slotds slot &optional default) (let ((slotd (find-if #'(lambda (slotd) @@ -57,67 +54,58 @@ (defun %direct-slot-definitions-slot-value (slotds slot &optional default) (if slotd (slot-value slotd slot) default))) - - -(defgeneric compute-virtual-slot-location (class slotd direct-slotds)) + +(defgeneric compute-virtual-slot-accessors (class slotd direct-slotds)) -(defmethod compute-virtual-slot-location - ((class virtual-class) +(defmethod compute-virtual-slot-accessors + ((class virtual-slot-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))) - + (let ((getter (%most-specific-slot-value direct-slotds 'getter)) + (setter (%most-specific-slot-value direct-slotds 'setter))) + (list getter setter))) (defmethod compute-effective-slot-definition - ((class virtual-class) direct-slotds) + ((class virtual-slot-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))) + (compute-virtual-slot-accessors class slotd direct-slotds))) slotd)) - (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))))) - (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) + (value (class virtual-slot-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (let ((writer (second (slot-definition-location slotd)))) + (let ((setter (second (slot-definition-location slotd)))) (cond - ((null writer) + ((null setter) (error "Can't set read-only slot ~A in ~A" (slot-definition-name slotd) object)) - ((or (functionp writer) (symbolp writer)) - (funcall writer value object) + ((or (functionp setter) (symbolp setter)) + (funcall setter value object) value) (t - (funcall (fdefinition writer) value object) + (funcall (fdefinition setter) value object) value)))) - (defmethod validate-superclass - ((class virtual-class) (super pcl::standard-class)) + ((class virtual-slot-class) (super pcl::standard-class)) t) @@ -145,9 +133,7 @@ (defun remove-cached-instance (location) (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,16 +145,28 @@ (defmethod initialize-instance :after ((instance proxy) (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))) + (let ((free (proxy-class-free (class-of instance))) + (type (type-of instance)) + (location (proxy-location instance))) + (declare + (type symbol type) + (type system-area-pointer location)) #'(lambda () + (funcall free type location) (remove-cached-instance location)))) @@ -186,28 +184,38 @@ (deftype-method translate-from-alien (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) + `(funcall + (proxy-class-copy (find-class ',type-spec)) + ',type-spec (proxy-location ,instance)))) +(deftype-method unreference-alien proxy (type-spec location) + `(funcall (proxy-class-free (find-class ',type-spec)) ',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))) (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition)) - + (defmethod most-specific-proxy-superclass ((class proxy-class)) (find-if @@ -215,33 +223,34 @@ (defmethod most-specific-proxy-superclass ((class proxy-class)) (subtypep (class-name class) 'proxy)) (cdr (pcl::compute-class-precedence-list class)))) + (defmethod direct-proxy-superclass ((class proxy-class)) + (find-if + #'(lambda (class) + (subtypep (class-name class) 'proxy)) + (pcl::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))))) + (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) + (let ((super (direct-proxy-superclass class))) + (unless (typep super '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) initargs) (case (getf initargs :allocation) @@ -249,22 +258,20 @@ (defmethod direct-slot-definition-class ((class proxy-class) initargs) ; (:instance (error "Allocation :instance not allowed in class ~A" class)) (t (call-next-method)))) - (defmethod effective-slot-definition-class ((class proxy-class) 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 + (defmethod compute-virtual-slot-accessors ((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))) + (setf offset (slot-definition-offset (first direct-slotds))) (list #'(lambda (object) (funcall reader (proxy-location object) offset)) @@ -272,62 +279,50 @@ (defmethod compute-virtual-slot-location (let ((location (proxy-location object))) (funcall destroy location offset) (funcall writer value location offset))))))) - - - (defmethod compute-virtual-slot-location + + (defmethod compute-virtual-slot-accessors ((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))) - + (destructuring-bind (getter setter) (call-next-method) + (let ((class-name (class-name class))) + (with-slots (type) slotd + (list + (if (stringp getter) + (mkbinding getter type class-name) + getter) + (if (stringp setter) + (let ((setter (mkbinding setter 'nil class-name type))) + #'(lambda (value object) + (funcall setter object value))) + setter)))))) (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)))) + (with-slots (direct-slots size) class + (let ((current-offset + (proxy-class-size (most-specific-proxy-superclass class))) + (max-size 0)) (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)) - ) + (unless (slot-boundp slotd 'offset) + (setf offset current-offset)) + (setq current-offset (+ offset (size-of type))) + (setq max-size (max max-size current-offset))))) + (unless (slot-boundp class 'size) + (setf size max-size)))) (call-next-method)) - - + (defmethod validate-superclass ((class proxy-class) (super pcl::standard-class)) - (subtypep (class-name super) 'proxy)) - - (defgeneric make-proxy-instance (class location weak-ref &rest initargs &key))) + (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 +342,43 @@ (defun ensure-proxy-instance (class location weak-ref &rest initargs) (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) +(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))) +(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) -- [mdw]