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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 2000-2001 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.15 2004-10-31 00:56:29 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     (:copy %object-ref)
  29     (:free %object-unref)))
  30
  31
  32 (defmethod initialize-instance ((object gobject) &rest initargs)
  33   (let ((slotds (class-slots (class-of object)))
  34         (names (make-array 0 :adjustable t :fill-pointer t))
  35         (values (make-array 0 :adjustable t :fill-pointer t)))
  36
  37     (loop
  38      as tmp = initargs then (cddr tmp) while tmp
  39      as key = (first tmp)
  40      as value = (second tmp)
  41      as slotd = (find-if
  42                  #'(lambda (slotd)
  43                      (member key (slot-definition-initargs slotd)))
  44                  slotds)
  45      when (and (typep slotd 'effective-property-slot-definition)
  46                (slot-value slotd 'construct))
  47      do (let ((type (find-type-number (slot-definition-type slotd))))
  48           (vector-push-extend (slot-definition-pname slotd) names)
  49           (vector-push-extend (gvalue-new type value) values)
  50           (remf initargs key)))
  51
  52     (setf
  53      (slot-value object 'location)
  54      (if (zerop (length names))
  55          (%gobject-new (type-number-of object))
  56        (%gobject-newvv (type-number-of object) (length names) names values)))
  57
  58 ;    (map 'nil #'gvalue-free values)
  59     )
  60
  61   (apply #'call-next-method object initargs))
  62
  63
  64
  65 (defbinding (%gobject-new "g_object_new") () pointer
  66   (type type-number)
  67   (nil null))
  68
  69 (defbinding (%gobject-newvv "g_object_newvv") () pointer
  70   (type type-number)
  71   (n-parameters unsigned-int)
  72   (names (vector string))
  73   (values (vector gvalue)))
  74
  75
  76 (defbinding %object-ref (type location) pointer
  77   (location pointer))
  78
  79  (defbinding %object-unref (type location) nil
  80    (location pointer))
  81
  82 (defun object-ref (object)
  83   (%object-ref nil (proxy-location object)))
  84
  85 (defun object-unref (object)
  86   (%object-unref nil (proxy-location object)))
  87
  88
  89
  90 ;;;; Property stuff
  91
  92 (defbinding %object-set-property () nil
  93   (object gobject)
  94   (name string)
  95   (value gvalue))
  96
  97 (defbinding %object-get-property () nil
  98   (object gobject)
  99   (name string)
 100   (value gvalue))
 101
 102 (defbinding %object-notify () nil
 103   (object gobject)
 104   (name string))
 105
 106 (defbinding object-freeze-notify () nil
 107   (object gobject))
 108
 109 (defbinding object-thaw-notify () nil
 110   (object gobject))
 111
 112 (defbinding %object-set-qdata-full () nil
 113   (object gobject)
 114   (id quark)
 115   (data unsigned-long)
 116   (destroy-marshal pointer))
 117
 118
 119 ;;;; User data
 120
 121 (defun (setf object-data) (data object key &key (test #'eq))
 122   (%object-set-qdata-full
 123    object (quark-from-object key :test test)
 124    (register-user-data data) *destroy-notify*)
 125   data)
 126
 127 (defbinding %object-get-qdata () unsigned-long
 128   (object gobject)
 129   (id quark))
 130
 131 (defun object-data (object key &key (test #'eq))
 132   (find-user-data
 133    (%object-get-qdata object (quark-from-object key :test test))))
 134
 135
 136
 137 ;;;; Metaclass used for subclasses of gobject
 138
 139 (eval-when (:compile-toplevel :load-toplevel :execute)
 140   (defclass gobject-class (ginstance-class)
 141     ())
 142
 143   (defclass direct-property-slot-definition (direct-virtual-slot-definition)
 144     ((pname :reader slot-definition-pname :initarg :pname)
 145      (readable :initform t :reader slot-readable-p :initarg :readable)
 146      (writable :initform t :reader slot-writable-p :initarg :writable)
 147      (construct :initform nil :initarg :construct)))
 148
 149   (defclass effective-property-slot-definition (effective-virtual-slot-definition)
 150     ((pname :reader slot-definition-pname :initarg :pname)
 151      (readable :reader slot-readable-p :initarg :readable)
 152      (writable :reader slot-writable-p :initarg :writable)
 153      (construct :initarg :construct))))
 154
 155
 156
 157 ; (defbinding object-class-install-param () nil
 158 ;   (class pointer)
 159 ;   (id unsigned-int)
 160 ;   (parameter parameter))
 161
 162 ; (defbinding object-class-find-param-spec () parameter
 163 ;   (class pointer)
 164 ;   (name string))
 165
 166 (defun signal-name-to-string (name)
 167   (substitute #\_ #\- (string-downcase (string name))))
 168
 169
 170 (defmethod direct-slot-definition-class ((class gobject-class) &rest initargs)
 171   (case (getf initargs :allocation)
 172     (:property (find-class 'direct-property-slot-definition))
 173     (t (call-next-method))))
 174
 175 (defmethod effective-slot-definition-class ((class gobject-class) &rest initargs)
 176   (case (getf initargs :allocation)
 177     (:property (find-class 'effective-property-slot-definition))
 178     (t (call-next-method))))
 179
 180 (defmethod compute-effective-slot-definition-initargs ((class gobject-class) direct-slotds)
 181   (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
 182       (nconc
 183        (list :pname (signal-name-to-string
 184                      (most-specific-slot-value direct-slotds 'pname))
 185              :readable (most-specific-slot-value direct-slotds 'readable)
 186              :writable (most-specific-slot-value direct-slotds 'writable)
 187              :construct (most-specific-slot-value direct-slotds 'construct))
 188        (call-next-method))
 189     (call-next-method)))
 190
 191
 192 (defmethod initialize-internal-slot-functions ((slotd effective-property-slot-definition))
 193   (let* ((type (slot-definition-type slotd))
 194          (pname (slot-definition-pname slotd))
 195          (type-number (find-type-number type)))
 196     (unless (slot-boundp slotd 'reader-function)
 197       (setf
 198        (slot-value slotd 'reader-function)
 199        (if (slot-readable-p slotd)
 200            #'(lambda (object)
 201                (with-gc-disabled
 202                    (let ((gvalue (gvalue-new type-number)))
 203                      (%object-get-property object pname gvalue)
 204                      (unwind-protect
 205                           (funcall
 206                            (intern-reader-function (type-from-number type-number)) gvalue +gvalue-value-offset+) ; temporary workaround for wrong topological sorting of types
 207                        (gvalue-free gvalue t)))))
 208            #'(lambda (value object)
 209                (error "Slot is not readable: ~A" (slot-definition-name slotd))))))
 210
 211     (unless (slot-boundp slotd 'writer-function)
 212       (setf
 213        (slot-value slotd 'writer-function)
 214        (if (slot-writable-p slotd)
 215            #'(lambda (value object)
 216                (with-gc-disabled
 217                    (let ((gvalue (gvalue-new type-number)))
 218                      (funcall
 219                       (intern-writer-function (type-from-number type-number)) ; temporary
 220                       value gvalue +gvalue-value-offset+)
 221                      (%object-set-property object pname gvalue)
 222                      (funcall
 223                       (intern-destroy-function (type-from-number type-number)) ; temporary
 224                       gvalue +gvalue-value-offset+)
 225                      (gvalue-free gvalue nil)
 226                      value)))
 227            #'(lambda (value object)
 228                (error "Slot is not writable: ~A" (slot-definition-name slotd))))))
 229
 230     (unless (slot-boundp slotd 'boundp-function)
 231       (setf
 232        (slot-value slotd 'boundp-function)
 233        #'(lambda (object)
 234            (declare (ignore object))
 235            t))))
 236   (call-next-method))
 237
 238
 239 (defmethod validate-superclass ((class gobject-class)
 240                                 (super pcl::standard-class))
 241 ;  (subtypep (class-name super) 'gobject)
 242   t)
 243
 244
 245
 246 ;;;;
 247
 248 (defbinding %object-class-list-properties () pointer
 249   (class pointer)
 250   (n-properties unsigned-int :out))
 251
 252
 253 (defun %map-params (params length type inherited-p)
 254   (if inherited-p
 255       (map-c-array 'list #'identity params 'param length)
 256     (let ((properties ()))
 257       (map-c-array 'list
 258        #'(lambda (param)
 259            (when (eql (param-owner-type param) type)
 260              (push param properties)))
 261        params 'param length)
 262       (nreverse properties))))
 263
 264 (defun query-object-class-properties (type &optional inherited-p)
 265   (let* ((type-number (find-type-number type))
 266          (class (type-class-ref type-number)))
 267     (unwind-protect
 268          (multiple-value-bind (array length)
 269              (%object-class-list-properties class)
 270            (unwind-protect
 271                 (%map-params array length type-number inherited-p)
 272              (deallocate-memory array)))
 273 ;      (type-class-unref type-number)
 274       )))
 275
 276
 277 (defun default-slot-name (name)
 278   (intern (substitute #\- #\_ (string-upcase (string-upcase name)))))
 279
 280 (defun default-slot-accessor (class-name slot-name type)
 281   (intern
 282    (format
 283     nil "~A-~A~A" class-name slot-name
 284     (if (eq type 'boolean) "-P" ""))))
 285
 286
 287 (defun slot-definition-from-property (class property)
 288   (with-slots (name flags value-type documentation) property
 289     (let* ((slot-name (default-slot-name name))
 290            (slot-type (or (type-from-number value-type) value-type))
 291            (accessor (default-slot-accessor class slot-name slot-type)))
 292
 293       `(,slot-name
 294         :allocation :property :pname ,name
 295
 296         ;; accessors
 297         ,@(cond
 298            ((and
 299              (member :writable flags) (member :readable flags)
 300              (not (member :construct-only flags)))
 301             (list :accessor accessor))
 302            ((and (member :writable flags) (not (member :construct-only flags)))
 303             (list :writer `(setf ,accessor)))
 304            ((member :readable flags)
 305             (list :reader accessor)))
 306
 307         ;; readable/writable/construct
 308         ,@(when (or (not (member :writable flags))
 309                     (member :construct-only flags))
 310             '(:writable nil))
 311         ,@(when (not (member :readable flags))
 312             '(:readable nil))
 313         ,@(when (or (member :construct flags)
 314                     (member :construct-only flags))
 315             '(:construct t))
 316
 317         ;; initargs
 318         ,@(when (or (member :construct flags)
 319                     (member :construct-only flags)
 320                     (member :writable flags))
 321             (list :initarg (intern (string slot-name) "KEYWORD")))
 322
 323         :type ,slot-type
 324         :documentation ,documentation))))
 325
 326
 327 (defun slot-definitions (class properties slots)
 328   (loop
 329    with manual-slots = slots
 330    for property in properties
 331    unless (find-if
 332            #'(lambda (slot)
 333                (destructuring-bind (name &rest args) slot
 334                  (or
 335                   (equal (param-name property) (getf args :pname))
 336                   (eq (default-slot-name (param-name property)) name))))
 337            manual-slots)
 338    do (push (slot-definition-from-property class property) slots))
 339   (delete-if #'(lambda (slot) (getf (rest slot) :ignore)) slots))
 340
 341
 342 (defun expand-gobject-type (type &optional options (metaclass 'gobject-class))
 343   (let ((supers (cons (supertype type) (implements type)))
 344         (class  (type-from-number type))
 345         (slots (getf options :slots)))
 346     `(defclass ,class ,supers
 347       ,(slot-definitions class (query-object-class-properties type) slots)
 348       (:metaclass ,metaclass)
 349       (:alien-name ,(find-type-name type)))))
 350
 351
 352 (register-derivable-type 'gobject "GObject" 'expand-gobject-type)