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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 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: gboxed.lisp,v 1.7 2001-12-12 20:24:41 espen Exp $
  19
  20 (in-package "GLIB")
  21
  22
  23 (eval-when (:compile-toplevel :load-toplevel :execute)
  24   (init-types-in-library "libgobject-1.3.so")
  25   (defclass boxed (proxy)
  26     ()
  27     (:metaclass proxy-class)
  28     (:copy %boxed-copy)
  29     (:free %boxed-free)))
  30
  31 (defbinding %boxed-copy (type location) pointer
  32   ((find-type-number type) type-number)
  33   (location pointer))
  34
  35 (defbinding %boxed-free (type location) nil
  36   ((find-type-number type) type-number)
  37   (location pointer))
  38
  39
  40 ;;;; Metaclass for boxed classes
  41
  42 (eval-when (:compile-toplevel :load-toplevel :execute)
  43   (defclass boxed-class (proxy-class))
  44
  45
  46   (defmethod shared-initialize ((class boxed-class) names
  47                                 &rest initargs &key name alien-name)
  48     (declare (ignore initargs names))
  49     (call-next-method)
  50
  51     (let* ((class-name (or name (class-name class)))
  52            (type-number
  53             (find-type-number
  54              (or (first alien-name) (default-alien-type-name class-name)))))
  55       (register-type class-name type-number)))
  56
  57
  58   (defmethod validate-superclass
  59     ((class boxed-class) (super pcl::standard-class))
  60     (subtypep (class-name super) 'boxed)))
  61
  62
  63 ;;;;
  64
  65 (defun expand-boxed-type (type-number &optional slots)
  66   `(defclass ,(type-from-number type-number) (boxed)
  67      ,slots
  68      (:metaclass boxed-class)
  69      (:alien-name ,(find-type-name type-number))))
  70
  71 (register-derivable-type 'boxed "GBoxed" 'expand-boxed-type)
  72
  73 ;;;; Special boxed types
  74
  75 (defclass gstring (boxed)
  76   ()
  77   (:metaclass boxed-class)
  78   (:alien-name "GString"))
  79
  80 (deftype-method translate-from-alien
  81     gstring (type-spec location &optional weak-ref)
  82   `(let ((location ,location))
  83      (unless (null-pointer-p location)
  84        (prog1
  85            (c-call::%naturalize-c-string location)
  86          ,(unless weak-ref
  87             (unreference-alien type-spec location))))))
  88
  89 (deftype-method translate-to-alien
  90     gstring (type-spec string &optional weak-ref)
  91   (declare (ignore type-spec weak-ref))
  92   `(let ((string ,string))
  93      ;; Always copy strings to prevent seg fault due to GC
  94      (funcall
  95       ',(proxy-class-copy (find-class type-spec))
  96       ',type-spec
  97       (make-pointer (1+ (kernel:get-lisp-obj-address string))))))
  98
  99 (deftype-method cleanup-alien gstring (type-spec c-string &optional weak-ref)
 100   (when weak-ref
 101     (unreference-alien type-spec c-string)))
 102