glib/gobject.stable-pointer.lisp

   1 (in-package :gobject)
   2
   3 (defvar *registered-stable-pointers* (make-array 0 :adjustable t :fill-pointer t))
   4
   5 (defun allocate-stable-pointer (thing)
   6   "Allocates the stable pointer for @code{thing}. Stable pointer is an integer that can be dereferenced with @fun{get-stable-pointer-value} and freed with @fun{free-stable-pointer}. Stable pointers are used to pass references to lisp objects to foreign code.
   7 @arg[thing]{any object}
   8 @return{integer}"
   9   (let ((id (find-fresh-id)))
  10     (setf (aref *registered-stable-pointers* id) thing)
  11     (make-pointer id)))
  12
  13 (defun free-stable-pointer (stable-pointer)
  14   "Frees the stable pointer previously allocated by @fun{allocate-stable-pointer}"
  15   (setf (aref *registered-stable-pointers* (pointer-address stable-pointer)) nil))
  16
  17 (defun get-stable-pointer-value (stable-pointer)
  18   "Returns the objects that is referenced by stable pointer previously allocated by @fun{allocate-stable-pointer}. May be called any number of times."
  19   (when (<= 0 (pointer-address stable-pointer) (length *registered-stable-pointers*))
  20     (aref *registered-stable-pointers* (pointer-address stable-pointer))))
  21
  22 (defun set-stable-pointer-value (stable-pointer value)
  23   "Returns the objects that is referenced by stable pointer previously allocated by @fun{allocate-stable-pointer}. May be called any number of times."
  24   (when (<= 0 (pointer-address stable-pointer) (length *registered-stable-pointers*))
  25     (setf (aref *registered-stable-pointers* (pointer-address stable-pointer)) value)))
  26
  27 (defun stable-pointer-value (stable-pointer)
  28   (get-stable-pointer-value stable-pointer))
  29
  30 (defun (setf stable-pointer-value) (new-value stable-pointer)
  31   (set-stable-pointer-value stable-pointer new-value))
  32
  33 (defun find-fresh-id ()
  34   (or (position nil *registered-stable-pointers*)
  35       (progn (vector-push-extend nil *registered-stable-pointers*)
  36              (1- (length *registered-stable-pointers*)))))
  37
  38 (defmacro with-stable-pointer ((ptr expr) &body body)
  39   "Executes @code{body} with @code{ptr} bound to the stable pointer to result of evaluating @code{expr}.
  40
  41 @arg[ptr]{a symbol naming the variable which will hold the stable pointer value}
  42 @arg[expr]{an expression}"
  43   `(let ((,ptr (allocate-stable-pointer ,expr)))
  44      (unwind-protect
  45           (progn ,@body)
  46        (free-stable-pointer ,ptr))))