weak: Uniform interface to weak pointers.

diff --git a/mdw.asd b/mdw.asd
index 0dc10a7..51f5981 100644 (file)
--- a/mdw.asd
+++ b/mdw.asd
@@ -13,6 +13,7 @@
               (:file "sys-base")
               (:file "factorial")
               (:file "queue")
+              (:file "weak")
               (:file "dep" :depends-on ("queue"))
               (:file "mdw-mop" :depends-on ("mdw-base"))
               (:file "str" :depends-on ("mdw-base"))

diff --git a/weak.lisp b/weak.lisp
new file mode 100644 (file)
index 0000000..ff7c9c3
--- /dev/null
+++ b/weak.lisp
@@ -0,0 +1,61 @@
+;;; -*-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 --------------------------------------------------