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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2001 Espen S. Johnsen <espen@users.sourceforge.net>
   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: ginterface.lisp,v 1.9 2005-03-06 17:26:23 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 (use-prefix "g")
  23
  24 ;;;;
  25
  26 (defclass ginterface ()
  27   ())
  28
  29 ;;;; Metaclass for interfaces
  30
  31 (eval-when (:compile-toplevel :load-toplevel :execute)
  32   (defclass ginterface-class (virtual-slots-class)
  33     ()))
  34
  35 (defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
  36   (case (getf initargs :allocation)
  37     (:property (find-class 'direct-property-slot-definition))
  38     (t (call-next-method))))
  39
  40 (defmethod effective-slot-definition-class ((class ginterface-class) &rest initargs)
  41   (case (getf initargs :allocation)
  42     (:property (find-class 'effective-property-slot-definition))
  43     (t (call-next-method))))
  44
  45 (defmethod compute-effective-slot-definition-initargs ((class ginterface-class) direct-slotds)
  46   (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
  47       (nconc
  48        (list :pname (signal-name-to-string
  49                      (most-specific-slot-value direct-slotds 'pname))
  50              :readable (most-specific-slot-value direct-slotds 'readable)
  51              :writable (most-specific-slot-value direct-slotds 'writable)
  52              :construct (most-specific-slot-value direct-slotds 'construct))
  53        (call-next-method))
  54     (call-next-method)))
  55
  56
  57 (defmethod shared-initialize ((class ginterface-class) names &key name gtype)
  58   (declare (ignore names))
  59   (let ((class-name (or name (class-name class))))
  60     (unless (find-type-number class-name)
  61       (register-type class-name
  62         (or (first gtype) (default-type-init-name class-name)))))
  63   (call-next-method))
  64
  65
  66 (defmethod validate-superclass ((class ginterface-class) (super standard-class))
  67   (subtypep (class-name super) 'ginterface))
  68
  69
  70 (defmethod alien-type ((class ginterface-class) &rest args)
  71   (declare (ignore class args))
  72   (alien-type 'gobject))
  73
  74 (defmethod size-of ((class ginterface-class) &rest args)
  75   (declare (ignore class args))
  76   (size-of 'gobject))
  77
  78 (defmethod from-alien-form (location (class ginterface-class) &rest args)
  79   (declare (ignore class args))
  80   (from-alien-form location 'gobject))
  81
  82 (defmethod from-alien-function ((class ginterface-class) &rest args)
  83   (declare (ignore class args))
  84   (from-alien-function 'gobject))
  85
  86 (defmethod to-alien-form (instance (class ginterface-class) &rest args)
  87   (declare (ignore class args))
  88   (to-alien-form instance 'gobject))
  89
  90 (defmethod to-alien-function ((class ginterface-class) &rest args)
  91   (declare (ignore class args))
  92   (to-alien-function 'gobject))
  93
  94 (defmethod reader-function ((class ginterface-class) &rest args)
  95   (declare (ignore class args))
  96   (reader-function 'gobject))
  97
  98 (defmethod writer-function ((class ginterface-class) &rest args)
  99   (declare (ignore class args))
 100   (writer-function 'gobject))
 101
 102 (defmethod destroy-function ((class ginterface-class) &rest args)
 103   (declare (ignore class args))
 104   (destroy-function 'gobject))
 105
 106
 107 ;;;;
 108
 109
 110 (defbinding type-default-interface-ref (type) pointer
 111   ((find-type-number type t) type-number))
 112
 113 (defbinding type-default-interface-unref (type) nil
 114   ((find-type-number type t) type-number))
 115
 116 (defbinding type-default-interface-peek (type) pointer
 117   ((find-type-number type t) type-number))
 118
 119 (defbinding %object-interface-list-properties () pointer
 120   (iface pointer)
 121   (n-properties unsigned-int :out))
 122
 123 (defun query-object-interface-properties (type &optional inherited-p)
 124   (let* ((type-number (find-type-number type))
 125          (iface (type-default-interface-ref type-number)))
 126     (unwind-protect
 127          (multiple-value-bind (array length)
 128              (%object-interface-list-properties iface)
 129            (unless (null-pointer-p array)
 130              (unwind-protect
 131                  (%map-params array length type-number inherited-p)
 132                (deallocate-memory array))))
 133 ;      (type-default-interface-unref type-number)
 134       )))
 135
 136
 137 (defun expand-ginterface-type (type forward-p options &rest args)
 138   (declare (ignore args))
 139   (let ((class (type-from-number type))
 140         (slots (getf options :slots)))
 141     `(defclass ,class (,(supertype type))
 142        ,(unless forward-p
 143           (slot-definitions class (query-object-interface-properties type) slots))
 144       (:metaclass ginterface-class)
 145       (:gtype ,(find-type-init-function type)))))
 146
 147 (defun ginterface-dependencies (type)
 148   (delete-duplicates
 149    (cons
 150     (supertype type)
 151     (mapcar #'param-value-type (query-object-interface-properties type)))))
 152
 153 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)