chiark - git - mdw - clg/blob - glib/gboxed.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: gboxed.lisp,v 1.20 2006-02-04 12:15:31 espen Exp $
  24
  25 (in-package "GLIB")
  26
  27
  28 (defclass boxed (struct)
  29   ()
  30   (:metaclass struct-class))
  31
  32 (defmethod instance-finalizer ((instance boxed))
  33   (let ((location (foreign-location instance))
  34         (type-number (type-number-of instance)))
  35     #'(lambda ()
  36         (remove-cached-instance location)
  37         (%boxed-free type-number location))))
  38
  39
  40 ;;;; Metaclass for boxed classes
  41
  42 (eval-when (:compile-toplevel :load-toplevel :execute)
  43   (defclass boxed-class (struct-class)
  44     ())
  45
  46   (defmethod validate-superclass ((class boxed-class) (super standard-class))
  47     (subtypep (class-name super) 'boxed)))
  48
  49
  50 (defmethod shared-initialize ((class boxed-class) names &key name gtype)
  51   (declare (ignore names))
  52   (call-next-method)
  53   (let ((class-name (or name (class-name class))))
  54     (unless (find-type-number class-name)
  55       (register-type class-name
  56        (or (first gtype) (default-type-init-name class-name))))))
  57
  58 (defbinding %boxed-copy () pointer
  59   (type-number type-number)
  60   (location pointer))
  61
  62 (defbinding %boxed-free () nil
  63   (type-number type-number)
  64   (location pointer))
  65
  66 (defmethod reference-foreign ((class boxed-class) location)
  67   (%boxed-copy (find-type-number class) location))
  68
  69 (defmethod unreference-foreign ((class boxed-class) location)
  70   (%boxed-free (find-type-number class) location))
  71
  72
  73 ;;;;
  74
  75 (defun expand-boxed-type (type-number forward-p slots)
  76   `(defclass ,(type-from-number type-number) (boxed)
  77      ,(unless forward-p
  78         slots)
  79      (:metaclass boxed-class)
  80      (:gtype ,(register-type-as type-number))))
  81
  82 (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
  83
  84 ;;;; Special boxed types
  85
  86 ;; (defclass gstring (boxed)
  87 ;;   ()
  88 ;;   (:metaclass boxed-class)
  89 ;;   (:alien-name "GString"))
  90
  91 ;; (deftype-method translate-from-alien
  92 ;;     gstring (type-spec location &optional weak-ref)
  93 ;;   `(let ((location ,location))
  94 ;;      (unless (null-pointer-p location)
  95 ;;        (prog1
  96 ;;         (c-call::%naturalize-c-string location)
  97 ;;       ,(unless weak-ref
  98 ;;          (unreference-alien type-spec location))))))
  99
 100 ;; (deftype-method translate-to-alien
 101 ;;     gstring (type-spec string &optional weak-ref)
 102 ;;   (declare (ignore weak-ref))
 103 ;;   `(let ((string ,string))
 104 ;;      ;; Always copy strings to prevent seg fault due to GC
 105 ;;      (funcall
 106 ;;       ',(proxy-class-copy (find-class type-spec))
 107 ;;       ',type-spec
 108 ;;       (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
 109
 110 ;; (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
 111 ;;   (when weak-ref
 112 ;;     (unreference-alien type-spec c-string)))
 113
 114
 115
 116 ;;;; NULL terminated vector of strings
 117
 118 (deftype strings () '(null-terminated-vector string))
 119 (register-type 'strings '|g_strv_get_type|)