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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000 Espen S. Johnsen <espejohn@online.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.2 2000-08-23 21:40:38 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22
  23 (eval-when (:compile-toplevel :load-toplevel :execute)
  24   (defclass gobject (gtype)
  25     ()
  26     (:metaclass gtype-class)
  27     (:alien-name "GObject"))
  28
  29   (defclass gobject-class (gtype-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 not yet implemented
  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 ;;;; User data mechanism
  77
  78 (declaim (fixnum *user-data-count*))
  79
  80 (defvar *user-data* (make-hash-table))
  81 (defvar *user-data-count* 0)
  82
  83 ;; Until the callback mechanism is moved to glib, the value of
  84 ;; *destroy-marshal* is set in gtkobject.lisp
  85 (defvar *destroy-marshal* nil)
  86
  87 (defun register-user-data (object &optional destroy-function)
  88   (check-type destroy-function (or null symbol function))
  89 ;  (incf *user-data-count*)
  90   (setq *user-data-count* (the fixnum (1+ *user-data-count*)))
  91   (setf
  92    (gethash *user-data-count* *user-data*)
  93    (cons object destroy-function))
  94   *user-data-count*)
  95
  96 (defun find-user-data (id)
  97   (check-type id fixnum)
  98   (multiple-value-bind (user-data p) (gethash id *user-data*)
  99     (values (car user-data) p)))
 100
 101 (defun destroy-user-data (id)
 102   (check-type id fixnum)
 103   (let ((user-data (gethash id *user-data*)))
 104     (when (cdr user-data)
 105       (funcall (cdr user-data) (car user-data))))
 106   (remhash id *user-data*))
 107
 108 (define-foreign %object-set-qdata-full () nil
 109   (object gobject)
 110   (id quark)
 111   (data unsigned-long)
 112   (destroy-marshal pointer))
 113
 114 (defun (setf object-data) (data object key &key (test #'eq))
 115   (%object-set-qdata-full
 116    object (quark-from-object key :test test)
 117    (register-user-data data) *destroy-marshal*)
 118   data)
 119
 120 (define-foreign %object-get-qdata () unsigned-long
 121   (object gobject)
 122   (id quark))
 123
 124 (defun object-data (object key &key (test #'eq))
 125   (find-user-data
 126    (%object-get-qdata object (quark-from-object key :test test))))
 127
 128
 129
 130 ;;;; Methods for gobject-class
 131
 132 (defmethod shared-initialize ((class gobject-class) names &rest initargs
 133                               &key type-init name)
 134   (declare (ignore initargs names))
 135   (let ((alien
 136          (alien::%heap-alien
 137           (alien::make-heap-alien-info
 138            :type (alien::parse-alien-type '(function (unsigned 32)))
 139            :sap-form (system:foreign-symbol-address
 140                       (or
 141                        (first type-init)
 142                        (default-alien-func-name
 143                          (format
 144                           nil "~A_get_type" (or name (class-name class))))))))))
 145     (alien:alien-funcall alien))
 146   (call-next-method))
 147
 148
 149 ; (define-foreign object-class-install-param () nil
 150 ;   (class pointer)
 151 ;   (id unsigned-int)
 152 ;   (parameter parameter))
 153
 154 ; (define-foreign object-class-find-param-spec () parameter
 155 ;   (class pointer)
 156 ;   (name string))
 157