From 62f128081bd450f55d7e4ffd6602fb518f8ea304 Mon Sep 17 00:00:00 2001 Message-Id: <62f128081bd450f55d7e4ffd6602fb518f8ea304.1715106013.git.mdw@distorted.org.uk> From: Mark Wooding Date: Tue, 1 Feb 2005 15:24:52 +0000 Subject: [PATCH] Introspected classes now defined in propper order Organization: Straylight/Edgeware From: espen --- glib/gboxed.lisp | 7 ++-- glib/genums.lisp | 5 +-- glib/ginterface.lisp | 13 ++++--- glib/gobject.lisp | 14 +++++--- glib/gtype.lisp | 82 +++++++++++++++++++++++++++----------------- gtk/gtkobject.lisp | 26 +++++++------- 6 files changed, 88 insertions(+), 59 deletions(-) diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp index c2daeb5..64ea49f 100644 --- a/glib/gboxed.lisp +++ b/glib/gboxed.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: gboxed.lisp,v 1.13 2004-11-09 10:10:59 espen Exp $ +;; $Id: gboxed.lisp,v 1.14 2005-02-01 15:24:52 espen Exp $ (in-package "GLIB") @@ -76,9 +76,10 @@ (defmethod unreference-foreign ((class boxed-class) location) ;;;; -(defun expand-boxed-type (type-number &optional slots) +(defun expand-boxed-type (type-number forward-p slots) `(defclass ,(type-from-number type-number) (boxed) - ,slots + ,(unless forward-p + slots) (:metaclass boxed-class) (:alien-name ,(find-type-name type-number)))) diff --git a/glib/genums.lisp b/glib/genums.lisp index 02fbe76..7f37948 100644 --- a/glib/genums.lisp +++ b/glib/genums.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: genums.lisp,v 1.5 2004-12-19 18:18:05 espen Exp $ +;; $Id: genums.lisp,v 1.6 2005-02-01 15:24:52 espen Exp $ (in-package "GLIB") @@ -213,7 +213,8 @@ (defun query-flags-values (type) ;;;; -(defun expand-enum-type (type-number &optional options) +(defun expand-enum-type (type-number forward-p options) + (declare (ignore forward)) (let* ((super (supertype type-number)) (type (type-from-number type-number)) (mappings (getf options :mappings)) diff --git a/glib/ginterface.lisp b/glib/ginterface.lisp index b54c665..17ced81 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.5 2004-11-07 15:54:15 espen Exp $ +;; $Id: ginterface.lisp,v 1.6 2005-02-01 15:24:52 espen Exp $ (in-package "GLIB") @@ -136,14 +136,17 @@ (defun query-object-interface-properties (type &optional inherited-p) ))) -(defun expand-ginterface-type (type options &rest args) +(defun expand-ginterface-type (type forward-p options &rest args) (declare (ignore args)) (let ((class (type-from-number type)) - (slots (getf options :slots))) + (slots (getf options :slots))) `(defclass ,class (,(supertype type)) - ,(slot-definitions class (query-object-interface-properties type) slots) + ,(unless forward-p + (slot-definitions class (query-object-interface-properties type) slots)) (:metaclass ginterface-class) (:alien-name ,(find-type-name type))))) +(defun ginterface-dependencies (type) + (delete-duplicates (mapcar #'param-value-type (query-object-interface-properties type)))) -(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type) +(register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies) diff --git a/glib/gobject.lisp b/glib/gobject.lisp index b07a620..a722174 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.29 2005-01-30 14:30:30 espen Exp $ +;; $Id: gobject.lisp,v 1.30 2005-02-01 15:24:52 espen Exp $ (in-package "GLIB") @@ -354,7 +354,7 @@ (defun default-slot-accessor (class-name slot-name type) (defun slot-definition-from-property (class property &optional slot-name args) (with-slots (name flags value-type documentation) property (let* ((slot-name (or slot-name (default-slot-name name))) - (slot-type (or (getf args :type) (type-from-number value-type) value-type)) + (slot-type (or (getf args :type) (type-from-number value-type) 'pointer)) (accessor (default-slot-accessor class slot-name slot-type))) `(,slot-name @@ -415,17 +415,21 @@ (defun slot-definitions (class properties slots) (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots)) -(defun expand-gobject-type (type &optional options (metaclass 'gobject-class)) +(defun expand-gobject-type (type forward-p options &optional (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) + ,(unless forward-p + (slot-definitions class (query-object-class-properties type) slots)) (:metaclass ,metaclass) (:alien-name ,(find-type-name type))))) +(defun gobject-dependencies (type) + (delete-duplicates (mapcar #'param-value-type (query-object-class-properties type)))) -(register-derivable-type 'gobject "GObject" 'expand-gobject-type) + +(register-derivable-type 'gobject "GObject" 'expand-gobject-type 'gobject-dependencies) ;;; Pseudo type for gobject instances which have their reference count diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 165c06e..5c7e5a0 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.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: gtype.lisp,v 1.23 2005-01-12 13:33:06 espen Exp $ +;; $Id: gtype.lisp,v 1.24 2005-02-01 15:24:52 espen Exp $ (in-package "GLIB") @@ -260,23 +260,25 @@ (register-type 'pathname "gchararray") (register-type 'string "gchararray") -;;;; +;;;; Introspection of type information (defvar *derivable-type-info* (make-hash-table)) -(defun register-derivable-type (type id expander) +(defun register-derivable-type (type id expander &optional dependencies) (register-type type id) (let ((type-number (register-type type id))) - (setf (gethash type-number *derivable-type-info*) expander))) + (setf + (gethash type-number *derivable-type-info*) + (list expander dependencies)))) (defun find-type-info (type) (dolist (super (cdr (type-hierarchy type))) (let ((info (gethash super *derivable-type-info*))) (return-if info)))) -(defun expand-type-definition (type options) - (let ((expander (find-type-info type))) - (funcall expander (find-type-number type t) options))) +(defun expand-type-definition (type forward-p options) + (let ((expander (first (find-type-info type)))) + (funcall expander (find-type-number type t) forward-p options))) (defbinding type-parent (type) type-number ((find-type-number type t) type-number)) @@ -337,24 +339,37 @@ (defun find-types (prefix) *derivable-type-info*) type-list)) -(defun %sort-types-topologicaly (unsorted) - (let ((sorted ())) - (loop while unsorted do - (dolist (type unsorted) - (let ((dependencies - (append (rest (type-hierarchy type)) (type-interfaces type)))) +(defun find-type-dependencies (type) + (let ((list-dependencies (second (find-type-info type)))) + (when list-dependencies + (funcall list-dependencies (find-type-number type t))))) + +(defun %sort-types-topologicaly (types) + (let ((unsorted (mapcar + #'(lambda (type) + (cons type (remove-if #'(lambda (dep) + (not (find dep types))) + (find-type-dependencies type)))) + types)) + (forward-define ()) + (sorted ())) + + (loop + as tmp = unsorted then (or (rest tmp) unsorted) + while tmp + do (destructuring-bind (type . dependencies) (first tmp) (cond - ((null dependencies) + ((every #'(lambda (dep) + (or (find dep forward-define) (find dep sorted))) + dependencies) (push type sorted) - (setq unsorted (delete type unsorted))) - (t - (unless (dolist (dep dependencies) - (when (find type (rest (type-hierarchy dep))) - (error "Cyclic type dependencie")) - (return-if (find dep unsorted))) - (push type sorted) - (setq unsorted (delete type unsorted)))))))) - (nreverse sorted))) + (setq unsorted (delete type unsorted :key #'first))) + ((some #'(lambda (dep) + (find type (find-type-dependencies dep))) + dependencies) + (push type forward-define))))) + + (values (nreverse sorted) forward-define))) (defun expand-type-definitions (prefix &optional args) @@ -385,15 +400,18 @@ (defun expand-type-definitions (prefix &optional args) (register-type (getf (type-options type-number) :type (default-type-name name)) type-number))) - - `(progn - ,@(mapcar - #'(lambda (type) - (expand-type-definition type (type-options type))) - (%sort-types-topologicaly type-list)))))) + + (multiple-value-bind (sorted-type-list forward-define) + (%sort-types-topologicaly type-list) + `(progn + ,@(mapcar + #'(lambda (type) + (expand-type-definition type t (type-options type))) + forward-define) + ,@(mapcar + #'(lambda (type) + (expand-type-definition type nil (type-options type))) + sorted-type-list)))))) (defmacro define-types-by-introspection (prefix &rest args) (expand-type-definitions prefix args)) - - - diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index eb6cdb2..d03e975 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.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: gtkobject.lisp,v 1.21 2004-12-20 20:09:53 espen Exp $ +;; $Id: gtkobject.lisp,v 1.22 2005-02-01 15:24:56 espen Exp $ (in-package "GTK") @@ -208,17 +208,19 @@ (defun query-container-class-child-properties (type-number) (defun default-container-child-name (container-class) (intern (format nil "~A-CHILD" container-class))) -(defun expand-container-type (type &optional options) +(defun expand-container-type (type forward-p options) (let* ((class (type-from-number type)) (super (supertype type)) (child-class (default-container-child-name class))) - `(progn - ,(expand-gobject-type type options) - (defclass ,child-class (,(default-container-child-name super)) - ,(slot-definitions child-class - (query-container-class-child-properties type) nil) - (:metaclass child-class) - (:container ,class))))) - - -(register-derivable-type 'container "GtkContainer" 'expand-container-type) + (if forward-p + (expand-gobject-type type t options) + `(progn + ,(expand-gobject-type type nil options) + (defclass ,child-class (,(default-container-child-name super)) + ,(slot-definitions child-class + (query-container-class-child-properties type) nil) + (:metaclass child-class) + (:container ,class)))))) + + +(register-derivable-type 'container "GtkContainer" 'expand-container-type 'gobject-dependencies) -- [mdw]