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.11 2005-03-11 19:13:05 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          (type-number
  61           (or
  62            (find-type-number class-name)
  63            (register-type class-name
  64             (or (first gtype) (default-type-init-name class-name))))))
  65 ;    (type-default-interface-ref type-number)
  66     )
  67   (call-next-method))
  68
  69
  70 (defmethod validate-superclass ((class ginterface-class) (super standard-class))
  71   (subtypep (class-name super) 'ginterface))
  72
  73
  74 (defmethod alien-type ((class ginterface-class) &rest args)
  75   (declare (ignore class args))
  76   (alien-type 'gobject))
  77
  78 (defmethod size-of ((class ginterface-class) &rest args)
  79   (declare (ignore class args))
  80   (size-of 'gobject))
  81
  82 (defmethod from-alien-form (location (class ginterface-class) &rest args)
  83   (declare (ignore class args))
  84   (from-alien-form location 'gobject))
  85
  86 (defmethod from-alien-function ((class ginterface-class) &rest args)
  87   (declare (ignore class args))
  88   (from-alien-function 'gobject))
  89
  90 (defmethod to-alien-form (instance (class ginterface-class) &rest args)
  91   (declare (ignore class args))
  92   (to-alien-form instance 'gobject))
  93
  94 (defmethod to-alien-function ((class ginterface-class) &rest args)
  95   (declare (ignore class args))
  96   (to-alien-function 'gobject))
  97
  98 (defmethod reader-function ((class ginterface-class) &rest args)
  99   (declare (ignore class args))
 100   (reader-function 'gobject))
 101
 102 (defmethod writer-function ((class ginterface-class) &rest args)
 103   (declare (ignore class args))
 104   (writer-function 'gobject))
 105
 106 (defmethod destroy-function ((class ginterface-class) &rest args)
 107   (declare (ignore class args))
 108   (destroy-function 'gobject))
 109
 110
 111 ;;;;
 112
 113
 114 (defbinding type-default-interface-ref (type) pointer
 115   ((find-type-number type t) type-number))
 116
 117 (defbinding type-default-interface-unref (type) nil
 118   ((find-type-number type t) type-number))
 119
 120 (defbinding type-default-interface-peek (type) pointer
 121   ((find-type-number type t) type-number))
 122
 123 (defbinding %object-interface-list-properties () pointer
 124   (iface pointer)
 125   (n-properties unsigned-int :out))
 126
 127 (defun query-object-interface-properties (type &optional inherited-p)
 128   (let* ((type-number (find-type-number type))
 129          (iface (type-default-interface-ref type-number)))
 130     (unwind-protect
 131          (multiple-value-bind (array length)
 132              (%object-interface-list-properties iface)
 133            (unless (null-pointer-p array)
 134              (unwind-protect
 135                  (%map-params array length type-number inherited-p)
 136                (deallocate-memory array))))
 137 ;      (type-default-interface-unref type-number)
 138       )))
 139
 140
 141 (defun expand-ginterface-type (type forward-p options &rest args)
 142   (declare (ignore args))
 143   (let ((class (type-from-number type))
 144         (slots (getf options :slots)))
 145     `(defclass ,class (,(supertype type))
 146        ,(unless forward-p
 147           (slot-definitions class (query-object-interface-properties type) slots))
 148       (:metaclass ginterface-class)
 149       (:gtype ,(register-type-as type)))))
 150
 151 (defun ginterface-dependencies (type)
 152   (delete-duplicates
 153    (cons
 154     (supertype type)
 155     (mapcar #'param-value-type (query-object-interface-properties type)))))
 156
 157 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)