chiark - git - mdw - clg/blob - glib/gtype.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   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
  18 ;; $Id: gtype.lisp,v 1.10 2001/05/11 16:04:33 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 (use-prefix "g")
  23
  24 ;;;;
  25
  26 (deftype type-number () '(unsigned 32))
  27
  28 (eval-when (:compile-toplevel :load-toplevel :execute)
  29   (defclass type-query (struct)
  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
  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)))
  43     (%type-query (find-type-number type t) query)
  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))
  51
  52 (defbinding type-class-ref (type) pointer
  53   ((find-type-number type t) type-number))
  54
  55 (defbinding type-class-unref (type) nil
  56   ((find-type-number type t) type-number))
  57
  58 (defbinding type-class-peek (type) pointer
  59   ((find-type-number type t) type-number))
  60
  61
  62 ;;;; Mapping between lisp types and glib types
  63
  64 (defvar *type-to-number-hash* (make-hash-table))
  65 (defvar *number-to-type-hash* (make-hash-table))
  66
  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)
  80   (etypecase type
  81     (integer type)
  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))))
  95
  96 (defun type-from-number (type-number)
  97   (gethash type-number *number-to-type-hash*))
  98
  99 (defun type-from-name (name)
 100   (etypecase name
 101     (string (type-from-number (find-type-number name t)))))
 102
 103 (defbinding (find-type-name "g_type_name") (type) string
 104   ((find-type-number type t) type-number))
 105
 106 (defun type-number-of (object)
 107   (find-type-number (type-of object) t))
 108
 109 (defun init-type (init)
 110   (mapc
 111    #'(lambda (fname)
 112        (funcall (mkbinding fname 'type-number)))
 113    (mklist init)))
 114
 115 (defmacro init-types-in-library (pathname)
 116   (let ((process (ext:run-program
 117                   "nm" (list (namestring (truename pathname)))
 118                   :output :stream :wait nil))
 119         (fnames ()))
 120     (labels ((read-symbols ()
 121                (let ((line (read-line (ext:process-output process) nil)))
 122                  (when line
 123                    (when (search "_get_type" line)
 124                      (push (subseq line 11) fnames))
 125                    (read-symbols)))))
 126       (read-symbols)
 127       (ext:process-close process)
 128       `(init-type ',fnames))))
 129
 130
 131 ;;;; Superclass for wrapping types in the glib type system
 132
 133 (eval-when (:compile-toplevel :load-toplevel :execute)
 134   (defclass ginstance (proxy)
 135     ((class :allocation :alien :type pointer))
 136     (:metaclass proxy-class)))
 137
 138 (defun %type-of-ginstance (location)
 139   (let ((class (sap-ref-sap location 0)))
 140     (type-from-number (sap-ref-unsigned class 0))))
 141
 142 (deftype-method translate-from-alien
 143     ginstance (type-spec location &optional weak-ref)
 144   (declare (ignore type-spec))
 145   `(let ((location ,location))
 146      (unless (null-pointer-p location)
 147        (ensure-proxy-instance
 148         (%type-of-ginstance location) location ,weak-ref))))
 149
 150
 151
 152 ;;;; Metaclass for subclasses of ginstance
 153
 154 (eval-when (:compile-toplevel :load-toplevel :execute)
 155   (defclass ginstance-class (proxy-class)))
 156
 157
 158 (defmethod shared-initialize ((class ginstance-class) names
 159                               &rest initargs &key name alien-name
 160                               size ref unref)
 161   (declare (ignore initargs names))
 162   (let* ((class-name (or name (class-name class)))
 163          (type-number
 164           (find-type-number
 165            (or (first alien-name) (default-alien-type-name class-name)))))
 166     (register-type class-name type-number)
 167     (let ((size (or size (type-instance-size type-number))))
 168       (call-next-method)))
 169
 170   (when ref
 171     (let ((ref (mkbinding (first ref) 'pointer 'pointer)))
 172       (setf
 173        (slot-value class 'copy)
 174        #'(lambda (type location)
 175            (declare (ignore type))
 176            (funcall ref location)))))
 177   (when unref
 178     (let ((unref (mkbinding (first unref) 'nil 'pointer)))
 179       (setf
 180        (slot-value class 'free)
 181        #'(lambda (type location)
 182            (declare (ignore type))
 183            (funcall unref location))))))
 184
 185
 186 (defmethod validate-superclass
 187     ((class ginstance-class) (super pcl::standard-class))
 188   (subtypep (class-name super) 'ginstance))
 189
 190
 191 ;;;; Registering fundamental types
 192
 193 (register-type 'pointer "gpointer")
 194 (register-type 'char "gchar")
 195 (register-type 'unsigned-char "guchar")
 196 (register-type 'boolean "gboolean")
 197 (register-type 'fixnum "gint")
 198 (register-type 'int "gint")
 199 (register-type 'unsigned-int "guint")
 200 (register-type 'long "glong")
 201 (register-type 'unsigned-long "gulong")
 202 (register-type 'single-float "gfloat")
 203 (register-type 'double-float "gdouble")
 204 (register-type 'string "GString")
 205
 206
 207 ;;;;
 208
 209 (defvar *derivable-type-info* ())
 210
 211 (defun register-derivable-type (type id &key query expand)
 212   (register-type type id)
 213   (let* ((type-number (register-type type id))
 214          (info (assoc type-number *derivable-type-info*)))
 215     (if info
 216         (setf (cdr info) (list query expand))
 217       (push
 218        (list type-number query expand)
 219        *derivable-type-info*))))
 220
 221 (defun type-dependencies (type)
 222   (let ((query (second (assoc (car (last (type-hierarchy type)))
 223                               *derivable-type-info*))))
 224     (when query
 225       (funcall query (find-type-number type t)))))
 226
 227 (defun expand-type-definition (type)
 228   (let ((expander (third (assoc (car (last (type-hierarchy type)))
 229                                 *derivable-type-info*))))
 230     (funcall expander (find-type-number type t))))
 231
 232
 233 (defbinding type-parent (type) type-number
 234   ((find-type-number type t) type-number))
 235
 236 (defun supertype (type)
 237   (type-from-number (type-parent type)))
 238
 239 (defun type-hierarchy (type)
 240   (let ((type-number (find-type-number type t)))
 241     (unless (= type-number 0)
 242       (cons type-number (type-hierarchy (type-parent type-number))))))
 243
 244 (defbinding (type-is-p "g_type_is_a") (type super) boolean
 245   ((find-type-number type) type-number)
 246   ((find-type-number super) type-number))
 247
 248 (defbinding %type-children () pointer
 249   (type-number type-number)
 250   (num-children unsigned-int :out))
 251
 252 (defun map-subtypes (function type &optional prefix)
 253   (let ((type-number (find-type-number type t)))
 254     (multiple-value-bind (array length) (%type-children type-number)
 255       (unwind-protect
 256           (map-c-array
 257            'nil
 258            #'(lambda (type-number)
 259                (when (or
 260                       (not prefix)
 261                       (string-prefix-p prefix (find-type-name type-number)))
 262                  (funcall function type-number))
 263                (map-subtypes function type-number prefix))
 264            array 'type-number length)
 265         (deallocate-memory array)))))
 266
 267 (defun find-types (prefix)
 268   (let ((type-list nil))
 269     (dolist (type-info *derivable-type-info*)
 270       (map-subtypes
 271        #'(lambda (type-number)
 272            (push type-number type-list))
 273        (first type-info) prefix))
 274     type-list))
 275
 276 (defun %sort-types-topologicaly (unsorted)
 277   (let ((sorted ()))
 278     (loop while unsorted do
 279       (dolist (type unsorted)
 280         (let ((dependencies (type-dependencies type)))
 281           (cond
 282            ((null dependencies)
 283             (push type sorted)
 284             (setq unsorted (delete type unsorted)))
 285            (t
 286             (unless (dolist (dep dependencies)
 287                       (when (find type (type-dependencies dep))
 288                         (error "Cyclic type dependencies not yet supported"))
 289                       (return-if (find dep unsorted)))
 290               (push type sorted)
 291               (setq unsorted (delete type unsorted))))))))
 292     (nreverse sorted)))
 293
 294
 295 (defun expand-type-definitions (prefix &optional args)
 296   (flet ((type-options (type-number)
 297            (let ((name (find-type-name type-number)))
 298              (cdr (assoc name argss :test #'string=)))))
 299
 300     (let ((type-list
 301            (delete-if
 302             #'(lambda (type-number)
 303                 (getf (type-options type-number) :ignore nil))
 304             (find-types prefix))))
 305
 306       (dolist (type-number type-list)
 307         (let ((name (find-type-name type-number)))
 308           (register-type
 309            (getf (type-options type-number) :type (default-type-name name))
 310            type-number)))
 311
 312       `(progn
 313          ,@(mapcar
 314             #'expand-type-definition
 315             (%sort-types-topologicaly type-list))))))
 316
 317 (defmacro define-types-by-introspection (prefix &rest args)
 318   `(eval-when (:compile-toplevel :load-toplevel :execute)
 319      ,(expand-type-definitions prefix args)))