+;;; -*-lisp-*-
+;;;
+;;; Weak pointers and data structures
+;;;
+;;; (c) 2008 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:defpackage #:weak
+ (:use #:common-lisp)
+ #+sbcl
+ (:import-from #:sb-ext #:make-weak-pointer #:weak-pointer-value)
+ #+(or cmu clisp)
+ (:import-from #:ext #:make-weak-pointer #:weak-pointer-value)
+ (:export #:make-weak-pointer #:weak-pointer-value))
+(cl:in-package #:weak)
+
+#+(or allegro common-lispworks)
+(progn
+ (defun make-weak-pointer (object)
+ (make-array 1 :initial-contents (list object) :weak t))
+ (defun weak-pointer-value (weak)
+ (aref weak 0)))
+
+#+ecl
+(progn
+ (defun make-weak-pointer (object)
+ (ffi:c-inline (object) (:object) :pointer-void
+ "{ cl_object *weak = GC_malloc_atomic(sizeof(cl_object));
+ *weak = #0;
+ GC_general_register_disappearing_link(weak, GC_base(#0));
+ @(return) = weak; }"
+ :one-liner nil))
+ (defun weak-pointer-value (weak)
+ (ffi:c-inline (weak) (:pointer-void) (values :object :object)
+ "{ cl_object *weak = #0;
+ if (*weak) { @(return 0) = *weak; @(return 1) = @t; }
+ else { @(return 0) = @nil; @(return 1) = @nil; } }"
+ :one-liner nil)))
+
+#-(or sbcl cmu clisp allegro common-lispworks ecl)
+(progn
+ (defun make-weak-pointer (object) object)
+ (defun weak-pointer-value (weak) (values weak t)))
+
+;;;----- That's all, folks --------------------------------------------------