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

Contents of /flexichain/utilities.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide 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 rkreuter 1.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 rstrandh 1.3 ;;;; Weak pointers
38 rkreuter 1.1
39 rstrandh 1.3 #+: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