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