/[flexichain]/flexichain/utilities.lisp
ViewVC logotype

Contents of /flexichain/utilities.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Oct 17 16:02:02 2006 UTC (7 years, 6 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +48 -56 lines
Patches to make weak pointers work on a number of platforms.

Thanks to Luís Oliveira.
1 ;;; Flexichain
2 ;;; Utility functions
3 ;;;
4 ;;; Copyright (C) 2003-2004 Robert Strandh (strandh@labri.fr)
5 ;;; Copyright (C) 2003-2004 Matthieu Villeneuve (matthieu.villeneuve@free.fr)
6 ;;;
7 ;;; This library is free software; you can redistribute it and/or
8 ;;; modify it under the terms of the GNU Lesser General Public
9 ;;; License as published by the Free Software Foundation; either
10 ;;; version 2.1 of the License, or (at your option) any later version.
11 ;;;
12 ;;; This library is distributed in the hope that it will be useful,
13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 ;;; Lesser General Public License for more details.
16 ;;;
17 ;;; You should have received a copy of the GNU Lesser General Public
18 ;;; License along with this library; if not, write to the Free Software
19 ;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20
21
22 (in-package :flexichain)
23
24 (defun square (x)
25 "Returns the square of the number X."
26 (* x x))
27
28 (defun find-if-2 (predicate sequence)
29 "Searches the sequence for an element that satisfies PREDICATE.
30 Returns the element found or NIL of none was found, and a boolean
31 indicating whether an element was found or not."
32 (let ((position (position-if predicate sequence)))
33 (if (null position)
34 (values nil nil)
35 (values (elt sequence position) t))))
36
37 ;;;; Weak pointers
38
39 #+:openmcl
40 (defvar *weak-pointers* (make-hash-table :test 'eq :weak :value)
41 "Weak value hash-table mapping between pseudo weak pointers and its values.")
42
43 #+:openmcl
44 (defstruct (weak-pointer (:constructor %make-weak-pointer)))
45
46 (defun make-weak-pointer (object)
47 "Creates a new weak pointer which points to OBJECT. For
48 portability reasons, OBJECT most not be NIL."
49 (assert (not (null object)))
50 #+:sbcl (sb-ext:make-weak-pointer object)
51 #+:cmu (ext:make-weak-pointer object)
52 #+:clisp (ext:make-weak-pointer object)
53 #+:allegro
54 (let ((wv (excl:weak-vector 1)))
55 (setf (svref wv 0) object)
56 wv)
57 #+:openmcl
58 (let ((wp (%make-weak-pointer)))
59 (setf (gethash wp *weak-pointers*) object)
60 wp)
61 #+:corman (ccl:make-weak-pointer object)
62 #+:lispworks
63 (let ((array (make-array 1)))
64 (hcl:set-array-weak array t)
65 (setf (svref array 0) object)
66 array)
67 #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks)
68 object)
69
70 (defun weak-pointer-value (weak-pointer)
71 "If WEAK-POINTER is valid, returns its value. Otherwise, returns NIL."
72 #+:sbcl (prog1 (sb-ext:weak-pointer-value weak-pointer))
73 #+:cmu (prog1 (ext:weak-pointer-value weak-pointer))
74 #+:clisp (prog1 (ext:weak-pointer-value weak-pointer))
75 #+:allegro (svref weak-pointer 0)
76 #+:openmcl (prog1 (gethash weak-pointer *weak-pointers*))
77 #+:corman (ccl:weak-pointer-obj weak-pointer)
78 #+:lispworks (svref weak-pointer 0)
79 #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks)
80 weak-pointer)
81
82 #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks)
83 (eval-when (:compile-toplevel :load-toplevel :execute)
84 (warn "No support for weak pointers in this implementation. ~
85 Things may get big and slow."))

  ViewVC Help
Powered by ViewVC 1.1.5