[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
0d07716f	1	;; Common Lisp bindings for GTK+ v2.0
3a935dfa	2	;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
0d07716f	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
4812615b	18	;; $Id: gtype.lisp,v 1.12 2001/10/21 21:50:18 espen Exp $
0d07716f	19
	20	(in-package "GLIB")
	21
	22	(use-prefix "g")
	23
0d07716f	24	;;;;
	25
	26	(deftype type-number () '(unsigned 32))
	27
fc47a022	28	(eval-when (:compile-toplevel :load-toplevel :execute)
3a935dfa	29	(defclass type-query (struct)
fc47a022	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
fc47a022	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)))
3a935dfa	43	(%type-query (find-type-number type t) query)
fc47a022	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))
0d07716f	51
3a935dfa	52	(defbinding type-class-ref (type) pointer
3a935dfa	53	((find-type-number type t) type-number))
0d07716f	54
3a935dfa	55	(defbinding type-class-unref (type) nil
3a935dfa	56	((find-type-number type t) type-number))
fc47a022	57
3a935dfa	58	(defbinding type-class-peek (type) pointer
3a935dfa	59	((find-type-number type t) type-number))
fc47a022	60
0d07716f	61
3a935dfa	62	;;;; Mapping between lisp types and glib types
0d07716f	63
	64	(defvar type-to-number-hash (make-hash-table))
	65	(defvar number-to-type-hash (make-hash-table))
	66
3a935dfa	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)
0d07716f	80	(etypecase type
0d07716f	81	(integer type)
3a935dfa	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))))
0d07716f	95
b011356b	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))
0d07716f	105
3a935dfa	106	(defun type-from-name (name)
	107	(etypecase name
	108	(string (type-from-number (find-type-number name t)))))
0d07716f	109
3a935dfa	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
b011356b	122	(defun %init-types-in-library (pathname ignore)
3a935dfa	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
b011356b	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)))
3a935dfa	135	(read-symbols)))))
	136	(read-symbols)
	137	(ext:process-close process)
	138	`(init-type ',fnames))))
0d07716f	139
b011356b	140	(defmacro init-types-in-library (pathname &key ignore)
	141	(%init-types-in-library pathname ignore))
	142
	143
0d07716f	144
fc47a022	145	;;;; Superclass for wrapping types in the glib type system
0d07716f	146
0d07716f	147	(eval-when (:compile-toplevel :load-toplevel :execute)
fc47a022	148	(defclass ginstance (proxy)
3a935dfa	149	((class :allocation :alien :type pointer))
3a935dfa	150	(:metaclass proxy-class)))
0d07716f	151
fc47a022	152	(defun %type-of-ginstance (location)
	153	(let ((class (sap-ref-sap location 0)))
	154	(type-from-number (sap-ref-unsigned class 0))))
0d07716f	155
0d07716f	156	(deftype-method translate-from-alien
fc47a022	157	ginstance (type-spec location &optional weak-ref)
fc47a022	158	(declare (ignore type-spec))
0d07716f	159	`(let ((location ,location))
0d07716f	160	(unless (null-pointer-p location)
fc47a022	161	(ensure-proxy-instance
fc47a022	162	(%type-of-ginstance location) location ,weak-ref))))
0d07716f	163
0d07716f	164
0d07716f	165
fc47a022	166	;;;; Metaclass for subclasses of ginstance
0d07716f	167
0d07716f	168	(eval-when (:compile-toplevel :load-toplevel :execute)
3a935dfa	169	(defclass ginstance-class (proxy-class)))
0d07716f	170
0d07716f	171
c9819f3e	172	(defmethod shared-initialize ((class ginstance-class) names
3a935dfa	173	&rest initargs &key name alien-name
3a935dfa	174	size ref unref)
0d07716f	175	(declare (ignore initargs names))
fc47a022	176	(let* ((class-name (or name (class-name class)))
fc47a022	177	(type-number
3a935dfa	178	(find-type-number
b011356b	179	(or (first alien-name) (default-alien-type-name class-name)) t)))
3a935dfa	180	(register-type class-name type-number)
3a935dfa	181	(let ((size (or size (type-instance-size type-number))))
b011356b	182	(declare (special size))
3a935dfa	183	(call-next-method)))
	184
	185	(when ref
	186	(let ((ref (mkbinding (first ref) 'pointer 'pointer)))
fc47a022	187	(setf
3a935dfa	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)))
fc47a022	194	(setf
3a935dfa	195	(slot-value class 'free)
	196	#'(lambda (type location)
	197	(declare (ignore type))
	198	(funcall unref location))))))
0d07716f	199
	200
	201	(defmethod validate-superclass
c9819f3e	202	((class ginstance-class) (super pcl::standard-class))
c9819f3e	203	(subtypep (class-name super) 'ginstance))
0d07716f	204
0d07716f	205
3a935dfa	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")
b011356b	219	(register-type 'string "gchararray")
3a935dfa	220
	221
	222	;;;;
	223
4812615b	224	(defvar derivable-type-info (make-hash-table))
3a935dfa	225
4812615b	226	(defun register-derivable-type (type id expander)
3a935dfa	227	(register-type type id)
4812615b	228	(let ((type-number (register-type type id)))
4812615b	229	(setf (gethash type-number derivable-type-info) expander)))
3a935dfa	230
b011356b	231	(defun find-type-info (type)
b011356b	232	(dolist (super (cdr (type-hierarchy type)))
4812615b	233	(let ((info (gethash super derivable-type-info)))
b011356b	234	(return-if info))))
b011356b	235
4812615b	236	(defun expand-type-definition (type options)
	237	(let ((expander (find-type-info type)))
	238	(funcall expander (find-type-number type t) options)))
3a935dfa	239
3a935dfa	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))
4812615b	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)
3a935dfa	284	type-list))
	285
	286	(defun %sort-types-topologicaly (unsorted)
	287	(let ((sorted ()))
	288	(loop while unsorted do
	289	(dolist (type unsorted)
4812615b	290	(let ((dependencies (rest (type-hierarchy type))))
3a935dfa	291	(cond
	292	((null dependencies)
	293	(push type sorted)
	294	(setq unsorted (delete type unsorted)))
	295	(t
	296	(unless (dolist (dep dependencies)
4812615b	297	(when (find type (rest (type-hierarchy dep)))
4812615b	298	(error "Cyclic type dependencie"))
3a935dfa	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)
4812615b	306	(flet ((type-options (type-number)
3a935dfa	307	(let ((name (find-type-name type-number)))
b011356b	308	(cdr (assoc name args :test #'string=)))))
3a935dfa	309
4812615b	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))))
3a935dfa	323
4812615b	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
3a935dfa	336	(defmacro define-types-by-introspection (prefix &rest args)
b011356b	337	(expand-type-definitions prefix args))
4812615b	338
	339
	340