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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2001-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: ginterface.lisp,v 1.15 2006-02-26 15:30:01 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27 (use-prefix "g")
  28
  29 ;;;;
  30
  31 (defclass ginterface ()
  32   ())
  33
  34 ;;;; Metaclass for interfaces
  35
  36 (eval-when (:compile-toplevel :load-toplevel :execute)
  37   (defclass ginterface-class (virtual-slots-class)
  38     ()))
  39
  40 (defmethod direct-slot-definition-class ((class ginterface-class) &rest initargs)
  41   (case (getf initargs :allocation)
  42     (:property (find-class 'direct-property-slot-definition))
  43     (t (call-next-method))))
  44
  45 (defmethod effective-slot-definition-class ((class ginterface-class) &rest initargs)
  46   (case (getf initargs :allocation)
  47     (:property (find-class 'effective-property-slot-definition))
  48     (t (call-next-method))))
  49
  50 (defmethod compute-effective-slot-definition-initargs ((class ginterface-class) direct-slotds)
  51   (if (eq (slot-definition-allocation (first direct-slotds)) :property)
  52       (nconc
  53        (list :pname (signal-name-to-string
  54                      (most-specific-slot-value direct-slotds 'pname))
  55              :readable (most-specific-slot-value direct-slotds 'readable)
  56              :writable (most-specific-slot-value direct-slotds 'writable)
  57              :construct-only (most-specific-slot-value direct-slotds 'construct))
  58        (call-next-method))
  59     (call-next-method)))
  60
  61
  62 (defmethod shared-initialize ((class ginterface-class) names &key name gtype)
  63   (declare (ignore names))
  64   (let* ((class-name (or name (class-name class)))
  65 ;;       (type-number
  66 ;;        (or
  67 ;;         (find-type-number class-name)
  68 ;;         (register-type class-name
  69 ;;          (or (first gtype) (default-type-init-name class-name)))))
  70          )
  71 ;    (type-default-interface-ref type-number)
  72     )
  73   (call-next-method))
  74
  75
  76 (defmethod validate-superclass ((class ginterface-class) (super standard-class))
  77   (subtypep (class-name super) 'ginterface))
  78
  79
  80 (define-type-method alien-type ((type ginterface))
  81   (declare (ignore type))
  82   (alien-type 'gobject))
  83
  84 (define-type-method size-of ((type ginterface))
  85   (declare (ignore type))
  86   (size-of 'gobject))
  87
  88 (define-type-method from-alien-form ((type ginterface) location)
  89   (declare (ignore type))
  90   (from-alien-form 'gobject location))
  91
  92 (define-type-method from-alien-function ((type ginterface))
  93   (declare (ignore type))
  94   (from-alien-function 'gobject))
  95
  96 (define-type-method to-alien-form ((type ginterface) instance)
  97   (declare (ignore type))
  98   (to-alien-form 'gobject instance))
  99
 100 (define-type-method to-alien-function ((type ginterface))
 101   (declare (ignore type))
 102   (to-alien-function 'gobject))
 103
 104 (define-type-method reader-function ((type ginterface))
 105   (declare (ignore type))
 106   (reader-function 'gobject))
 107
 108 (define-type-method writer-function ((type ginterface))
 109   (declare (ignore type))
 110   (writer-function 'gobject))
 111
 112 (define-type-method destroy-function ((type ginterface))
 113   (declare (ignore type))
 114   (destroy-function 'gobject))
 115
 116
 117 ;;;;
 118
 119
 120 (defbinding type-default-interface-ref (type) pointer
 121   ((find-type-number type t) type-number))
 122
 123 (defbinding type-default-interface-unref (type) nil
 124   ((find-type-number type t) type-number))
 125
 126 (defbinding type-default-interface-peek (type) pointer
 127   ((find-type-number type t) type-number))
 128
 129 (defbinding %object-interface-list-properties () pointer
 130   (iface pointer)
 131   (n-properties unsigned-int :out))
 132
 133 (defun query-object-interface-properties (type &optional inherited-p)
 134   (let* ((type-number (find-type-number type))
 135          (iface (type-default-interface-ref type-number)))
 136     (unwind-protect
 137          (multiple-value-bind (array length)
 138              (%object-interface-list-properties iface)
 139            (unless (null-pointer-p array)
 140              (unwind-protect
 141                  (%map-params array length type-number inherited-p)
 142                (deallocate-memory array))))
 143 ;      (type-default-interface-unref type-number)
 144       )))
 145
 146
 147 (defun expand-ginterface-type (type forward-p options &rest args)
 148   (declare (ignore args))
 149   (let ((class (type-from-number type))
 150         (slots (getf options :slots)))
 151     `(defclass ,class (,(supertype type))
 152        ,(unless forward-p
 153           (slot-definitions class (query-object-interface-properties type) slots))
 154       (:metaclass ginterface-class)
 155       (:gtype ,(register-type-as type)))))
 156
 157 (defun ginterface-dependencies (type)
 158   (delete-duplicates
 159    (cons
 160     (supertype type)
 161     (mapcar #'param-value-type (query-object-interface-properties type)))))
 162
 163 (register-derivable-type 'ginterface "GInterface" 'expand-ginterface-type 'ginterface-dependencies)