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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
   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: gobject.lisp,v 1.4 2001-01-28 14:17:12 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22
  23 (eval-when (:compile-toplevel :load-toplevel :execute)
  24   (defclass gobject (ginstance)
  25     ()
  26     (:metaclass ginstance-class)
  27     (:alien-name "GObject")))
  28
  29
  30 ;;;; Object construction
  31
  32 (define-foreign ("g_object_new" %gobject-new) () gobject
  33   (type type-number)
  34   (nil null))
  35
  36
  37 ;;;; Reference counting for gobject
  38
  39 ;; Specializing reference-instance and unreference-instance on gobject
  40 ;; is not really necessary but done for efficiency
  41
  42 (defmethod reference-instance ((object gobject))
  43   (%object-ref object)
  44   object)
  45
  46 (defmethod unreference-instance ((object gobject))
  47   (%object-unref object))
  48
  49 (deftype-method alien-ref gobject (type-spec)
  50   (declare (ignore type-spec))
  51   '%object-ref)
  52
  53 (deftype-method alien-unref gobject (type-spec)
  54   (declare (ignore type-spec))
  55   '%object-unref)
  56
  57 (define-foreign %object-ref () pointer
  58   (object (or gobject pointer)))
  59
  60 (define-foreign %object-unref () nil
  61   (object (or gobject pointer)))
  62
  63
  64 ;;;; Parameter stuff
  65
  66 (define-foreign %object-set-property () nil
  67   (object gobject)
  68   (name string)
  69   (value gvalue))
  70
  71 (define-foreign %object-get-property () nil
  72   (object gobject)
  73   (name string)
  74   (value gvalue))
  75
  76 (define-foreign %object-notify () nil
  77   (object gobject)
  78   (name string))
  79
  80 (define-foreign object-freeze-notify () nil
  81   (object gobject))
  82
  83 (define-foreign object-thaw-notify () nil
  84   (object gobject))
  85
  86 (define-foreign %object-set-qdata-full () nil
  87   (object gobject)
  88   (id quark)
  89   (data unsigned-long)
  90   (destroy-marshal pointer))
  91
  92
  93 ;;;; User data
  94
  95 (defun (setf object-data) (data object key &key (test #'eq))
  96   (%object-set-qdata-full
  97    object (quark-from-object key :test test)
  98    (register-user-data data) *destroy-notify*)
  99   data)
 100
 101 (define-foreign %object-get-qdata () unsigned-long
 102   (object gobject)
 103   (id quark))
 104
 105 (defun object-data (object key &key (test #'eq))
 106   (find-user-data
 107    (%object-get-qdata object (quark-from-object key :test test))))
 108
 109
 110
 111 ;;;; Metaclass used for subclasses of gobject
 112
 113 (eval-when (:compile-toplevel :load-toplevel :execute)
 114   (defclass gobject-class (ginstance-class))
 115
 116   (defclass direct-gobject-slot-definition (direct-virtual-slot-definition))
 117
 118   (defclass effective-gobject-slot-definition
 119     (effective-virtual-slot-definition)))
 120
 121 (defmethod allocate-alien-storage ((class gobject-class))
 122   (alien-instance-location (%gobject-new (find-type-number class))))
 123
 124 (defmethod shared-initialize ((class gobject-class) names &rest initargs
 125                               &key type-init name)
 126   (declare (ignore initargs names))
 127   (let ((alien
 128          (alien::%heap-alien
 129           (alien::make-heap-alien-info
 130            :type (alien::parse-alien-type '(function (unsigned 32)))
 131            :sap-form (system:foreign-symbol-address
 132                       (or
 133                        (first type-init)
 134                        (default-alien-func-name
 135                          (format
 136                           nil "~A_get_type" (or name (class-name class))))))))))
 137     (alien:alien-funcall alien))
 138   (call-next-method))
 139
 140
 141 ; (define-foreign object-class-install-param () nil
 142 ;   (class pointer)
 143 ;   (id unsigned-int)
 144 ;   (parameter parameter))
 145
 146 ; (define-foreign object-class-find-param-spec () parameter
 147 ;   (class pointer)
 148 ;   (name string))
 149
 150
 151 (defmethod initialize-instance :after ((slotd direct-gobject-slot-definition)
 152                                        &rest initargs &key)
 153   (declare (ignore initargs))
 154   (unless (slot-boundp slotd 'location)
 155     ;; Find parameter name from slot name
 156     (with-slots (pcl::name location) slotd
 157       (setf location (signal-name-to-string pcl::name)))))
 158
 159 (defmethod direct-slot-definition-class ((class gobject-class) initargs)
 160   (case (getf initargs :allocation)
 161     (:param (find-class 'direct-gobject-slot-definition))
 162     (t (call-next-method))))
 163
 164 (defmethod effective-slot-definition-class ((class gobject-class) initargs)
 165   (case (getf initargs :allocation)
 166     (:param (find-class 'effective-gobject-slot-definition))
 167     (t (call-next-method))))
 168
 169 (defmethod compute-virtual-slot-location
 170     ((class gobject-class) (slotd effective-gobject-slot-definition)
 171      direct-slotds)
 172   (with-slots (type) slotd
 173     (let ((param-name (slot-definition-location (first direct-slotds)))
 174           (type-number (find-type-number type))
 175           (reader (get-reader-function type))
 176           (writer (get-writer-function type))
 177           (destroy (get-destroy-function type)))
 178       (list
 179        #'(lambda (object)
 180            (with-gc-disabled
 181              (let ((gvalue (gvalue-new type-number)))
 182                (%object-get-property object param-name gvalue)
 183                (prog1
 184                    (funcall reader gvalue +gvalue-value-offset+)
 185                  (gvalue-free gvalue t)))))
 186        #'(lambda (value object)
 187            (with-gc-disabled
 188              (let ((gvalue (gvalue-new type-number)))
 189                (funcall writer value gvalue +gvalue-value-offset+)
 190                (%object-set-property object param-name gvalue)
 191                (funcall destroy gvalue +gvalue-value-offset+)
 192                (gvalue-free gvalue nil)
 193                value)))))))
 194
 195
 196 (defmethod validate-superclass ((class gobject-class)
 197                                 (super pcl::standard-class))
 198   (subtypep (class-name super) 'gobject))