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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2001-2006 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.21 2006-04-25 21:55:42 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         (%boxed-free type-number location))))
  37
  38
  39 ;;;; Metaclass for boxed classes
  40
  41 (eval-when (:compile-toplevel :load-toplevel :execute)
  42   (defclass boxed-class (struct-class)
  43     ())
  44
  45   (defmethod validate-superclass ((class boxed-class) (super standard-class))
  46     (subtypep (class-name super) 'boxed)))
  47
  48
  49 (defbinding %boxed-copy () pointer
  50   (type-number type-number)
  51   (location pointer))
  52
  53 (defbinding %boxed-free () nil
  54   (type-number type-number)
  55   (location pointer))
  56
  57 (defmethod shared-initialize ((class boxed-class) names
  58                               &key name gtype ref unref)
  59   (declare (ignore names))
  60   (let* ((class-name (or name (class-name class)))
  61          (type-number
  62           (register-type class-name
  63           (or
  64            (first gtype)
  65            (default-type-init-name class-name)))))
  66     (unless (or ref (slot-boundp class 'ref))
  67       (setf
  68        (slot-value class 'ref)
  69        #'(lambda (location)
  70            (%boxed-copy type-number location))))
  71     (unless (or unref (slot-boundp class 'unref))
  72       (setf
  73        (slot-value class 'unref)
  74        #'(lambda (location)
  75            (%boxed-free type-number location)))))
  76   (call-next-method))
  77
  78
  79 (defun expand-boxed-type (type-number forward-p slots)
  80   `(defclass ,(type-from-number type-number) (boxed)
  81      ,(unless forward-p
  82         slots)
  83      (:metaclass boxed-class)
  84      (:gtype ,(register-type-as type-number))))
  85
  86 (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
  87
  88
  89 ;;;; NULL terminated vector of strings
  90
  91 (deftype strings () '(null-terminated-vector string))
  92 (register-type 'strings '|g_strv_get_type|)