From 584285fba4d518f8d6f581b542ee6b38650ba287 Mon Sep 17 00:00:00 2001 Message-Id: <584285fba4d518f8d6f581b542ee6b38650ba287.1714166178.git.mdw@distorted.org.uk> From: Mark Wooding Date: Wed, 16 Aug 2006 11:02:45 +0000 Subject: [PATCH] Updates for SBCL 0.9.14 and 0.9.15 Organization: Straylight/Edgeware From: espen --- gffi/interface.lisp | 4 +- gffi/proxy.lisp | 10 ++- gffi/virtual-slots.lisp | 185 +++++++++++++++++++++------------------- glib/gobject.lisp | 8 +- glib/gtype.lisp | 6 +- gtk/gtkobject.lisp | 5 +- 6 files changed, 118 insertions(+), 100 deletions(-) diff --git a/gffi/interface.lisp b/gffi/interface.lisp index 35a1a2f..88ce957 100644 --- a/gffi/interface.lisp +++ b/gffi/interface.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: interface.lisp,v 1.2 2006-04-26 19:19:14 espen Exp $ +;; $Id: interface.lisp,v 1.3 2006-08-16 11:02:45 espen Exp $ (in-package "GFFI") @@ -423,7 +423,7 @@ (defun find-next-type-method (name type-spec &optional (error-p t)) (lookup-method (type-spec) (if (and (symbolp type-spec) (find-class type-spec nil)) (let ((class (find-class type-spec))) - #+clisp + #?(or (sbcl>= 0 9 15) (featurep :clisp)) (unless (class-finalized-p class) (finalize-inheritance class)) (search-method-in-cpl-order diff --git a/gffi/proxy.lisp b/gffi/proxy.lisp index b7cdaed..c2c3fbc 100644 --- a/gffi/proxy.lisp +++ b/gffi/proxy.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: proxy.lisp,v 1.2 2006-06-08 13:25:09 espen Exp $ +;; $Id: proxy.lisp,v 1.3 2006-08-16 11:02:45 espen Exp $ (in-package "GFFI") @@ -162,7 +162,7 @@ (defmethod invalidate-instance ((instance proxy) &optional finalize-p) (funcall (instance-finalizer instance))) (slot-makunbound instance 'location) (cancel-finalization instance)) - ;; We can't cached invalidated instances in CLISP beacuse it is + ;; We can't cache invalidated instances in CLISP beacuse it is ;; not possible to cancel finalization #-clisp(cache-invalidated-instance instance)) @@ -242,7 +242,8 @@ (defmethod compute-effective-slot-definition-initargs ((class proxy-class) dir (call-next-method))) - (defmethod compute-slot-reader-function ((slotd effective-alien-slot-definition)) + (defmethod compute-slot-reader-function ((slotd effective-alien-slot-definition) &optional signal-unbound-p) + (declare (ignore signal-unbound-p)) (let* ((type (slot-definition-type slotd)) (offset (slot-definition-offset slotd)) (reader (reader-function type))) @@ -260,7 +261,8 @@ (defmethod compute-slot-writer-function ((slotd effective-alien-slot-definitio (funcall writer value location offset)) value))) - (defmethod compute-slot-reader-function ((slotd effective-virtual-alien-slot-definition)) + (defmethod compute-slot-reader-function ((slotd effective-virtual-alien-slot-definition) &optional signal-unbound-p) + (declare (ignore signal-unbound-p)) (if (and (slot-boundp slotd 'getter) (stringp (slot-definition-getter slotd))) (let ((getter (slot-definition-getter slotd)) (type (slot-definition-type slotd)) diff --git a/gffi/virtual-slots.lisp b/gffi/virtual-slots.lisp index 2f75fc9..b57082c 100644 --- a/gffi/virtual-slots.lisp +++ b/gffi/virtual-slots.lisp @@ -20,43 +20,46 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: virtual-slots.lisp,v 1.1 2006-04-25 20:49:16 espen Exp $ +;; $Id: virtual-slots.lisp,v 1.2 2006-08-16 11:02:45 espen Exp $ (in-package "GFFI") ;;;; Superclass for all metaclasses implementing some sort of virtual slots -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass virtual-slots-class (standard-class) - ()) - - (defclass direct-virtual-slot-definition (standard-direct-slot-definition) - ((setter :reader slot-definition-setter :initarg :setter) - (getter :reader slot-definition-getter :initarg :getter) - (unbound :reader slot-definition-unbound :initarg :unbound) - (boundp :reader slot-definition-boundp :initarg :boundp) - (makunbound :reader slot-definition-makunbound :initarg :makunbound) - #+clisp(type :initarg :type :reader slot-definition-type))) - - (defclass effective-virtual-slot-definition (standard-effective-slot-definition) - ((setter :reader slot-definition-setter :initarg :setter) - (getter :reader slot-definition-getter :initarg :getter) - (unbound :reader slot-definition-unbound :initarg :unbound) - (boundp :reader slot-definition-boundp :initarg :boundp) - (makunbound :reader slot-definition-makunbound :initarg :makunbound) - #+clisp(reader-function) - #+clisp(writer-function) - #+clisp(boundp-function) - makunbound-function - #+clisp(type :initarg :type :reader slot-definition-type))) - - (defclass direct-special-slot-definition (standard-direct-slot-definition) - ((special :initarg :special :accessor slot-definition-special))) +(defclass virtual-slots-class (standard-class) + ()) + +(defclass direct-virtual-slot-definition (standard-direct-slot-definition) + ((setter :reader slot-definition-setter :initarg :setter) + (getter :reader slot-definition-getter :initarg :getter) + (unbound :reader slot-definition-unbound :initarg :unbound) + (boundp :reader slot-definition-boundp :initarg :boundp) + (makunbound :reader slot-definition-makunbound :initarg :makunbound) + #+clisp(type :initarg :type :reader slot-definition-type))) - (defclass effective-special-slot-definition (standard-effective-slot-definition) - ((special :initarg :special :accessor slot-definition-special)))) +(defclass effective-virtual-slot-definition (standard-effective-slot-definition) + ((setter :reader slot-definition-setter :initarg :setter) + (getter :reader slot-definition-getter :initarg :getter) + (unbound :reader slot-definition-unbound :initarg :unbound) + (boundp :reader slot-definition-boundp :initarg :boundp) + (makunbound :reader slot-definition-makunbound :initarg :makunbound) + #+clisp(reader-function) + #+clisp(writer-function) + #+clisp(boundp-function) + makunbound-function + #+clisp(type :initarg :type :reader slot-definition-type))) + +(defclass direct-special-slot-definition (standard-direct-slot-definition) + ((special :initarg :special :accessor slot-definition-special))) + +(defclass effective-special-slot-definition (standard-effective-slot-definition) + ((special :initarg :special :accessor slot-definition-special))) + +(defclass virtual-slots-object (standard-object) + ()) + -(defgeneric compute-slot-reader-function (slotd)) +(defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p)) (defgeneric compute-slot-boundp-function (slotd)) (defgeneric compute-slot-writer-function (slotd)) (defgeneric compute-slot-makunbound-function (slotd)) @@ -91,7 +94,39 @@ (define-condition unreadable-slot (cell-error) (cell-error-name condition) (unreadable-slot-instance condition))))) -(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition)) +(defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t)) + (let ((reader-function (call-next-method))) + (cond + ((not signal-unbound-p) reader-function) + + ;; An explicit boundp function has been supplied + ((slot-boundp slotd 'boundp) + (let ((unbound-value (slot-value slotd 'boundp))) + #'(lambda (object) + (let ((value (funcall reader-function object))) + (if (eq value unbound-value) + (slot-unbound (class-of object) object (slot-definition-name slotd)) + value))))) + + ;; A type unbound value exists + ((let ((unbound-method (find-applicable-type-method 'unbound-value + (slot-definition-type slotd) nil))) + (when unbound-method + (let ((unbound-value (funcall unbound-method (slot-definition-type slotd)))) + #'(lambda (object) + (let ((value (funcall reader-function object))) + (if (eq value unbound-value) + (slot-unbound (class-of object) object (slot-definition-name slotd)) + value))))))) + + ((let ((boundp-function (compute-slot-boundp-function slotd))) + #'(lambda (object) + (if (funcall boundp-function object) + (funcall reader-function object) + (slot-unbound (class-of object) object (slot-definition-name slotd))))))))) + +(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p) + (declare (ignore signal-unbound-p)) (if (slot-boundp slotd 'getter) (slot-value slotd 'getter) #'(lambda (object) @@ -104,7 +139,7 @@ (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definitio ;; An unbound value has been supplied ((slot-boundp slotd 'unbound) - (let ((reader-function (slot-value slotd 'reader-function)) + (let ((reader-function (compute-slot-reader-function slotd nil)) (unbound-value (slot-value slotd 'unbound))) #'(lambda (object) (not (eql (funcall reader-function object) unbound-value))))) @@ -113,7 +148,7 @@ (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definitio ((let ((unbound-method (find-applicable-type-method 'unbound-value (slot-definition-type slotd) nil))) (when unbound-method - (let ((reader-function (slot-value slotd 'reader-function)) + (let ((reader-function (compute-slot-reader-function slotd nil)) (unbound-value (funcall unbound-method (slot-definition-type slotd)))) #'(lambda (object) (not (eql (funcall reader-function object) unbound-value))))))) @@ -148,6 +183,7 @@ (defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-defin #-clisp (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition)) + #?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze (setf (slot-value slotd 'reader-function) (compute-slot-reader-function slotd) (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd) @@ -161,6 +197,7 @@ (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-def (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf) nil) + (defun slot-bound-in-some-p (instances slot) (find-if #'(lambda (ob) @@ -195,73 +232,51 @@ (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-clas (append '(:special t) (call-next-method))) (t (call-next-method)))) - +#?(or (not (sbcl>= 0 9 14)) (featurep :clisp)) (defmethod slot-value-using-class - ((class virtual-slots-class) (object standard-object) + ((class virtual-slots-class) (object virtual-slots-object) (slotd effective-virtual-slot-definition)) - ;; This isn't optimal when we have an unbound value, as the reader - ;; function gets invoke twice - (if (funcall (slot-value slotd 'boundp-function) object) - (funcall (slot-value slotd 'reader-function) object) - (slot-unbound class object (slot-definition-name slotd)))) + (funcall (slot-value slotd 'reader-function) object)) +#?(or (not (sbcl>= 0 9 14)) (featurep :clisp)) (defmethod slot-boundp-using-class - ((class virtual-slots-class) (object standard-object) + ((class virtual-slots-class) (object virtual-slots-object) (slotd effective-virtual-slot-definition)) - (handler-case - (funcall (slot-value slotd 'boundp-function) object) - (unreadable-slot (condition) - (declare (ignore condition)) - nil))) + (funcall (slot-value slotd 'boundp-function) object)) +#?(or (not (sbcl>= 0 9 14)) (featurep :clisp)) (defmethod (setf slot-value-using-class) - (value (class virtual-slots-class) (object standard-object) + (value (class virtual-slots-class) (object virtual-slots-object) (slotd effective-virtual-slot-definition)) (funcall (slot-value slotd 'writer-function) value object)) (defmethod slot-makunbound-using-class - ((class virtual-slots-class) (object standard-object) + ((class virtual-slots-class) (object virtual-slots-object) (slotd effective-virtual-slot-definition)) (funcall (slot-value slotd 'makunbound-function) object)) -;; In CLISP a class may not have been finalized when update-slots are -;; called. So to avoid the possibility of finalize-instance beeing -;; called recursivly we have to delay the initialization of slot -;; functions until after an instance has been created. We therefor do -;; it in around methods for the generic functions used to access -;; slots. -#+clisp -(defmethod slot-value-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (unless (slot-boundp slotd 'reader-function) - (setf - (slot-value slotd 'reader-function) (compute-slot-reader-function slotd) - (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd))) - (call-next-method)) +;; In CLISP and SBCL (0.9.15 or newler) a class may not have been +;; finalized when update-slots are called. So to avoid the possibility +;; of finalize-instance beeing called recursivly we have to delay the +;; initialization of slot functions until after an instance has been +;; created. +#?(or (sbcl>= 0 9 15) (featurep :clisp)) +(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function))) + (setf (slot-value slotd name) (compute-slot-reader-function slotd))) -#+clisp -(defmethod slot-boundp-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (unless (slot-boundp slotd 'boundp-function) - (setf - (slot-value slotd 'reader-function) (compute-slot-reader-function slotd) - (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd))) - (call-next-method)) - -#+clisp -(defmethod (setf slot-value-using-class) :around (value (class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (declare (ignore value)) - (unless (slot-boundp slotd 'writer-function) - (setf - (slot-value slotd 'writer-function) (compute-slot-writer-function slotd))) - (call-next-method)) +#?(or (sbcl>= 0 9 15) (featurep :clisp)) +(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function))) + (setf (slot-value slotd name) (compute-slot-boundp-function slotd))) + +#?(or (sbcl>= 0 9 15) (featurep :clisp)) +(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function))) + (setf (slot-value slotd name) (compute-slot-writer-function slotd))) + +#?(or (sbcl>= 0 9 15) (featurep :clisp)) +(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function))) + (setf (slot-value slotd name) (compute-slot-makunbound-function slotd))) -#+clisp -(defmethod slot-makunbound-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) - (unless (slot-boundp slotd 'makunbound-function) - (setf - (slot-value slotd 'makunbound-function) - (compute-slot-makunbound-function slotd))) - (call-next-method)) (defmethod validate-superclass ((class virtual-slots-class) (super standard-class)) @@ -276,10 +291,6 @@ (defmethod slot-definition-special ((slotd standard-effective-slot-definition)) nil) -(defclass virtual-slots-object (standard-object) - ()) - - ;;; To determine if a slot should be initialized with the initform, ;;; CLISP checks whether it is unbound or not. This doesn't work with ;;; virtual slots which does not have an unbound state, so we have to diff --git a/glib/gobject.lisp b/glib/gobject.lisp index f908b12..ae5995a 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gobject.lisp,v 1.52 2006-04-25 22:10:36 espen Exp $ +;; $Id: gobject.lisp,v 1.53 2006-08-16 11:02:46 espen Exp $ (in-package "GLIB") @@ -149,7 +149,8 @@ (defmethod compute-effective-slot-definition-initargs ((class gobject-class) dir (defvar *ignore-setting-construct-only-property* nil) (declaim (special *ignore-setting-construct-only-property*)) -(defmethod compute-slot-reader-function ((slotd effective-property-slot-definition)) +(defmethod compute-slot-reader-function ((slotd effective-property-slot-definition) &optional signal-unbound-p) + (declare (ignore signal-unbound-p)) (if (slot-readable-p slotd) (let* ((type (slot-definition-type slotd)) (pname (slot-definition-pname slotd)) @@ -183,7 +184,8 @@ (defmethod compute-slot-writer-function ((slotd effective-property-slot-definiti (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))) ((call-next-method)))) -(defmethod compute-slot-reader-function ((slotd effective-user-data-slot-definition)) +(defmethod compute-slot-reader-function ((slotd effective-user-data-slot-definition) &optional signal-unbound-p) + (declare (ignore signal-unbound-p)) (let ((slot-name (slot-definition-name slotd))) #'(lambda (object) (user-data object slot-name)))) diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 5eea061..8b41474 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtype.lisp,v 1.53 2006-04-26 10:29:01 espen Exp $ +;; $Id: gtype.lisp,v 1.54 2006-08-16 11:02:46 espen Exp $ (in-package "GLIB") @@ -335,6 +335,7 @@ (default-alien-type-name class-name))) (register-new-type class-name (class-name super) gtype)))) (type-class-ref type-number) type-number)))) + #+nil (when (and (supertype type-number) (not (eq (class-name super) (supertype type-number)))) @@ -505,7 +506,8 @@ (defun find-type-dependencies (type &optional options) ;; The argument is a list where each elements is on the form -;; (type . dependencies) +;; (type . dependencies). This function will not handle indirect +;; dependencies and types depending on them selve. (defun sort-types-topologicaly (unsorted) (flet ((depend-p (type1) (find-if #'(lambda (type2) diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index 1c70ad4..bd6ec8d 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtkobject.lisp,v 1.35 2006-08-15 12:16:09 espen Exp $ +;; $Id: gtkobject.lisp,v 1.36 2006-08-16 11:02:46 espen Exp $ (in-package "GTK") @@ -135,7 +135,8 @@ (defmethod compute-effective-slot-definition-initargs ((class container-child-cl (call-next-method)) (call-next-method))) -(defmethod compute-slot-reader-function ((slotd effective-child-slot-definition)) +(defmethod compute-slot-reader-function ((slotd effective-child-slot-definition) &optional signal-unbound-p) + (declare (ignore signal-unbound-p)) (let* ((type (slot-definition-type slotd)) (pname (slot-definition-pname slotd)) (reader (reader-function type :ref :get))) -- [mdw]