From 9c03a07c0079f661828aed8b168ab6cba8504046 Mon Sep 17 00:00:00 2001
From: espen <espen>
Date: Sun, 31 Oct 2004 00:56:29 +0000
Subject: [PATCH] Added properties to interface classes

---
 glib/ginterface.lisp |  62 +++++++++++++++--
 glib/gobject.lisp    | 191 ++++++++++++++++++++++++++-------------------------
 2 files changed, 152 insertions(+), 101 deletions(-)

diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp
index 906606a..47fc9a3 100644
--- a/glib/ginterface.lisp
+++ b/glib/ginterface.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: ginterface.lisp,v 1.2 2004-10-27 14:58:59 espen Exp $
+;; $Id: ginterface.lisp,v 1.3 2004-10-31 00:56:29 espen Exp $
 
 (in-package "GLIB")
 
@@ -52,6 +52,27 @@
   (defclass ginterface-class (virtual-slot-class)
     ()))
 
+(defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
+  (case (getf initargs :allocation)
+    (:property (find-class 'direct-property-slot-definition))
+    (t (call-next-method))))
+
+(defmethod effective-slot-definition-class ((class ginterface-class) &rest initargs)
+  (case (getf initargs :allocation)
+    (:property (find-class 'effective-property-slot-definition))
+    (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)
+      (nconc 
+       (list :pname (signal-name-to-string 
+		     (most-specific-slot-value direct-slotds 'pname))
+	     :readable (most-specific-slot-value direct-slotds 'readable)
+	     :writable (most-specific-slot-value direct-slotds 'writable)
+	     :construct (most-specific-slot-value direct-slotds 'construct))
+       (call-next-method))
+    (call-next-method)))
+
 
 (defmethod shared-initialize ((class ginterface-class) names
 			      &rest initargs &key name alien-name)
@@ -71,12 +92,41 @@
 
 ;;;;
 
-(defun expand-ginterface-type (type-number options &rest args)
+
+(defbinding type-default-interface-ref (type) pointer
+  ((find-type-number type t) type-number))
+
+(defbinding type-default-interface-unref (type) nil
+  ((find-type-number type t) type-number))
+
+(defbinding type-default-interface-peek (type) pointer
+  ((find-type-number type t) type-number))
+
+(defbinding %object-interface-list-properties () pointer
+  (iface pointer)
+  (n-properties unsigned-int :out))
+
+(defun query-object-interface-properties (type &optional inherited-p)
+  (let* ((type-number (find-type-number type))
+	 (iface (type-default-interface-ref type-number)))
+    (unwind-protect
+	 (multiple-value-bind (array length)
+	     (%object-interface-list-properties iface)
+	   (unwind-protect
+		(%map-params array length type-number inherited-p)
+	     (deallocate-memory array)))
+;      (type-default-interface-unref type-number)
+      )))
+
+
+(defun expand-ginterface-type (type options &rest args)
   (declare (ignore args))
-  `(defclass ,(type-from-number type-number) (ginterface)
-     ,(getf options :slots)
-     (:metaclass ginterface-class)
-     (:alien-name ,(find-type-name type-number))))
+  (let ((class (type-from-number type))
+	(slots (getf options :slots)))    
+    `(defclass ,class (,(supertype type))
+      ,(slot-definitions class (query-object-interface-properties type) slots)
+      (:metaclass ginterface-class)
+      (:alien-name ,(find-type-name type)))))
 
 
 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type)
diff --git a/glib/gobject.lisp b/glib/gobject.lisp
index e21d702..79ce7dc 100644
--- 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.14 2004-10-28 09:34:35 espen Exp $
+;; $Id: gobject.lisp,v 1.15 2004-10-31 00:56:29 espen Exp $
 
 (in-package "GLIB")
 
@@ -42,7 +42,7 @@
 		 #'(lambda (slotd)
 		     (member key (slot-definition-initargs slotd)))
 		 slotds)
-     when (and (typep slotd 'effective-gobject-slot-definition)
+     when (and (typep slotd 'effective-property-slot-definition)
 	       (slot-value slotd 'construct))
      do (let ((type (find-type-number (slot-definition-type slotd))))
 	  (vector-push-extend (slot-definition-pname slotd) names)
@@ -55,7 +55,8 @@
 	 (%gobject-new (type-number-of object))
        (%gobject-newvv (type-number-of object) (length names) names values)))
     
-    (mapc #'gvalue-free values))
+;    (map 'nil #'gvalue-free values)
+    )
   
   (apply #'call-next-method object initargs))
 
@@ -139,13 +140,13 @@
   (defclass gobject-class (ginstance-class)
     ())
 
-  (defclass direct-gobject-slot-definition (direct-virtual-slot-definition)
+  (defclass direct-property-slot-definition (direct-virtual-slot-definition)
     ((pname :reader slot-definition-pname :initarg :pname)
      (readable :initform t :reader slot-readable-p :initarg :readable)
      (writable :initform t :reader slot-writable-p :initarg :writable)
      (construct :initform nil :initarg :construct)))
 
-  (defclass effective-gobject-slot-definition (effective-virtual-slot-definition)
+  (defclass effective-property-slot-definition (effective-virtual-slot-definition)
     ((pname :reader slot-definition-pname :initarg :pname)
      (readable :reader slot-readable-p :initarg :readable)
      (writable :reader slot-writable-p :initarg :writable)
@@ -168,12 +169,12 @@
 
 (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
   (case (getf initargs :allocation)
-    (:property (find-class 'direct-gobject-slot-definition))
+    (:property (find-class 'direct-property-slot-definition))
     (t (call-next-method))))
 
 (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
   (case (getf initargs :allocation)
-    (:property (find-class 'effective-gobject-slot-definition))
+    (:property (find-class 'effective-property-slot-definition))
     (t (call-next-method))))
 
 (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
@@ -188,7 +189,7 @@
     (call-next-method)))
 
 
-(defmethod initialize-internal-slot-functions ((slotd effective-gobject-slot-definition))
+(defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition))
   (let* ((type (slot-definition-type slotd))
 	 (pname (slot-definition-pname slotd))
 	 (type-number (find-type-number type)))
@@ -248,21 +249,29 @@
   (class pointer)
   (n-properties unsigned-int :out))
 
-(defun query-object-class-properties (type-number &optional
-				      inherited-properties)
-  (let ((class (type-class-ref type-number)))
-    (multiple-value-bind (array length)
-	(%object-class-list-properties class)
-      (unwind-protect
-	  (let ((all-properties
-		 (map-c-array 'list #'identity array 'param length)))
-	    (if (not inherited-properties)
-		(delete-if
-		 #'(lambda (param)
-		     (not (eql type-number (param-owner-type param))))
-		 all-properties)
-	      all-properties))
-	(deallocate-memory array)))))
+
+(defun %map-params (params length type inherited-p)
+  (if inherited-p
+      (map-c-array 'list #'identity params 'param length)
+    (let ((properties ()))
+      (map-c-array 'list 
+       #'(lambda (param)
+	   (when (eql (param-owner-type param) type)
+	     (push param properties)))
+       params 'param length)
+      (nreverse properties))))
+
+(defun query-object-class-properties (type &optional inherited-p)
+  (let* ((type-number (find-type-number type))
+	 (class (type-class-ref type-number)))
+    (unwind-protect
+	 (multiple-value-bind (array length)
+	     (%object-class-list-properties class)
+	   (unwind-protect
+		(%map-params array length type-number inherited-p)
+	     (deallocate-memory array)))
+;      (type-class-unref type-number)
+      )))
 
 
 (defun default-slot-name (name)
@@ -274,78 +283,70 @@
     nil "~A-~A~A" class-name slot-name
     (if (eq type 'boolean) "-P" ""))))
 
-(defun expand-gobject-type (type-number &optional options
-			    (metaclass 'gobject-class))
-  (let* ((supers (cons (supertype type-number) (implements type-number)))
-	 (class  (type-from-number type-number))
-	 (manual-slots (getf options :slots))
-	 (expanded-slots
-	  (mapcar
-	   #'(lambda (param)
-	       (with-slots (name flags value-type documentation) param
-	         (let* ((slot-name (default-slot-name name))
-;			(slot-type value-type) ;(type-from-number value-type t))
-			(slot-type (or (type-from-number value-type) value-type))
-			(accessor
-			 (default-slot-accessor class slot-name slot-type)));(type-from-number slot-type)))) ; temporary workaround for wrong topological sorting of types
-
-		   `(,slot-name
-		     :allocation :property
-		     :pname ,name
-		     ,@(cond
-			((and
-			  (member :writable flags)
-			  (member :readable flags)
-			  (not (member :construct-only flags)))
-			 (list :accessor accessor))
-			((and (member :writable flags)
-			      (not (member :construct-only flags)))
-			 (list :writer `(setf ,accessor)))
-			((member :readable flags)
-			 (list :reader accessor)))
-		     ,@(when (or
-			      (not (member :writable flags))
-			      (member :construct-only flags))
-		         (list :writable nil))
-		     ,@(when (not (member :readable flags))
-		         (list :readable nil))
-		     ,@(when (or 
-			      (member :construct flags)
-			      (member :construct-only flags))
-		         (list :construct t))
-		     ,@(when (or
-			      (member :construct flags)
-			      (member :construct-only flags)
-			      (member :writable flags))
-			 (list :initarg (intern (string slot-name) "KEYWORD")))
-		     :type ,slot-type
-		     ,@(when documentation
-			 (list :documentation documentation))))))
-	   (query-object-class-properties type-number))))
-
-    (dolist (slot-def (reverse manual-slots))
-      (let ((name (car slot-def))
-	    (pname (getf (cdr slot-def) :pname)))
-	(setq
-	 expanded-slots
-	 (delete-if
-	  #'(lambda (expanded-slot-def)
-	      (or
-	       (eq name (car expanded-slot-def))
-	       (and
-		pname
-		(string= pname (getf (cdr expanded-slot-def) :pname)))))
-	  expanded-slots))
-
-	(unless (getf (cdr slot-def) :ignore)
-	  (push slot-def expanded-slots))))
-    
-    `(progn
-       (defclass ,class ,supers
-	 ,expanded-slots
-	 (:metaclass ,metaclass)
-	 (:alien-name ,(find-type-name type-number))))))
 
+(defun slot-definition-from-property (class property)
+  (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))
+	   (accessor (default-slot-accessor class slot-name slot-type)))
+      
+      `(,slot-name
+	:allocation :property :pname ,name
+	
+	;; accessors
+	,@(cond
+	   ((and
+	     (member :writable flags) (member :readable flags)
+	     (not (member :construct-only flags)))
+	    (list :accessor accessor))
+	   ((and (member :writable flags) (not (member :construct-only flags)))
+	    (list :writer `(setf ,accessor)))
+	   ((member :readable flags)
+	    (list :reader accessor)))
+
+	;; readable/writable/construct
+	,@(when (or (not (member :writable flags))
+		    (member :construct-only flags))
+	    '(:writable nil))
+	,@(when (not (member :readable flags))
+	    '(:readable nil))
+	,@(when (or (member :construct flags) 
+		    (member :construct-only flags))
+	    '(:construct t))
+	
+	;; initargs
+	,@(when (or (member :construct flags)
+		    (member :construct-only flags)
+		    (member :writable flags))
+	    (list :initarg (intern (string slot-name) "KEYWORD")))
+	
+	:type ,slot-type
+	:documentation ,documentation))))
+
+
+(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))
+  (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))
+
+
+(defun expand-gobject-type (type &optional options (metaclass 'gobject-class))
+  (let ((supers (cons (supertype type) (implements type)))
+	(class  (type-from-number type))
+	(slots (getf options :slots)))    
+    `(defclass ,class ,supers
+      ,(slot-definitions class (query-object-class-properties type) slots)
+      (:metaclass ,metaclass)
+      (:alien-name ,(find-type-name type)))))
 
-(register-derivable-type 'gobject "GObject" 'expand-gobject-type)
 
+(register-derivable-type 'gobject "GObject" 'expand-gobject-type)
-- 
2.11.0