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.8 2005-02-10 00:20:02 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 ((class ginterface-class) (super standard-class))
  69   (subtypep (class-name super) 'ginterface))
  70
  71
  72 (defmethod alien-type ((class ginterface-class) &rest args)
  73   (declare (ignore class args))
  74   (alien-type 'gobject))
  75
  76 (defmethod size-of ((class ginterface-class) &rest args)
  77   (declare (ignore class args))
  78   (size-of 'gobject))
  79
  80 (defmethod from-alien-form (location (class ginterface-class) &rest args)
  81   (declare (ignore class args))
  82   (from-alien-form location 'gobject))
  83
  84 (defmethod from-alien-function ((class ginterface-class) &rest args)
  85   (declare (ignore class args))
  86   (from-alien-function 'gobject))
  87
  88 (defmethod to-alien-form (instance (class ginterface-class) &rest args)
  89   (declare (ignore class args))
  90   (to-alien-form instance 'gobject))
  91
  92 (defmethod to-alien-function ((class ginterface-class) &rest args)
  93   (declare (ignore class args))
  94   (to-alien-function 'gobject))
  95
  96 (defmethod reader-function ((class ginterface-class) &rest args)
  97   (declare (ignore class args))
  98   (reader-function 'gobject))
  99
 100 (defmethod writer-function ((class ginterface-class) &rest args)
 101   (declare (ignore class args))
 102   (writer-function 'gobject))
 103
 104 (defmethod destroy-function ((class ginterface-class) &rest args)
 105   (declare (ignore class args))
 106   (destroy-function 'gobject))
 107
 108
 109 ;;;;
 110
 111
 112 (defbinding type-default-interface-ref (type) pointer
 113   ((find-type-number type t) type-number))
 114
 115 (defbinding type-default-interface-unref (type) nil
 116   ((find-type-number type t) type-number))
 117
 118 (defbinding type-default-interface-peek (type) pointer
 119   ((find-type-number type t) type-number))
 120
 121 (defbinding %object-interface-list-properties () pointer
 122   (iface pointer)
 123   (n-properties unsigned-int :out))
 124
 125 (defun query-object-interface-properties (type &optional inherited-p)
 126   (let* ((type-number (find-type-number type))
 127          (iface (type-default-interface-ref type-number)))
 128     (unwind-protect
 129          (multiple-value-bind (array length)
 130              (%object-interface-list-properties iface)
 131            (unless (null-pointer-p array)
 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 forward-p 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        ,(unless forward-p
 145           (slot-definitions class (query-object-interface-properties type) slots))
 146       (:metaclass ginterface-class)
 147       (:alien-name ,(find-type-name type)))))
 148
 149 (defun ginterface-dependencies (type)
 150   (delete-duplicates
 151    (cons
 152     (supertype type)
 153     (mapcar #'param-value-type (query-object-interface-properties type)))))
 154
 155 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)