From d4b21b082be225e0c0edaa822bd8b1e267e2f87a Mon Sep 17 00:00:00 2001 Message-Id: From: Mark Wooding Date: Fri, 11 May 2001 16:04:33 +0000 Subject: [PATCH] Added code for automatic type definitions Organization: Straylight/Edgeware From: espen --- glib/gboxed.lisp | 79 +++------- glib/genums.lisp | 129 ++++++++--------- glib/gobject.lisp | 106 ++++++++++++-- glib/gtype.lisp | 362 ++++++++++++++++++++++++++++------------------ 4 files changed, 393 insertions(+), 283 deletions(-) diff --git a/glib/gboxed.lisp b/glib/gboxed.lisp index e2dac5c..48433cc 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.2 2001-04-30 11:25:25 espen Exp $ +;; $Id: gboxed.lisp,v 1.3 2001-05-11 16:04:33 espen Exp $ (in-package "GLIB") @@ -23,45 +23,16 @@ (in-package "GLIB") (eval-when (:compile-toplevel :load-toplevel :execute) (defclass boxed (proxy) () - (:metaclass proxy-class))) - -(defmethod initialize-proxy ((boxed boxed) &rest initargs - &key location weak-ref) - (declare (ignore initargs)) - (setf - (slot-value boxed 'location) - (if weak-ref - (%boxed-copy (find-type-number (class-of boxed)) location) - location)) - (call-next-method)) - -(defmethod instance-finalizer ((boxed boxed)) - (let ((location (proxy-location boxed)) - (type-number (find-type-number (class-of boxed)))) - (declare (type system-area-pointer location)) - #'(lambda () - (%boxed-free type-number location) - (remove-cached-instance location)))) - - -(deftype-method translate-to-alien boxed (type-spec boxed &optional weak-ref) - (if weak-ref - `(proxy-location ,boxed) - `(let ((boxed ,boxed)) - (%boxed-copy - (find-type-number type-spec) - (proxy-location boxed))))) - -(deftype-method unreference-alien boxed (type-spec c-struct) - `(%boxed-free ,(find-type-number type-spec) ,c-struct)) - - -(defbinding %boxed-copy () pointer - (type type-number) + (:metaclass proxy-class) + (:copy %boxed-copy) + (:free %boxed-free))) + +(defbinding %boxed-copy (type location) pointer + ((find-type-number type) type-number) (location pointer)) -(defbinding %boxed-free () nil - (type type-number) +(defbinding %boxed-free (type location) nil + ((find-type-number type) type-number) (location pointer)) @@ -72,29 +43,15 @@ (defclass boxed-class (proxy-class))) (defmethod shared-initialize ((class boxed-class) names - &rest initargs - &key name alien-name type-init) + &rest initargs &key name alien-name) (declare (ignore initargs names)) (call-next-method) (let* ((class-name (or name (class-name class))) (type-number - (cond - ((and alien-name type-init) - (error - "Specify either :type-init or :alien-name for class ~A" - class-name)) - (alien-name (type-number-from-alien-name (first alien-name))) - (type-init (funcall (mkbinding (first type-init) 'type-number))) - (t - (or - (type-number-from-alien-name - (default-alien-type-name class-name) nil) - (funcall - (mkbinding - (default-alien-fname (format nil "~A_get_type" class-name)) - 'type-number))))))) - (setf (find-type-number class) type-number))) + (find-type-number + (or (first alien-name) (default-alien-type-name class-name))))) + (register-type class-name type-number))) (defmethod validate-superclass @@ -102,6 +59,12 @@ (defmethod validate-superclass (subtypep (class-name super) 'boxed)) -;;;; Initializing type numbers +;;;; + +(defun expand-boxed-type (type-number &optional slots) + `(defclass ,(type-from-number type-number) (boxed) + ,slots + (:metaclass boxed-class) + (:alien-name ,(find-type-name type-number)))) -(setf (alien-type-name 'boxed) "GBoxed") +(register-derivable-type 'boxed "GBoxed" :expand 'expand-boxed-type) diff --git a/glib/genums.lisp b/glib/genums.lisp index d2cbe4a..f688f9f 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.1 2001-04-29 20:19:25 espen Exp $ +;; $Id: genums.lisp,v 1.2 2001-05-11 16:04:33 espen Exp $ (in-package "GLIB") @@ -38,7 +38,24 @@ (defun %map-mappings (args op) (rest args) args)))) - +(defun %query-enum-or-flags-values (query-function class type) + (multiple-value-bind (sap length) + (funcall query-function (type-class-ref type)) + (let ((values nil) + (size (proxy-class-size (find-class class))) + (proxy (make-proxy-instance class sap nil))) + (dotimes (i length) + (with-slots (location nickname value) proxy + (setf location sap) + (setq sap (sap+ sap size)) + (push + (list + (intern (substitute #\- #\_ (string-upcase nickname)) "KEYWORD") + value) + values))) + values))) + + ;;;; Enum type (deftype enum (&rest args) @@ -69,43 +86,20 @@ (deftype-method translate-from-alien enum (type-spec expr &optional weak-ref) `(ecase ,expr ,@(%map-mappings args :int-enum)))) -(setf (alien-type-name 'enum) "GEnum") - (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass %enum-value (alien-structure) + (defclass %enum-value (static) ((value :allocation :alien :type int) (name :allocation :alien :type string) (nickname :allocation :alien :type string)) (:metaclass proxy-class))) -(defbinding %enum-class-values () (glist %enum-value) - (class pointer)) - -(defun %query-enum-values (type-number) - (mapcar - #'(lambda (enum-value) - (list - (intern - (substitute - #\- #\_ (string-upcase (slot-value enum-value 'nickname))) "KEYWORD") - (slot-value enum-value 'value))) - (%enum-class-values (type-class-peek type-number)))) - -(defun define-enum-by-query (init-fname &optional name) - (let ((type-number (type-init name init-fname))) - (unless (= (type-parent type-number) (find-type-number 'enum)) - (error "~A is not an enum type" (alien-type-name type-number))) - - (type-class-ref type-number) - (setf (find-type-number name) type-number) - (let ((expanded (cons 'enum (%query-enum-values type-number))) - (name (or name (default-type-name (alien-type-name type-number))))) - (lisp::%deftype - name - #'(lambda (whole) - (unless (zerop (length (cdr whole))) - (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0)) - expanded))))) +(defbinding %enum-class-values () pointer + (class pointer) + (n-values unsigned-int :out)) + +(defun query-enum-values (type) + (%query-enum-or-flags-values #'%enum-class-values '%enum-value type)) + ;;;; Flags type @@ -150,41 +144,46 @@ (deftype-method translate-from-alien flags (type-spec expr &optional weak-ref) (unless (zerop (logand ,expr (first mapping))) (push (second mapping) ,result))))))) -(setf (alien-type-name 'flags) "GFlags") -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass %flags-value (alien-structure) +;(eval-when (:compile-toplevel :load-toplevel :execute) + (defclass %flags-value (static) ((value :allocation :alien :type unsigned-int) (name :allocation :alien :type string) (nickname :allocation :alien :type string)) - (:metaclass proxy-class))) + (:metaclass proxy-class));) + +(defbinding %flags-class-values () pointer + (class pointer) + (n-values unsigned-int :out)) + +(defun query-flags-values (type) + (%query-enum-or-flags-values #'%flags-class-values '%flags-value type)) + + + +;;;; + +(defun expand-enum-type (type-number &optional mappings) + (let* ((super (supertype type-number)) + (type (type-from-number type-number)) + (expanded-mappings + (append + (delete-if + #'(lambda (mapping) + (or + (assoc (first mapping) mappings) + (rassoc (cdr mapping) mappings :test #'equal))) + (if (eq super 'enum) + (query-enum-values type-number) + (query-flags-values type-number))) + (remove-if + #'(lambda (mapping) (eq (second mapping) nil)) mappings)))) + `(progn + (register-type ',type ,(find-type-name type-number)) + (deftype ,type () '(,super ,@expanded-mappings))))) + + +(register-derivable-type 'enum "GEnum" :expand 'expand-enum-type) +(register-derivable-type 'flags "GFlags" :expand 'expand-enum-type) -(defbinding %flags-class-values () (glist %flags-value) - (class pointer)) - -(defun %query-flags-values (type-number) - (mapcar - #'(lambda (flags-value) - (list - (intern - (substitute - #\- #\_ (string-upcase (slot-value flags-value 'nickname))) "KEYWORD") - (slot-value flags-value 'value))) - (%flags-class-values (type-class-peek type-number)))) - -(defun define-flags-by-query (init-fname &optional name) - (let ((type-number (type-init nil init-fname))) - (unless (= (type-parent type-number) (find-type-number 'flags)) - (error "~A is not a flags type" (alien-type-name type-number))) - - (type-class-ref type-number) - (setf (find-type-number name) type-number) - (let ((expanded (cons 'flags (%query-flags-values type-number))) - (name (or name (default-type-name (alien-type-name type-number))))) - (lisp::%deftype - name - #'(lambda (whole) - (unless (zerop (length (cdr whole))) - (lisp::do-arg-count-error 'deftype name (cdr whole) nil 0 0)) - expanded))))) diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 9f560d2..be77962 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.6 2001-04-29 20:34:18 espen Exp $ +;; $Id: gobject.lisp,v 1.7 2001-05-11 16:08:08 espen Exp $ (in-package "GLIB") @@ -35,11 +35,12 @@ (defmethod initialize-instance ((object gobject) &rest initargs) (%gobject-new (type-number-of object))) (call-next-method)) -(defbinding ("g_object_new" %gobject-new) () gobject +(defbinding (%gobject-new "g_object_new") () pointer (type type-number) (nil null)) + ;;;; Parameter stuff (defbinding %object-set-property () nil @@ -92,7 +93,8 @@ (defun object-data (object key &key (test #'eq)) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class)) - (defclass direct-gobject-slot-definition (direct-virtual-slot-definition)) + (defclass direct-gobject-slot-definition (direct-virtual-slot-definition) + ((param :reader slot-definition-param))) (defclass effective-gobject-slot-definition (effective-virtual-slot-definition))) @@ -109,12 +111,12 @@ (defclass effective-gobject-slot-definition (defmethod initialize-instance :after ((slotd direct-gobject-slot-definition) - &rest initargs &key) + &rest initargs &key param) (declare (ignore initargs)) - (unless (slot-boundp slotd 'location) - ;; Find parameter name from slot name - (with-slots (pcl::name location) slotd - (setf location (signal-name-to-string pcl::name))))) + (when param + (setf + (slot-value slotd 'param) + (signal-name-to-string (slot-definition-name slotd))))) (defmethod direct-slot-definition-class ((class gobject-class) initargs) (case (getf initargs :allocation) @@ -126,14 +128,14 @@ (defmethod effective-slot-definition-class ((class gobject-class) initargs) (:param (find-class 'effective-gobject-slot-definition)) (t (call-next-method)))) -(defmethod compute-virtual-slot-location +(defmethod compute-virtual-slot-accessors ((class gobject-class) (slotd effective-gobject-slot-definition) direct-slotds) (with-slots (type) slotd - (let ((param-name (slot-definition-location (first direct-slotds))) + (let ((param-name (slot-definition-param (first direct-slotds))) (type-number (find-type-number type)) - (reader (intern-reader-function type)) - (writer (intern-writer-function type)) + (getter (intern-reader-function type)) + (setter (intern-writer-function type)) (destroy (intern-destroy-function type))) (list #'(lambda (object) @@ -141,19 +143,91 @@ (defmethod compute-virtual-slot-location (let ((gvalue (gvalue-new type-number))) (%object-get-property object param-name gvalue) (prog1 - (funcall reader gvalue +gvalue-value-offset+) + (funcall getter gvalue +gvalue-value-offset+) (gvalue-free gvalue t))))) #'(lambda (value object) (with-gc-disabled (let ((gvalue (gvalue-new type-number))) - (funcall writer value gvalue +gvalue-value-offset+) + (funcall setter value gvalue +gvalue-value-offset+) (%object-set-property object param-name gvalue) (funcall destroy gvalue +gvalue-value-offset+) (gvalue-free gvalue nil) value))))))) - (defmethod validate-superclass ((class gobject-class) (super pcl::standard-class)) (subtypep (class-name super) 'gobject)) - \ No newline at end of file + + + +;;;; + +(defbinding %object-class-properties () pointer + (class pointer) + (n-properties unsigned-int :out)) + +(defun query-object-class-properties (type) + (let ((class (type-class-ref type))) + (multiple-value-bind (array length) + (%object-class-properties class) + (map-c-array 'list #'identity array 'param length)))) + +(defun query-object-class-dependencies (class) + (delete-duplicates + (reduce + #'nconc + (mapcar + #'(lambda (param) + ;; A gobject does not depend on it's supertypes due to forward + ;; referenced superclasses + (delete-if + #'(lambda (type) + (type-is-p class type)) + (type-hierarchy (param-type param)))) + (query-object-class-properties class))))) + + +(defun default-slot-name (name) + (intern (substitute #\- #\_ (string-upcase (string-upcase name))))) + +(defun default-slot-accessor (class-name slot-name type) + (intern + (format + nil "~A-~A~A" class-name slot-name + (if (eq 'boolean type) "-p" "")))) + +(defun expand-gobject-type (type-number &optional slots) + (let* ((super (supertype type-number)) + (class (type-from-number type-number)) + (expanded-slots + (mapcar + #'(lambda (param) + (with-slots (name flags type documentation) param + (let* ((slot-name (default-slot-name name)) + (slot-type (type-from-number type)) + (accessor + (default-slot-accessor class slot-name slot-type))) + `(,slot-name + :allocation :param + :param ,name + ,@(when (member :writable flags) + (list :writer `(setf ,accessor))) + ,@(when (member :readable flags) + (list :reader accessor)) + ,@(when (member :construct flags) + (list :initarg (intern (string slot-name) "KEYWORD"))) + :type ,slot-type + ,@(when documentation + (list :documentation documentation)))))) + (query-object-class-properties type-number)))) + + `(defclass ,class (,super) + ,expanded-slots + (:metaclass gobject-class) + (:alien-name ,(find-type-name type-number))))) + +(register-derivable-type + 'gobject "GObject" + :query 'query-object-class-dependencies + :expand 'expand-gobject-type) + diff --git a/glib/gtype.lisp b/glib/gtype.lisp index 9cd2319..b5c434b 100644 --- a/glib/gtype.lisp +++ b/glib/gtype.lisp @@ -1,5 +1,5 @@ ;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000 Espen S. Johnsen +;; Copyright (C) 2000-2001 Espen S. Johnsen ;; ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public @@ -15,19 +15,18 @@ ;; 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.9 2001-04-30 11:25:25 espen Exp $ +;; $Id: gtype.lisp,v 1.10 2001-05-11 16:04:33 espen Exp $ (in-package "GLIB") (use-prefix "g") - ;;;; (deftype type-number () '(unsigned 32)) (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass type-query (alien-structure) + (defclass type-query (struct) ((type-number :allocation :alien :type type-number) (name :allocation :alien :type string) (class-size :allocation :alien :type unsigned-int) @@ -35,22 +34,13 @@ (defclass type-query (alien-structure) (:metaclass proxy-class))) -(defbinding ("g_type_name" alien-type-name) (type) (static string) - ((find-type-number type) type-number)) - -(defbinding %type-from-name () type-number - (name string)) - -(defbinding type-parent () type-number - (type type-number)) - (defbinding %type-query () nil (type type-number) (query type-query)) (defun type-query (type) (let ((query (make-instance 'type-query))) - (%type-query (find-type-number type) query) + (%type-query (find-type-number type t) query) query)) (defun type-instance-size (type) @@ -59,85 +49,91 @@ (defun type-instance-size (type) (defun type-class-size (type) (slot-value (type-query type) 'class-size)) -(defbinding type-class-ref () pointer - (type type-number)) +(defbinding type-class-ref (type) pointer + ((find-type-number type t) type-number)) -(defbinding type-class-unref () nil - (type type-number)) +(defbinding type-class-unref (type) nil + ((find-type-number type t) type-number)) -(defbinding type-class-peek () pointer - (type type-number)) +(defbinding type-class-peek (type) pointer + ((find-type-number type t) type-number)) -(defbinding type-create-instance (type) pointer - ((find-type-number type) type-number)) - -(defbinding type-free-instance () nil - (instance pointer)) +;;;; Mapping between lisp types and glib types (defvar *type-to-number-hash* (make-hash-table)) (defvar *number-to-type-hash* (make-hash-table)) -(defun type-number-from-alien-name (name &optional (error t)) - (if (string= name "invalid") - 0 - (let ((type-number (%type-from-name name))) - (cond - ((and (zerop type-number) error) - (error "Invalid alien type name: ~A" name)) - ((zerop type-number) nil) - (t type-number))))) - -(defun (setf alien-type-name) (alien-name type) - (let ((type-name (ensure-type-name type)) - (type-number (type-number-from-alien-name alien-name))) - (setf (gethash type-number *number-to-type-hash*) type-name) - (setf (gethash type-name *type-to-number-hash*) type-number))) - -(defun (setf find-type-number) (type-number type) - (setf (gethash (ensure-type-name type) *type-to-number-hash*) type-number)) - -(defun find-type-number (type) +(defun register-type (type id) + (let ((type-number + (etypecase id + (integer id) + (string (find-type-number id t))))) + (setf (gethash type *type-to-number-hash*) type-number) + (setf (gethash type-number *number-to-type-hash*) type) + type-number)) + +(defbinding %type-from-name () type-number + (name string)) + +(defun find-type-number (type &optional error) (etypecase type (integer type) - (symbol (gethash type *type-to-number-hash*)) - (pcl::class (gethash (class-name type) *type-to-number-hash*)))) + (string + (let ((type-number (%type-from-name type))) + (cond + ((and (zerop type-number) error) + (error "Invalid alien type name: ~A" type)) + ((zerop type-number) nil) + (t type-number)))) + (symbol + (let ((type-number (gethash type *type-to-number-hash*))) + (or + type-number + (and error (error "Type not registered: ~A" type))))) + (pcl::class (find-type-number (class-name type) error)))) (defun type-from-number (type-number) (gethash type-number *number-to-type-hash*)) -(defun type-number-of (object) - (find-type-number (type-of object))) +(defun type-from-name (name) + (etypecase name + (string (type-from-number (find-type-number name t))))) -(defun type-init (name &optional init-fname) - (funcall - (mkbinding - (or init-fname (default-alien-fname (format nil "~A_get_type" name))) - 'type-number))) +(defbinding (find-type-name "g_type_name") (type) string + ((find-type-number type t) type-number)) + +(defun type-number-of (object) + (find-type-number (type-of object) t)) + +(defun init-type (init) + (mapc + #'(lambda (fname) + (funcall (mkbinding fname 'type-number))) + (mklist init))) + +(defmacro init-types-in-library (pathname) + (let ((process (ext:run-program + "nm" (list (namestring (truename pathname))) + :output :stream :wait nil)) + (fnames ())) + (labels ((read-symbols () + (let ((line (read-line (ext:process-output process) nil))) + (when line + (when (search "_get_type" line) + (push (subseq line 11) fnames)) + (read-symbols))))) + (read-symbols) + (ext:process-close process) + `(init-type ',fnames)))) ;;;; Superclass for wrapping types in the glib type system (eval-when (:compile-toplevel :load-toplevel :execute) (defclass ginstance (proxy) - () - (:metaclass proxy-class) - (:size 4 #|(size-of 'pointer|#))) - -(defmethod initialize-proxy ((instance ginstance) &rest initargs &key location) - (declare (ignore initargs)) - (setf - (slot-value instance 'location) - (funcall (ginstance-class-ref (class-of instance)) location)) - (call-next-method)) - -(defmethod instance-finalizer ((instance ginstance)) - (let ((location (proxy-location instance)) - (unref (ginstance-class-unref (class-of instance)))) - (declare (type system-area-pointer location)) - #'(lambda () - (funcall unref location) - (remove-cached-instance location)))) + ((class :allocation :alien :type pointer)) + (:metaclass proxy-class))) (defun %type-of-ginstance (location) (let ((class (sap-ref-sap location 0))) @@ -151,77 +147,40 @@ (deftype-method translate-from-alien (ensure-proxy-instance (%type-of-ginstance location) location ,weak-ref)))) -(deftype-method translate-to-alien - ginstance (type-spec object &optional weak-ref) - (declare (ignore type-spec)) - (if weak-ref - `(proxy-location ,object) - `(let ((object ,object)) - (funcall - (ginstance-class-ref (class-of object)) (proxy-location object))))) - -(deftype-method unreference-alien ginstance (type-spec location) - (declare (ignore type-spec)) - `(let* ((location ,location) - (class (find-class (%type-of-ginstance location)))) - (funcall (ginstance-class-unref class) location))) - ;;;; Metaclass for subclasses of ginstance (eval-when (:compile-toplevel :load-toplevel :execute) - (defclass ginstance-class (proxy-class) - ((ref :reader ginstance-class-ref) - (unref :reader ginstance-class-unref)))) + (defclass ginstance-class (proxy-class))) (defmethod shared-initialize ((class ginstance-class) names - &rest initargs - &key name alien-name size - ref unref type-init) + &rest initargs &key name alien-name + size ref unref) (declare (ignore initargs names)) - (call-next-method) - (let* ((class-name (or name (class-name class))) (type-number - (cond - ((and alien-name type-init) - (error - "Specify either :type-init or :alien-name for class ~A" - class-name)) - (alien-name (type-number-from-alien-name (first alien-name))) - (type-init (type-init class-name (first type-init))) - (t - (or - (type-number-from-alien-name - (default-alien-type-name class-name) nil) - (type-init class-name)))))) - (setf (find-type-number class) type-number) - (unless size - (setf - (slot-value class 'size) - (type-instance-size (find-type-number class-name)))) - (when ref + (find-type-number + (or (first alien-name) (default-alien-type-name class-name))))) + (register-type class-name type-number) + (let ((size (or size (type-instance-size type-number)))) + (call-next-method))) + + (when ref + (let ((ref (mkbinding (first ref) 'pointer 'pointer))) (setf - (slot-value class 'ref) - (mkbinding (first ref) 'pointer 'pointer))) - (when unref + (slot-value class 'copy) + #'(lambda (type location) + (declare (ignore type)) + (funcall ref location))))) + (when unref + (let ((unref (mkbinding (first unref) 'nil 'pointer))) (setf - (slot-value class 'unref) - (mkbinding (first unref) 'nil 'pointer))))) - -(defmethod shared-initialize :after ((class ginstance-class) names - &rest initargs) - (declare (ignore names initargs)) - (unless (slot-boundp class 'ref) - (setf - (slot-value class 'ref) - (ginstance-class-ref (most-specific-proxy-superclass class)))) - (unless (slot-boundp class 'unref) - (setf - (slot-value class 'unref) - (ginstance-class-unref (most-specific-proxy-superclass class))))) + (slot-value class 'free) + #'(lambda (type location) + (declare (ignore type)) + (funcall unref location)))))) (defmethod validate-superclass @@ -229,17 +188,132 @@ (defmethod validate-superclass (subtypep (class-name super) 'ginstance)) -;;;; Initializing type numbers - -(setf (alien-type-name 'invalid) "invalid") -(setf (alien-type-name 'char) "gchar") -(setf (alien-type-name 'unsigned-char) "guchar") -(setf (alien-type-name 'boolean) "gboolean") -(setf (alien-type-name 'int) "gint") -(setf (alien-type-name 'unsigned-int) "guint") -(setf (alien-type-name 'long) "glong") -(setf (alien-type-name 'unsigned-long) "gulong") -(setf (alien-type-name 'single-float) "gfloat") -(setf (alien-type-name 'double-float) "gdouble") -(setf (alien-type-name 'string) "GString") -(setf (find-type-number 'fixnum) (find-type-number 'int)) +;;;; Registering fundamental types + +(register-type 'pointer "gpointer") +(register-type 'char "gchar") +(register-type 'unsigned-char "guchar") +(register-type 'boolean "gboolean") +(register-type 'fixnum "gint") +(register-type 'int "gint") +(register-type 'unsigned-int "guint") +(register-type 'long "glong") +(register-type 'unsigned-long "gulong") +(register-type 'single-float "gfloat") +(register-type 'double-float "gdouble") +(register-type 'string "GString") + + +;;;; + +(defvar *derivable-type-info* ()) + +(defun register-derivable-type (type id &key query expand) + (register-type type id) + (let* ((type-number (register-type type id)) + (info (assoc type-number *derivable-type-info*))) + (if info + (setf (cdr info) (list query expand)) + (push + (list type-number query expand) + *derivable-type-info*)))) + +(defun type-dependencies (type) + (let ((query (second (assoc (car (last (type-hierarchy type))) + *derivable-type-info*)))) + (when query + (funcall query (find-type-number type t))))) + +(defun expand-type-definition (type) + (let ((expander (third (assoc (car (last (type-hierarchy type))) + *derivable-type-info*)))) + (funcall expander (find-type-number type t)))) + + +(defbinding type-parent (type) type-number + ((find-type-number type t) type-number)) + +(defun supertype (type) + (type-from-number (type-parent type))) + +(defun type-hierarchy (type) + (let ((type-number (find-type-number type t))) + (unless (= type-number 0) + (cons type-number (type-hierarchy (type-parent type-number)))))) + +(defbinding (type-is-p "g_type_is_a") (type super) boolean + ((find-type-number type) type-number) + ((find-type-number super) type-number)) + +(defbinding %type-children () pointer + (type-number type-number) + (num-children unsigned-int :out)) + +(defun map-subtypes (function type &optional prefix) + (let ((type-number (find-type-number type t))) + (multiple-value-bind (array length) (%type-children type-number) + (unwind-protect + (map-c-array + 'nil + #'(lambda (type-number) + (when (or + (not prefix) + (string-prefix-p prefix (find-type-name type-number))) + (funcall function type-number)) + (map-subtypes function type-number prefix)) + array 'type-number length) + (deallocate-memory array))))) + +(defun find-types (prefix) + (let ((type-list nil)) + (dolist (type-info *derivable-type-info*) + (map-subtypes + #'(lambda (type-number) + (push type-number type-list)) + (first type-info) prefix)) + type-list)) + +(defun %sort-types-topologicaly (unsorted) + (let ((sorted ())) + (loop while unsorted do + (dolist (type unsorted) + (let ((dependencies (type-dependencies type))) + (cond + ((null dependencies) + (push type sorted) + (setq unsorted (delete type unsorted))) + (t + (unless (dolist (dep dependencies) + (when (find type (type-dependencies dep)) + (error "Cyclic type dependencies not yet supported")) + (return-if (find dep unsorted))) + (push type sorted) + (setq unsorted (delete type unsorted)))))))) + (nreverse sorted))) + + +(defun expand-type-definitions (prefix &optional args) + (flet ((type-options (type-number) + (let ((name (find-type-name type-number))) + (cdr (assoc name argss :test #'string=))))) + + (let ((type-list + (delete-if + #'(lambda (type-number) + (getf (type-options type-number) :ignore nil)) + (find-types prefix)))) + + (dolist (type-number type-list) + (let ((name (find-type-name type-number))) + (register-type + (getf (type-options type-number) :type (default-type-name name)) + type-number))) + + `(progn + ,@(mapcar + #'expand-type-definition + (%sort-types-topologicaly type-list)))))) + +(defmacro define-types-by-introspection (prefix &rest args) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,(expand-type-definitions prefix args))) \ No newline at end of file -- [mdw]