[clg] / glib / gtype.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; 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.12 2001-10-21 21:50:18 espen Exp $

(in-package "GLIB")

(use-prefix "g")

;;;; 

(deftype type-number () '(unsigned 32))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass type-query (struct)
    ((type-number :allocation :alien :type type-number)
     (name :allocation :alien :type string)
     (class-size :allocation :alien :type unsigned-int)
     (instance-size :allocation :alien :type unsigned-int))
    (:metaclass proxy-class)))


(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 t) query)
    query))

(defun type-instance-size (type)
  (slot-value (type-query type) 'instance-size))

(defun type-class-size (type)
  (slot-value (type-query type) 'class-size))

(defbinding type-class-ref (type) pointer
  ((find-type-number type t) type-number))

(defbinding type-class-unref (type) nil
  ((find-type-number type t) type-number))

(defbinding type-class-peek (type) pointer
  ((find-type-number type t) type-number))


;;;; Mapping between lisp types and glib types

(defvar *type-to-number-hash* (make-hash-table))
(defvar *number-to-type-hash* (make-hash-table))

(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)
    (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 &optional error)
  (multiple-value-bind (type found)
      (gethash type-number *number-to-type-hash*)
    (when (and error (not found))
      (let ((name (find-type-name type-number)))
	(if name
	    (error "Type number not registered: ~A (~A)" type-number name)
	  (error "Invalid type number: ~A" type-number))))
    type))

(defun type-from-name (name)
  (etypecase name
    (string (type-from-number (find-type-number name t)))))

(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)))

(defun %init-types-in-library (pathname ignore)
  (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
		   (let ((symbol (subseq line 11)))
		     (when (and
			    (search "_get_type" symbol)
			    (not (member symbol ignore :test #'string=)))
		       (push symbol fnames)))
		   (read-symbols)))))
      (read-symbols)
      (ext:process-close process)
      `(init-type ',fnames))))

(defmacro init-types-in-library (pathname &key ignore)
  (%init-types-in-library pathname ignore))


;;;; Superclass for wrapping types in the glib type system

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass ginstance (proxy)
    ((class :allocation :alien :type pointer))
    (:metaclass proxy-class)))

(defun %type-of-ginstance (location)
  (let ((class (sap-ref-sap location 0)))
    (type-from-number (sap-ref-unsigned class 0))))

(deftype-method translate-from-alien
    ginstance (type-spec location &optional weak-ref)
  (declare (ignore type-spec))
  `(let ((location ,location))
     (unless (null-pointer-p location)
       (ensure-proxy-instance
	(%type-of-ginstance location) location ,weak-ref))))


;;;; Metaclass for subclasses of ginstance

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defclass ginstance-class (proxy-class)))


(defmethod shared-initialize ((class ginstance-class) names
			      &rest initargs &key name alien-name
			      size ref unref)
  (declare (ignore initargs names))
  (let* ((class-name (or name (class-name class)))
	 (type-number
	  (find-type-number
	   (or (first alien-name) (default-alien-type-name class-name)) t)))
    (register-type class-name type-number)
    (let ((size (or size (type-instance-size type-number))))
      (declare (special size))
      (call-next-method)))

  (when ref
    (let ((ref (mkbinding (first ref) 'pointer 'pointer)))
      (setf
       (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 'free)
       #'(lambda (type location)
	   (declare (ignore type))
	   (funcall unref location))))))


(defmethod validate-superclass
    ((class ginstance-class) (super pcl::standard-class))
  (subtypep (class-name super) 'ginstance))


;;;; 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 "gchararray")


;;;; 

(defvar *derivable-type-info* (make-hash-table))

(defun register-derivable-type (type id expander)
  (register-type type id)
  (let ((type-number (register-type type id)))
    (setf (gethash type-number *derivable-type-info*) expander)))

(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)))

(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))
    (maphash
     #'(lambda (type-number expander)
	 (declare (ignore expander))
	 (map-subtypes
	  #'(lambda (type-number)
	      (pushnew type-number type-list))
	  type-number prefix))
     *derivable-type-info*)
    type-list))

(defun %sort-types-topologicaly (unsorted)
  (let ((sorted ()))
    (loop while unsorted do
      (dolist (type unsorted)
	(let ((dependencies (rest (type-hierarchy type))))
	  (cond
	   ((null 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)))


(defun expand-type-definitions (prefix &optional args)
 (flet ((type-options (type-number)
	   (let ((name (find-type-name type-number)))
	     (cdr (assoc name args :test #'string=)))))

   (let ((type-list
	  (delete-if
	   #'(lambda (type-number)
	       (let ((name (find-type-name type-number)))
		 (or
		  (getf (type-options type-number) :ignore)
		  (find-if
		   #'(lambda (options)
		       (and
			(string-prefix-p (first options) name)
			(getf (cdr options) :ignore-prefix)))
		   args))))
	   (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
	   #'(lambda (type)
	       (expand-type-definition type (type-options type)))
	   (%sort-types-topologicaly type-list))))))

(defmacro define-types-by-introspection (prefix &rest args)
  (expand-type-definitions prefix args))
Commit	Line	Data
560af5c5	1	;; Common Lisp bindings for GTK+ v2.0
d4b21b08	2	;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
560af5c5	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
e77e7713	18	;; $Id: gtype.lisp,v 1.12 2001-10-21 21:50:18 espen Exp $
560af5c5	19
	20	(in-package "GLIB")
	21
	22	(use-prefix "g")
	23
560af5c5	24	;;;;
	25
	26	(deftype type-number () '(unsigned 32))
	27
93aa67db	28	(eval-when (:compile-toplevel :load-toplevel :execute)
d4b21b08	29	(defclass type-query (struct)
93aa67db	30	((type-number :allocation :alien :type type-number)
	31	(name :allocation :alien :type string)
	32	(class-size :allocation :alien :type unsigned-int)
	33	(instance-size :allocation :alien :type unsigned-int))
	34	(:metaclass proxy-class)))
	35
	36
93aa67db	37	(defbinding %type-query () nil
	38	(type type-number)
	39	(query type-query))
	40
	41	(defun type-query (type)
	42	(let ((query (make-instance 'type-query)))
d4b21b08	43	(%type-query (find-type-number type t) query)
93aa67db	44	query))
	45
	46	(defun type-instance-size (type)
	47	(slot-value (type-query type) 'instance-size))
	48
	49	(defun type-class-size (type)
	50	(slot-value (type-query type) 'class-size))
560af5c5	51
d4b21b08	52	(defbinding type-class-ref (type) pointer
d4b21b08	53	((find-type-number type t) type-number))
560af5c5	54
d4b21b08	55	(defbinding type-class-unref (type) nil
d4b21b08	56	((find-type-number type t) type-number))
93aa67db	57
d4b21b08	58	(defbinding type-class-peek (type) pointer
d4b21b08	59	((find-type-number type t) type-number))
93aa67db	60
560af5c5	61
d4b21b08	62	;;;; Mapping between lisp types and glib types
560af5c5	63
	64	(defvar type-to-number-hash (make-hash-table))
	65	(defvar number-to-type-hash (make-hash-table))
	66
d4b21b08	67	(defun register-type (type id)
	68	(let ((type-number
	69	(etypecase id
	70	(integer id)
	71	(string (find-type-number id t)))))
	72	(setf (gethash type type-to-number-hash) type-number)
	73	(setf (gethash type-number number-to-type-hash) type)
	74	type-number))
	75
	76	(defbinding %type-from-name () type-number
	77	(name string))
	78
	79	(defun find-type-number (type &optional error)
560af5c5	80	(etypecase type
560af5c5	81	(integer type)
d4b21b08	82	(string
	83	(let ((type-number (%type-from-name type)))
	84	(cond
	85	((and (zerop type-number) error)
	86	(error "Invalid alien type name: ~A" type))
	87	((zerop type-number) nil)
	88	(t type-number))))
	89	(symbol
	90	(let ((type-number (gethash type type-to-number-hash)))
	91	(or
	92	type-number
	93	(and error (error "Type not registered: ~A" type)))))
	94	(pcl::class (find-type-number (class-name type) error))))
560af5c5	95
4de90d10	96	(defun type-from-number (type-number &optional error)
	97	(multiple-value-bind (type found)
	98	(gethash type-number number-to-type-hash)
	99	(when (and error (not found))
	100	(let ((name (find-type-name type-number)))
	101	(if name
	102	(error "Type number not registered: ~A (~A)" type-number name)
	103	(error "Invalid type number: ~A" type-number))))
	104	type))
560af5c5	105
d4b21b08	106	(defun type-from-name (name)
	107	(etypecase name
	108	(string (type-from-number (find-type-number name t)))))
560af5c5	109
d4b21b08	110	(defbinding (find-type-name "g_type_name") (type) string
	111	((find-type-number type t) type-number))
	112
	113	(defun type-number-of (object)
	114	(find-type-number (type-of object) t))
	115
	116	(defun init-type (init)
	117	(mapc
	118	#'(lambda (fname)
	119	(funcall (mkbinding fname 'type-number)))
	120	(mklist init)))
	121
4de90d10	122	(defun %init-types-in-library (pathname ignore)
d4b21b08	123	(let ((process (ext:run-program
	124	"nm" (list (namestring (truename pathname)))
	125	:output :stream :wait nil))
	126	(fnames ()))
	127	(labels ((read-symbols ()
	128	(let ((line (read-line (ext:process-output process) nil)))
	129	(when line
4de90d10	130	(let ((symbol (subseq line 11)))
	131	(when (and
	132	(search "_get_type" symbol)
	133	(not (member symbol ignore :test #'string=)))
	134	(push symbol fnames)))
d4b21b08	135	(read-symbols)))))
	136	(read-symbols)
	137	(ext:process-close process)
	138	`(init-type ',fnames))))
560af5c5	139
4de90d10	140	(defmacro init-types-in-library (pathname &key ignore)
	141	(%init-types-in-library pathname ignore))
	142
	143
560af5c5	144
93aa67db	145	;;;; Superclass for wrapping types in the glib type system
560af5c5	146
560af5c5	147	(eval-when (:compile-toplevel :load-toplevel :execute)
93aa67db	148	(defclass ginstance (proxy)
d4b21b08	149	((class :allocation :alien :type pointer))
d4b21b08	150	(:metaclass proxy-class)))
560af5c5	151
93aa67db	152	(defun %type-of-ginstance (location)
	153	(let ((class (sap-ref-sap location 0)))
	154	(type-from-number (sap-ref-unsigned class 0))))
560af5c5	155
560af5c5	156	(deftype-method translate-from-alien
93aa67db	157	ginstance (type-spec location &optional weak-ref)
93aa67db	158	(declare (ignore type-spec))
560af5c5	159	`(let ((location ,location))
560af5c5	160	(unless (null-pointer-p location)
93aa67db	161	(ensure-proxy-instance
93aa67db	162	(%type-of-ginstance location) location ,weak-ref))))
560af5c5	163
560af5c5	164
560af5c5	165
93aa67db	166	;;;; Metaclass for subclasses of ginstance
560af5c5	167
560af5c5	168	(eval-when (:compile-toplevel :load-toplevel :execute)
d4b21b08	169	(defclass ginstance-class (proxy-class)))
560af5c5	170
560af5c5	171
c8c48a4c	172	(defmethod shared-initialize ((class ginstance-class) names
d4b21b08	173	&rest initargs &key name alien-name
d4b21b08	174	size ref unref)
560af5c5	175	(declare (ignore initargs names))
93aa67db	176	(let* ((class-name (or name (class-name class)))
93aa67db	177	(type-number
d4b21b08	178	(find-type-number
4de90d10	179	(or (first alien-name) (default-alien-type-name class-name)) t)))
d4b21b08	180	(register-type class-name type-number)
d4b21b08	181	(let ((size (or size (type-instance-size type-number))))
4de90d10	182	(declare (special size))
d4b21b08	183	(call-next-method)))
	184
	185	(when ref
	186	(let ((ref (mkbinding (first ref) 'pointer 'pointer)))
93aa67db	187	(setf
d4b21b08	188	(slot-value class 'copy)
	189	#'(lambda (type location)
	190	(declare (ignore type))
	191	(funcall ref location)))))
	192	(when unref
	193	(let ((unref (mkbinding (first unref) 'nil 'pointer)))
93aa67db	194	(setf
d4b21b08	195	(slot-value class 'free)
	196	#'(lambda (type location)
	197	(declare (ignore type))
	198	(funcall unref location))))))
560af5c5	199
	200
	201	(defmethod validate-superclass
c8c48a4c	202	((class ginstance-class) (super pcl::standard-class))
c8c48a4c	203	(subtypep (class-name super) 'ginstance))
560af5c5	204
560af5c5	205
d4b21b08	206	;;;; Registering fundamental types
	207
	208	(register-type 'pointer "gpointer")
	209	(register-type 'char "gchar")
	210	(register-type 'unsigned-char "guchar")
	211	(register-type 'boolean "gboolean")
	212	(register-type 'fixnum "gint")
	213	(register-type 'int "gint")
	214	(register-type 'unsigned-int "guint")
	215	(register-type 'long "glong")
	216	(register-type 'unsigned-long "gulong")
	217	(register-type 'single-float "gfloat")
	218	(register-type 'double-float "gdouble")
4de90d10	219	(register-type 'string "gchararray")
d4b21b08	220
	221
	222	;;;;
	223
e77e7713	224	(defvar derivable-type-info (make-hash-table))
d4b21b08	225
e77e7713	226	(defun register-derivable-type (type id expander)
d4b21b08	227	(register-type type id)
e77e7713	228	(let ((type-number (register-type type id)))
e77e7713	229	(setf (gethash type-number derivable-type-info) expander)))
d4b21b08	230
4de90d10	231	(defun find-type-info (type)
4de90d10	232	(dolist (super (cdr (type-hierarchy type)))
e77e7713	233	(let ((info (gethash super derivable-type-info)))
4de90d10	234	(return-if info))))
4de90d10	235
e77e7713	236	(defun expand-type-definition (type options)
	237	(let ((expander (find-type-info type)))
	238	(funcall expander (find-type-number type t) options)))
d4b21b08	239
d4b21b08	240	(defbinding type-parent (type) type-number
	241	((find-type-number type t) type-number))
	242
	243	(defun supertype (type)
	244	(type-from-number (type-parent type)))
	245
	246	(defun type-hierarchy (type)
	247	(let ((type-number (find-type-number type t)))
	248	(unless (= type-number 0)
	249	(cons type-number (type-hierarchy (type-parent type-number))))))
	250
	251	(defbinding (type-is-p "g_type_is_a") (type super) boolean
	252	((find-type-number type) type-number)
	253	((find-type-number super) type-number))
	254
	255	(defbinding %type-children () pointer
	256	(type-number type-number)
	257	(num-children unsigned-int :out))
	258
	259	(defun map-subtypes (function type &optional prefix)
	260	(let ((type-number (find-type-number type t)))
	261	(multiple-value-bind (array length) (%type-children type-number)
	262	(unwind-protect
	263	(map-c-array
	264	'nil
	265	#'(lambda (type-number)
	266	(when (or
	267	(not prefix)
	268	(string-prefix-p prefix (find-type-name type-number)))
	269	(funcall function type-number))
	270	(map-subtypes function type-number prefix))
	271	array 'type-number length)
	272	(deallocate-memory array)))))
	273
	274	(defun find-types (prefix)
	275	(let ((type-list nil))
e77e7713	276	(maphash
	277	#'(lambda (type-number expander)
	278	(declare (ignore expander))
	279	(map-subtypes
	280	#'(lambda (type-number)
	281	(pushnew type-number type-list))
	282	type-number prefix))
	283	derivable-type-info)
d4b21b08	284	type-list))
	285
	286	(defun %sort-types-topologicaly (unsorted)
	287	(let ((sorted ()))
	288	(loop while unsorted do
	289	(dolist (type unsorted)
e77e7713	290	(let ((dependencies (rest (type-hierarchy type))))
d4b21b08	291	(cond
	292	((null dependencies)
	293	(push type sorted)
	294	(setq unsorted (delete type unsorted)))
	295	(t
	296	(unless (dolist (dep dependencies)
e77e7713	297	(when (find type (rest (type-hierarchy dep)))
e77e7713	298	(error "Cyclic type dependencie"))
d4b21b08	299	(return-if (find dep unsorted)))
	300	(push type sorted)
	301	(setq unsorted (delete type unsorted))))))))
	302	(nreverse sorted)))
	303
	304
	305	(defun expand-type-definitions (prefix &optional args)
e77e7713	306	(flet ((type-options (type-number)
d4b21b08	307	(let ((name (find-type-name type-number)))
4de90d10	308	(cdr (assoc name args :test #'string=)))))
d4b21b08	309
e77e7713	310	(let ((type-list
	311	(delete-if
	312	#'(lambda (type-number)
	313	(let ((name (find-type-name type-number)))
	314	(or
	315	(getf (type-options type-number) :ignore)
	316	(find-if
	317	#'(lambda (options)
	318	(and
	319	(string-prefix-p (first options) name)
	320	(getf (cdr options) :ignore-prefix)))
	321	args))))
	322	(find-types prefix))))
d4b21b08	323
e77e7713	324	(dolist (type-number type-list)
	325	(let ((name (find-type-name type-number)))
	326	(register-type
	327	(getf (type-options type-number) :type (default-type-name name))
	328	type-number)))
	329
	330	`(progn
	331	,@(mapcar
	332	#'(lambda (type)
	333	(expand-type-definition type (type-options type)))
	334	(%sort-types-topologicaly type-list))))))
	335
d4b21b08	336	(defmacro define-types-by-introspection (prefix &rest args)
4de90d10	337	(expand-type-definitions prefix args))
e77e7713	338
	339
	340