Adding :unbound arg to virtual slots. Misc cleanup

diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index f888cc6d95932efb8fac43bd8401157ed9e25250..829277271384f3825502cd7179dad10e9456a6b0 100644 (file)
--- a/glib/gobject.lisp
+++ b/glib/gobject.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: gobject.lisp,v 1.22 2004-11-12 14:24:17 espen Exp $
+;; $Id: gobject.lisp,v 1.23 2004-12-16 23:19:17 espen Exp $
 
 (in-package "GLIB")
 
@@ -82,7 +82,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 (eq (most-specific-slot-value direct-slotds 'allocation) :property)
+  (if (typep (first direct-slotds) 'direct-property-slot-definition)
       (nconc 
        (list :pname (signal-name-to-string 
                     (most-specific-slot-value direct-slotds 'pname))
@@ -97,42 +97,32 @@ (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-de
   (let* ((type (slot-definition-type slotd))
         (pname (slot-definition-pname slotd))
         (type-number (find-type-number type)))
-    (unless (slot-boundp slotd 'reader-function)
+    (when (and (not (slot-boundp slotd 'getter)) (slot-readable-p slotd))
       (setf 
-       (slot-value slotd 'reader-function)
-       (if (slot-readable-p slotd)
-          (let () ;(reader (reader-function (type-from-number type-number))))
-            #'(lambda (object)
-                (let ((gvalue (gvalue-new type-number)))
-                  (%object-get-property object pname gvalue)
-                  (unwind-protect
-                       (funcall #|reader|# (reader-function (type-from-number type-number))  gvalue +gvalue-value-offset+)
-                    (gvalue-free gvalue t)))))
-          #'(lambda (value object)
-              (error "Slot is not readable: ~A" (slot-definition-name slotd))))))
+       (slot-value slotd 'getter)
+       (let ((reader nil))
+        #'(lambda (object)
+            (unless reader
+              (setq reader (reader-function (type-from-number type-number))))
+            (let ((gvalue (gvalue-new type-number)))
+              (%object-get-property object pname gvalue)
+              (unwind-protect
+                (funcall reader  gvalue +gvalue-value-offset+)
+                (gvalue-free gvalue t)))))))
     
-    (unless (slot-boundp slotd 'writer-function)
+    (when (and (not (slot-boundp slotd 'setter)) (slot-writable-p slotd))
       (setf 
-       (slot-value slotd 'writer-function)
-       (if (slot-writable-p slotd)
-          (let ();; (writer (writer-function (type-from-number type-number)))
-;;              (destroy (destroy-function (type-from-number type-number))))
-            #'(lambda (value object)
-                (let ((gvalue (gvalue-new type-number)))
-                  (funcall #|writer|# (writer-function (type-from-number type-number)) value gvalue +gvalue-value-offset+)
-                  (%object-set-property object pname gvalue)
-;                 (funcall #|destroy|#(destroy-function (type-from-number type-number)) gvalue +gvalue-value-offset+)
-                  (gvalue-free gvalue t)
-                  value)))
-          #'(lambda (value object)
-              (error "Slot is not writable: ~A" (slot-definition-name slotd))))))
-    
-    (unless (slot-boundp slotd 'boundp-function)
-      (setf 
-       (slot-value slotd 'boundp-function)
-       #'(lambda (object)
-          (declare (ignore object))
-          t))))
+       (slot-value slotd 'setter)
+       (let ((writer nil))
+        #'(lambda (value object)
+            (unless writer
+              (setq writer (writer-function (type-from-number type-number))))
+            (let ((gvalue (gvalue-new type-number)))
+              (funcall writer value gvalue +gvalue-value-offset+)
+              (%object-set-property object pname gvalue)
+              (gvalue-free gvalue t)
+              value))))))
+
   (call-next-method))
 
 
@@ -144,6 +134,23 @@   (defclass gobject (ginstance)
     (:metaclass gobject-class)
     (:alien-name "GObject")))
 
+
+(defun initial-add (object function initargs key pkey)
+  (loop 
+   as (initarg value . rest) = initargs then rest
+   do (cond
+       ((eq initarg key) (funcall function object value))
+       ((eq initarg pkey) (mapc #'(lambda (value)
+                                   (funcall function object value))
+                               value)))
+       while rest))
+
+(defun initial-apply-add (object function initargs key pkey)
+  (initial-add object #'(lambda (object value)
+                         (apply function object (mklist value)))
+              initargs key pkey))
+
+
 (defmethod initialize-instance ((object gobject) &rest initargs)
   ;; Extract initargs which we should pass directly to the GObeject
   ;; constructor
@@ -297,14 +304,19 @@ (defun default-slot-accessor (class-name slot-name type)
     (if (eq type 'boolean) "-P" ""))))
 
 
-(defun slot-definition-from-property (class property)
+(defun slot-definition-from-property (class property &optional args)
   (with-slots (name flags value-type documentation) property
     (let* ((slot-name (default-slot-name name))
-          (slot-type (or (type-from-number value-type) value-type))
+          (slot-type (or (getf args :type) (type-from-number value-type) value-type))
           (accessor (default-slot-accessor class slot-name slot-type)))
       
       `(,slot-name
        :allocation :property :pname ,name
+
+       ;; temporary hack
+       ,@(cond
+          ((find :unbound args) (list :unbound (getf args :unbound)))
+          ((type-is-p slot-type 'gobject) (list :unbound nil)))
        
        ;; accessors
        ,@(cond
@@ -339,16 +351,20 @@ (defun slot-definition-from-property (class property)
 
 (defun slot-definitions (class properties slots)
   (loop 
-   with manual-slots = slots
    for property in properties
-   unless (find-if 
-          #'(lambda (slot)
-              (destructuring-bind (name &rest args) slot
-                (or 
-                 (equal (param-name property) (getf args :pname))
-                 (eq (default-slot-name (param-name property)) name))))
-          manual-slots)
-   do (push (slot-definition-from-property class property) slots))
+   as slot = (or
+             (find (param-name property) slots 
+              :key #'(lambda (slot) (getf (rest slot) :pname)) 
+              :test #'string=)
+             (find (param-name property) slots 
+              :key #'first :test #'string-equal))
+   do (cond
+       ((not slot) 
+       (push (slot-definition-from-property class property) slots))
+       ((getf (rest slot) :merge)
+       (setf 
+        (rest slot) 
+        (rest (slot-definition-from-property class property (rest slot)))))))
   (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))
 
 

diff --git a/glib/proxy.lisp b/glib/proxy.lisp
index f5c3f6e4330097b0ce195b39b05e2b2871226bb4..72f201f288b222feb0749d7491a46a8fb25f4285 100644 (file)
--- 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.14 2004-11-19 13:02:51 espen Exp $
+;; $Id: proxy.lisp,v 1.15 2004-12-16 23:19:17 espen Exp $
 
 (in-package "GLIB")
 
@@ -28,14 +28,19 @@   (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)))
   
   (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)))
+  
+  (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
 
-  (defun most-specific-slot-value (instances slot &optional default)
+  (defun most-specific-slot-value (instances slot &optional 
+                                  (default *unbound-marker*))
     (let ((object (find-if
                   #'(lambda (ob)
                       (and (slot-exists-p ob slot) (slot-boundp ob slot)))
@@ -58,72 +63,121 @@ (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest in
 
 
 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
-  (with-slots (getter setter boundp) slotd
-    (unless (slot-boundp slotd 'reader-function)
-      (setf 
+  (if (not (slot-boundp slotd 'getter))
+      (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)))
-        (string ;(let ()(reader  (mkbinding getter 
-;;                             (slot-definition-type slotd) 'pointer)))
-                  (setf (slot-value slotd 'reader-function)
-                        #'(lambda (object)
-                            (let ((reader
-                               (mkbinding getter 
-                                (slot-definition-type slotd) 'pointer)))
-                            (funcall reader (proxy-location object)))))))))
-
-    (unless (slot-boundp slotd 'writer-function)
+       #'(lambda (object)
+          (declare (ignore object))
+          (error "Can't read slot: ~A" (slot-definition-name slotd)))
+       (slot-value slotd 'boundp-function)
+       #'(lambda (object) (declare (ignore object)) nil))
+
+    (let ((getter-function
+          (let ((getter (slot-value slotd 'getter)))
+            (etypecase getter
+              (function getter)
+              (symbol 
+               #'(lambda (object)
+                   (funcall getter object)))
+              (string 
+               (let ((reader nil))
+                 (setf (slot-value slotd 'reader-function)
+                       #'(lambda (object)
+                           (unless reader
+                           (setq reader
+                            (mkbinding getter 
+                             (slot-definition-type slotd) 'pointer)))
+                           (funcall reader (proxy-location object))))))))))
+
       (setf 
-       (slot-value slotd 'writer-function)
+       (slot-value slotd 'boundp-function)
+       (cond
+       ((and 
+         (not (slot-boundp slotd 'unbound))
+         (not (slot-boundp slotd 'boundp)))
+        #'(lambda (object) (declare (ignore object)) t))  
+       ((slot-boundp slotd 'unbound)
+        (let ((unbound-value (slot-value slotd 'unbound)))
+          (lambda (object)
+            (not (eq (funcall getter-function object) unbound-value)))))
+       ((let ((boundp (slot-value slotd 'boundp)))
+          (etypecase boundp
+            (function boundp)
+            (symbol #'(lambda (object)
+                        (funcall boundp object)))
+            (string (let ((reader ()))
+                      #'(lambda (object)
+                          (unless reader
+                            (setq reader
+                             (mkbinding boundp
+                              (slot-definition-type slotd) 'pointer)))
+                          (funcall reader (proxy-location object))))))))))
+
+      (setf
+       (slot-value slotd 'reader-function)
+       (cond
+       ((slot-boundp slotd 'unbound)
+        (let ((unbound (slot-value slotd 'unbound))
+              (slot-name (slot-definition-name slotd)))
+          (lambda (object)
+            (let ((value (funcall getter-function object)))
+              (if (eq value unbound)
+                  (slot-unbound (class-of object) object slot-name)
+                value)))))
+       ((slot-boundp slotd 'boundp)
+        (let ((boundp-function (slot-value slotd 'boundp-function)))
+          (lambda (object)
+            (and
+             (funcall boundp-function object)
+             (funcall getter-function object)))))
+       (getter-function)))))
+
+  (setf 
+   (slot-value slotd 'writer-function)
+   (if (not (slot-boundp slotd 'setter))
+       #'(lambda (object)
+          (declare (ignore object))
+          (error "Can't set slot: ~A" (slot-definition-name slotd)))
+     (with-slots (setter) slotd
        (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)))
+        ((or symbol cons) 
+         #'(lambda (value object)
+             (funcall (fdefinition setter) value object)))
         (string
-         (let ((writer ()));; (mkbinding setter 'nil 'pointer 
-;;                      (slot-definition-type slotd))))
-           (setf (slot-value slotd 'writer-function)
-                 #'(lambda (value object)
-                     (unless writer
-                       (setq writer
-                        (mkbinding setter 'nil 'pointer 
-                         (slot-definition-type slotd))))
-                     (funcall writer (proxy-location object) value))))))))
-
-    (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)))))))
+         (let ((writer ()))
+           (setf
+            (slot-value slotd 'writer-function)
+            #'(lambda (value object)
+                (unless writer
+                  (setq writer
+                   (mkbinding setter 'nil 'pointer 
+                    (slot-definition-type slotd))))
+                (funcall writer (proxy-location object) value)))))))))
+
   (initialize-internal-slot-gfs (slot-definition-name slotd)))
 
 
 
-(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition)
-                                           type gf)
+(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
   nil)
 
 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-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))
+  (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)))
 
 
@@ -203,12 +257,8 @@ (defmethod unreference-foreign :around ((class class) location)
 
 (defmethod print-object ((instance proxy) stream)
   (print-unreadable-object (instance stream :type t :identity nil)
-    (format stream "at 0x~X" (sap-int (proxy-location instance)))))
-
-(defmethod print-object ((instance proxy) stream)
-  (print-unreadable-object (instance stream :type t :identity nil)
-    (format stream "at 0x~X" (sap-int (proxy-location instance)))))
-
+    (when (slot-boundp instance 'location)
+      (format stream "at 0x~X" (sap-int (proxy-location instance))))))
 
 (defmethod initialize-instance :around ((instance proxy) &key location)
   (if location
@@ -254,9 +304,7 @@   (defmethod direct-proxy-superclass ((class proxy-class))
         (subtypep (class-name class) 'proxy))
      (class-direct-superclasses class)))
   
-  (defmethod shared-initialize ((class proxy-class) names
-                               &rest initargs &key size)
-    (declare (ignore initargs))
+  (defmethod shared-initialize ((class proxy-class) names &key size)
     (call-next-method)
     (cond
       (size (setf (slot-value class 'size) (first size)))
@@ -284,29 +332,23 @@   (defmethod compute-effective-slot-definition-initargs ((class proxy-class) dir
   (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
     (with-slots (offset) slotd
       (let ((type (slot-definition-type slotd)))
-       (unless (slot-boundp slotd 'reader-function)
+       (unless (slot-boundp slotd 'getter)
          (let ((reader (reader-function type)))
            (setf 
-            (slot-value slotd 'reader-function)
+            (slot-value slotd 'getter)
             #'(lambda (object)
                 (funcall reader (proxy-location object) offset)))))
 
-       (unless (slot-boundp slotd 'writer-function)
+       (unless (slot-boundp slotd 'setter)
          (let ((writer (writer-function type))
                (destroy (destroy-function type)))
            (setf 
-            (slot-value slotd 'writer-function)
+            (slot-value slotd 'setter)
             #'(lambda (value object)
                 (let ((location (proxy-location object)))
                   (funcall destroy location offset) ; destroy old value
-                  (funcall writer value location offset))))))
-
-       (unless (slot-boundp slotd 'boundp-function)
-         (setf 
-          (slot-value slotd 'boundp-function)
-          #'(lambda (object)
-              (declare (ignore object))
-              t)))))
+                  (funcall writer value location offset))))))))
+
     (call-next-method))