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.3 2004-10-31 00:56:29 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22 (use-prefix "g")
  23
  24 ;;;;
  25
  26 (defclass ginterface ()
  27   ())
  28
  29 (deftype-method translate-type-spec ginterface (type-spec)
  30   (declare (ignore type-spec))
  31   (translate-type-spec 'gobject))
  32
  33 (deftype-method size-of ginterface (type-spec)
  34   (declare (ignore type-spec))
  35   (size-of 'gobject))
  36
  37 (deftype-method translate-from-alien
  38     ginterface (type-spec location &optional weak-ref)
  39   (declare (ignore type-spec))
  40   (translate-from-alien 'gobject location weak-ref))
  41
  42 (deftype-method translate-to-alien
  43     ginterface (type-spec instance &optional weak-ref)
  44   (declare (ignore type-spec))
  45   (translate-to-alien 'gobject instance weak-ref))
  46
  47
  48
  49 ;;;; Metaclass for interfaces
  50
  51 (eval-when (:compile-toplevel :load-toplevel :execute)
  52   (defclass ginterface-class (virtual-slot-class)
  53     ()))
  54
  55 (defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
  56   (case (getf initargs :allocation)
  57     (:property (find-class 'direct-property-slot-definition))
  58     (t (call-next-method))))
  59
  60 (defmethod effective-slot-definition-class ((class ginterface-class) &rest initargs)
  61   (case (getf initargs :allocation)
  62     (:property (find-class 'effective-property-slot-definition))
  63     (t (call-next-method))))
  64
  65 (defmethod compute-effective-slot-definition-initargs ((class ginterface-class) direct-slotds)
  66   (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
  67       (nconc
  68        (list :pname (signal-name-to-string
  69                      (most-specific-slot-value direct-slotds 'pname))
  70              :readable (most-specific-slot-value direct-slotds 'readable)
  71              :writable (most-specific-slot-value direct-slotds 'writable)
  72              :construct (most-specific-slot-value direct-slotds 'construct))
  73        (call-next-method))
  74     (call-next-method)))
  75
  76
  77 (defmethod shared-initialize ((class ginterface-class) names
  78                               &rest initargs &key name alien-name)
  79   (declare (ignore initargs names))
  80   (let* ((class-name (or name (class-name class)))
  81          (type-number
  82           (find-type-number
  83            (or (first alien-name) (default-alien-type-name class-name)) t)))
  84     (register-type class-name type-number))
  85   (call-next-method))
  86
  87
  88 (defmethod validate-superclass
  89     ((class ginterface-class) (super pcl::standard-class))
  90   (subtypep (class-name super) 'ginterface))
  91
  92
  93 ;;;;
  94
  95
  96 (defbinding type-default-interface-ref (type) pointer
  97   ((find-type-number type t) type-number))
  98
  99 (defbinding type-default-interface-unref (type) nil
 100   ((find-type-number type t) type-number))
 101
 102 (defbinding type-default-interface-peek (type) pointer
 103   ((find-type-number type t) type-number))
 104
 105 (defbinding %object-interface-list-properties () pointer
 106   (iface pointer)
 107   (n-properties unsigned-int :out))
 108
 109 (defun query-object-interface-properties (type &optional inherited-p)
 110   (let* ((type-number (find-type-number type))
 111          (iface (type-default-interface-ref type-number)))
 112     (unwind-protect
 113          (multiple-value-bind (array length)
 114              (%object-interface-list-properties iface)
 115            (unwind-protect
 116                 (%map-params array length type-number inherited-p)
 117              (deallocate-memory array)))
 118 ;      (type-default-interface-unref type-number)
 119       )))
 120
 121
 122 (defun expand-ginterface-type (type options &rest args)
 123   (declare (ignore args))
 124   (let ((class (type-from-number type))
 125         (slots (getf options :slots)))
 126     `(defclass ,class (,(supertype type))
 127       ,(slot-definitions class (query-object-interface-properties type) slots)
 128       (:metaclass ginterface-class)
 129       (:alien-name ,(find-type-name type)))))
 130
 131
 132 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type)