From 8f96789a867b163e71781dc2599ae217bfe35ae4 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 10 Jun 2008 12:36:10 +0100
Subject: [PATCH] weak: Uniform interface to weak pointers.

---
 mdw.asd   |  1 +
 weak.lisp | 61 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 62 insertions(+)
 create mode 100644 weak.lisp

diff --git a/mdw.asd b/mdw.asd
index 0dc10a7..51f5981 100644
--- 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
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 --------------------------------------------------
-- 
2.11.0