From b19bbc943eecd2655a0e3f32eefada102f51142f Mon Sep 17 00:00:00 2001 Message-Id: From: Mark Wooding Date: Wed, 15 Feb 2006 09:45:41 +0000 Subject: [PATCH] Removed dependency of some internal PCL symbols Organization: Straylight/Edgeware From: espen --- glib/defpackage.lisp | 11 +++--- glib/ginterface.lisp | 4 +-- glib/gobject.lisp | 4 +-- glib/proxy.lisp | 85 +++++++++++++++++++++++++------------------- gtk/gtkobject.lisp | 6 ++-- gtk/gtktypes.lisp | 4 +-- 6 files changed, 62 insertions(+), 52 deletions(-) diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp index 5bf644a..2e643ef 100644 --- a/glib/defpackage.lisp +++ b/glib/defpackage.lisp @@ -20,19 +20,18 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: defpackage.lisp,v 1.9 2006-02-08 21:43:33 espen Exp $ +;; $Id: defpackage.lisp,v 1.10 2006-02-15 09:45:41 espen Exp $ ;(export 'kernel::type-expand-1 "KERNEL") (defpackage "GLIB" (:use "COMMON-LISP""AUTOEXPORT") #+cmu(:use "SYSTEM" "KERNEL" "PCL" "EXT") - #+sbcl(:use "SB-SYS" "SB-KERNEL" "SB-PCL" "SB-EXT") + #+sbcl(:use "SB-SYS" "SB-KERNEL" "SB-MOP" "SB-EXT") #+cmu(:shadowing-import-from "PCL" "CLASS-DIRECT-SUPERCLASSES" "CLASS-DIRECT-SUPERCLASSES") (:shadow "POINTER") (:import-from #+cmu"PCL" #+sbcl"SB-PCL" - "LOCATION" "ALLOCATION" "DIRECT-SLOTS" "READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION" "INITIALIZE-INTERNAL-SLOT-FUNCTIONS" "COMPUTE-SLOT-ACCESSOR-INFO" "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS" @@ -41,7 +40,8 @@ (defpackage "GLIB" #+cmu(:import-from "ALIEN" "CALLBACK") (:import-from #+cmu"ALIEN" #+sbcl"SB-ALIEN" "WITH-ALIEN" "ALIEN-FUNCALL" "%HEAP-ALIEN" "MAKE-HEAP-ALIEN-INFO" - "ADDR" "PARSE-ALIEN-TYPE" "SYSTEM-AREA-POINTER" "EXTERN-ALIEN") + "ADDR" "PARSE-ALIEN-TYPE" "SYSTEM-AREA-POINTER" "EXTERN-ALIEN" + "ALIEN-SAP") #+cmu(:import-from "C-CALL" "%NATURALIZE-C-STRING" "VOID") #+sbcl(:import-from "SB-ALIEN" "%NATURALIZE-UTF8-STRING" "%DEPORT-UTF8-STRING" "VOID") @@ -52,8 +52,7 @@ (defpackage "GLIB" "PACKAGE-PREFIX" "DEFCALLBACK" "CALLBACK" "CALL-NEXT-HANDLER") (:export "LONG" "UNSIGNED-LONG" "INT" "UNSIGNED-INT" "SHORT" "UNSIGNED-SHORT" "SIGNED" "UNSIGNED" "CHAR" "POINTER" "COPY-OF") - (:export "LOCATION" "ALLOCATION" "DIRECT-SLOTS" "READER-FUNCTION" - "WRITER-FUNCTION" "BOUNDP-FUNCTION" + (:export "LOCATION" "READER-FUNCTION" "WRITER-FUNCTION" "BOUNDP-FUNCTION" "INITIALIZE-INTERNAL-SLOT-FUNCTIONS" "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS")) diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp index 6f498c5..0e89408 100644 --- a/glib/ginterface.lisp +++ b/glib/ginterface.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: ginterface.lisp,v 1.13 2006-02-09 22:29:43 espen Exp $ +;; $Id: ginterface.lisp,v 1.14 2006-02-15 09:45:41 espen Exp $ (in-package "GLIB") @@ -48,7 +48,7 @@ (defmethod effective-slot-definition-class ((class ginterface-class) &rest inita (t (call-next-method)))) (defmethod compute-effective-slot-definition-initargs ((class ginterface-class) direct-slotds) - (if (eq (most-specific-slot-value direct-slotds 'allocation) :property) + (if (eq (slot-definition-allocation (first direct-slotds)) :property) (nconc (list :pname (signal-name-to-string (most-specific-slot-value direct-slotds 'pname)) diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 3c67fe0..51086f5 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.46 2006-02-09 22:29:01 espen Exp $ +;; $Id: gobject.lisp,v 1.47 2006-02-15 09:45:41 espen Exp $ (in-package "GLIB") @@ -128,7 +128,7 @@ (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs (t (call-next-method)))) (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds) - (if (typep (first direct-slotds) 'direct-property-slot-definition) + (if (eq (slot-definition-allocation (first direct-slotds)) :property) (nconc (list :pname (signal-name-to-string (most-specific-slot-value direct-slotds 'pname diff --git a/glib/proxy.lisp b/glib/proxy.lisp index c2d04ee..0d6939e 100644 --- a/glib/proxy.lisp +++ b/glib/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.32 2006-02-09 22:26:38 espen Exp $ +;; $Id: proxy.lisp,v 1.33 2006-02-15 09:45:41 espen Exp $ (in-package "GLIB") @@ -43,10 +43,10 @@ (defclass effective-virtual-slot-definition (standard-effective-slot-definitio (boundp :reader slot-definition-boundp :initarg :boundp))) (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)))) (defvar *unbound-marker* (gensym "UNBOUND-MARKER-")) @@ -59,23 +59,22 @@ (defun most-specific-slot-value (instances slot &optional (default *unbound-mark (slot-value object slot) default))) -(defmethod initialize-instance ((slotd effective-special-slot-definition) &rest initargs) - (declare (ignore initargs)) - (call-next-method) - (setf (slot-value slotd 'allocation) :instance)) - (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs) - (case (getf initargs :allocation) - (:virtual (find-class 'direct-virtual-slot-definition)) - (:special (find-class 'direct-special-slot-definition)) - (t (call-next-method)))) + (cond + ((eq (getf initargs :allocation) :virtual) + (find-class 'direct-virtual-slot-definition)) + ((getf initargs :special) + (find-class 'direct-special-slot-definition)) + (t (call-next-method)))) (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs) - (case (getf initargs :allocation) - (:virtual (find-class 'effective-virtual-slot-definition)) - (:special (find-class 'effective-special-slot-definition)) - (t (call-next-method)))) + (cond + ((eq (getf initargs :allocation) :virtual) + (find-class 'effective-virtual-slot-definition)) + ((getf initargs :special) + (find-class 'effective-special-slot-definition)) + (t (call-next-method)))) (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition)) @@ -191,22 +190,25 @@ (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) nil) (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds) - (if (typep (first direct-slotds) 'direct-virtual-slot-definition) - (let ((initargs ())) - (let ((getter (most-specific-slot-value direct-slotds 'getter))) - (unless (eq getter *unbound-marker*) - (setf (getf initargs :getter) getter))) - (let ((setter (most-specific-slot-value direct-slotds 'setter))) - (unless (eq setter *unbound-marker*) - (setf (getf initargs :setter) setter))) - (let ((unbound (most-specific-slot-value direct-slotds 'unbound))) - (unless (eq unbound *unbound-marker*) - (setf (getf initargs :unbound) unbound))) - (let ((boundp (most-specific-slot-value direct-slotds 'boundp))) - (unless (eq boundp *unbound-marker*) - (setf (getf initargs :boundp) boundp))) - (nconc initargs (call-next-method))) - (call-next-method))) + (typecase (first direct-slotds) + (direct-virtual-slot-definition + (let ((initargs ())) + (let ((getter (most-specific-slot-value direct-slotds 'getter))) + (unless (eq getter *unbound-marker*) + (setf (getf initargs :getter) getter))) + (let ((setter (most-specific-slot-value direct-slotds 'setter))) + (unless (eq setter *unbound-marker*) + (setf (getf initargs :setter) setter))) + (let ((unbound (most-specific-slot-value direct-slotds 'unbound))) + (unless (eq unbound *unbound-marker*) + (setf (getf initargs :unbound) unbound))) + (let ((boundp (most-specific-slot-value direct-slotds 'boundp))) + (unless (eq boundp *unbound-marker*) + (setf (getf initargs :boundp) boundp))) + (nconc initargs (call-next-method)))) + (direct-special-slot-definition + (append '(:special t) (call-next-method))) + (t (call-next-method)))) (defmethod slot-value-using-class @@ -232,6 +234,15 @@ (defmethod validate-superclass t) +(defmethod slot-definition-special ((slotd standard-direct-slot-definition)) + (declare (ignore slotd)) + nil) + +(defmethod slot-definition-special ((slotd standard-effective-slot-definition)) + (declare (ignore slotd)) + nil) + + ;;;; Proxy cache (defvar *instance-cache* (make-hash-table :test #'eql)) @@ -292,7 +303,7 @@ (defun list-invalidated-instances () ;; TODO: add a ref-counted-proxy subclass (defclass proxy () - ((location :allocation :special :type pointer)) + ((location :special t :type pointer)) (:metaclass virtual-slots-class)) (defgeneric instance-finalizer (object)) @@ -364,8 +375,8 @@ (defclass proxy-class (virtual-slots-class) ((size :reader foreign-size))) (defclass direct-alien-slot-definition (direct-virtual-slot-definition) - ((allocation :initform :alien) - (offset :reader slot-definition-offset :initarg :offset))) + ((offset :reader slot-definition-offset :initarg :offset)) + (:default-initargs :allocation :alien)) (defclass effective-alien-slot-definition (effective-virtual-slot-definition) ((offset :reader slot-definition-offset :initarg :offset))) @@ -400,7 +411,7 @@ (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds) - (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien) + (if (eq (slot-definition-allocation (first direct-slotds)) :alien) (nconc (list :offset (most-specific-slot-value direct-slotds 'offset)) (call-next-method)) @@ -605,7 +616,7 @@ (defmethod unreference-foreign ((class struct-class) location) (defmethod compute-slots :around ((class struct-class)) (let ((slots (call-next-method))) (when (and - #-sbcl>=0.9.8(class-finalized-p class) #+sbc098 t + #-sbcl>=0.9.8(class-finalized-p class) (not (slot-boundp class 'size))) (let ((size (loop for slotd in slots diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index 8c27644..bdc6c18 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.30 2006-02-08 21:57:26 espen Exp $ +;; $Id: gtkobject.lisp,v 1.31 2006-02-15 09:47:42 espen Exp $ (in-package "GTK") @@ -125,10 +125,10 @@ (defmethod effective-slot-definition-class ((class child-class) &rest initargs) (t (call-next-method)))) (defmethod compute-effective-slot-definition-initargs ((class child-class) direct-slotds) - (if (eq (most-specific-slot-value direct-slotds 'allocation) :property) + (if (eq (slot-definition-allocation (first direct-slotds)) :property) (nconc (list :pname (most-specific-slot-value direct-slotds 'pname)) - ;; Need this to prevent type type expansion in SBCL (>= 0.9.8) + ;; Need this to prevent type expansion in SBCL (>= 0.9.8) (list :type (most-specific-slot-value direct-slotds 'type)) (call-next-method)) (call-next-method))) diff --git a/gtk/gtktypes.lisp b/gtk/gtktypes.lisp index 520563e..4478c51 100644 --- a/gtk/gtktypes.lisp +++ b/gtk/gtktypes.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: gtktypes.lisp,v 1.42 2006-02-06 19:16:17 espen Exp $ +;; $Id: gtktypes.lisp,v 1.43 2006-02-15 09:47:42 espen Exp $ (in-package "GTK") @@ -155,7 +155,7 @@ (define-types-by-introspection "Gtk" ("GtkWidget" :slots ((child-properties - :allocation :special + :special t :accessor widget-child-properties :type container-child) (window -- [mdw]