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.3 2000/11/09 20:29:19 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   (defclass gobject-class (ginstance-class)))
  30
  31
  32 ;;;; Reference counting for gobject
  33
  34 ;; Specializing reference-instance and unreference-instance on gobject
  35 ;; is not really necessary but done for efficiency
  36
  37 (defmethod reference-instance ((object gobject))
  38   (%object-ref object)
  39   object)
  40
  41 (defmethod unreference-instance ((object gobject))
  42   (%object-unref object))
  43
  44 (deftype-method alien-ref gobject (type-spec)
  45   (declare (ignore type-spec))
  46   '%object-ref)
  47
  48 (deftype-method alien-unref gobject (type-spec)
  49   (declare (ignore type-spec))
  50   '%object-unref)
  51
  52 (define-foreign %object-ref () pointer
  53   (object (or gobject pointer)))
  54
  55 (define-foreign %object-unref () nil
  56   (object (or gobject pointer)))
  57
  58
  59 ;;;; Parameter stuff
  60
  61 (define-foreign %object-set-param () nil
  62   (object gobject)
  63   (name string)
  64   (value gvalue))
  65
  66 (define-foreign %object-get-param () nil
  67   (object gobject)
  68   (name string)
  69   (value gvalue :out))
  70
  71 (define-foreign object-queue-param-changed () nil
  72   (object gobject)
  73   (name string))
  74
  75
  76
  77
  78 (define-foreign %object-set-qdata-full () nil
  79   (object gobject)
  80   (id quark)
  81   (data unsigned-long)
  82   (destroy-marshal pointer))
  83
  84 (defun (setf object-data) (data object key &key (test #'eq))
  85   (%object-set-qdata-full
  86    object (quark-from-object key :test test)
  87    (register-user-data data) *destroy-notify*)
  88   data)
  89
  90 (define-foreign %object-get-qdata () unsigned-long
  91   (object gobject)
  92   (id quark))
  93
  94 (defun object-data (object key &key (test #'eq))
  95   (find-user-data
  96    (%object-get-qdata object (quark-from-object key :test test))))
  97
  98
  99
 100
 101
 102
 103 ;;;; Methods for gobject-class
 104
 105 (defmethod shared-initialize ((class gobject-class) names &rest initargs
 106                               &key type-init name)
 107   (declare (ignore initargs names))
 108   (let ((alien
 109          (alien::%heap-alien
 110           (alien::make-heap-alien-info
 111            :type (alien::parse-alien-type '(function (unsigned 32)))
 112            :sap-form (system:foreign-symbol-address
 113                       (or
 114                        (first type-init)
 115                        (default-alien-func-name
 116                          (format
 117                           nil "~A_get_type" (or name (class-name class))))))))))
 118     (alien:alien-funcall alien))
 119   (call-next-method))
 120
 121
 122 ; (define-foreign object-class-install-param () nil
 123 ;   (class pointer)
 124 ;   (id unsigned-int)
 125 ;   (parameter parameter))
 126
 127 ; (define-foreign object-class-find-param-spec () parameter
 128 ;   (class pointer)
 129 ;   (name string))
 130