Commit | Line | Data |
---|---|---|
8f96789a MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Weak pointers and data structures | |
4 | ;;; | |
5 | ;;; (c) 2008 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This program is free software; you can redistribute it and/or modify | |
11 | ;;; it under the terms of the GNU General Public License as published by | |
12 | ;;; the Free Software Foundation; either version 2 of the License, or | |
13 | ;;; (at your option) any later version. | |
14 | ;;; | |
15 | ;;; This program is distributed in the hope that it will be useful, | |
16 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;;; GNU General Public License for more details. | |
19 | ;;; | |
20 | ;;; You should have received a copy of the GNU General Public License | |
21 | ;;; along with this program; if not, write to the Free Software Foundation, | |
22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
24 | (cl:defpackage #:weak | |
25 | (:use #:common-lisp) | |
26 | #+sbcl | |
27 | (:import-from #:sb-ext #:make-weak-pointer #:weak-pointer-value) | |
28 | #+(or cmu clisp) | |
29 | (:import-from #:ext #:make-weak-pointer #:weak-pointer-value) | |
30 | (:export #:make-weak-pointer #:weak-pointer-value)) | |
31 | (cl:in-package #:weak) | |
32 | ||
33 | #+(or allegro common-lispworks) | |
34 | (progn | |
35 | (defun make-weak-pointer (object) | |
36 | (make-array 1 :initial-contents (list object) :weak t)) | |
37 | (defun weak-pointer-value (weak) | |
38 | (aref weak 0))) | |
39 | ||
40 | #+ecl | |
41 | (progn | |
6d23b6ba MW |
42 | (ffi:clines |
43 | "static GC_PTR fetch_obj(GC_PTR p) { return *(cl_object *)p; }") | |
8f96789a | 44 | (defun make-weak-pointer (object) |
6d23b6ba MW |
45 | (ffi:c-inline (object) (:object) :pointer-void " |
46 | { | |
47 | cl_object *weak = GC_malloc_atomic(sizeof(cl_object)); | |
48 | *weak = #0; | |
49 | GC_general_register_disappearing_link(weak, GC_base(#0)); | |
50 | @(return) = weak; | |
51 | }" | |
8f96789a MW |
52 | :one-liner nil)) |
53 | (defun weak-pointer-value (weak) | |
6d23b6ba MW |
54 | (ffi:c-inline (weak) (:pointer-void) (values :object :object) " |
55 | { | |
56 | cl_object obj = GC_call_with_alloc_lock(fetch_obj, #0); | |
57 | if (obj) { @(return 0) = obj; @(return 1) = @t; } | |
58 | else { @(return 0) = @nil; @(return 1) = @nil; } | |
59 | }" | |
8f96789a MW |
60 | :one-liner nil))) |
61 | ||
62 | #-(or sbcl cmu clisp allegro common-lispworks ecl) | |
63 | (progn | |
64 | (defun make-weak-pointer (object) object) | |
65 | (defun weak-pointer-value (weak) (values weak t))) | |
66 | ||
67 | ;;;----- That's all, folks -------------------------------------------------- |