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

Contents of /flexichain/utilities.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Mon Mar 13 18:13:33 2006 UTC (8 years, 1 month ago) by rstrandh
Branch: MAIN
CVS Tags: release-1-1
Changes since 1.1: +19 -11 lines
Improvements from Tim Moore with respect to weak pointers on Allegro.
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.2 ;;; CMUCL and SBCL have direct support for weak pointers. In OpenMCL and
38     ;;; Allegro weak references are only supported via weak hash tables. This class
39     ;;; provides the means for other classes to manage their weak references.
40 rkreuter 1.1 ;;; TODO: check other CL implementations behavior wrt. return values
41     (defclass weak-pointer-container-mixin ()
42 rstrandh 1.2 (#+(or openmcl allegro)
43     (weak-hash :initform (make-hash-table :test #'eql
44     ;; Get it together guys!
45     #+openmcl :weak #+openmcl :value
46     #+allegro :values #+allegro :weak))
47     (key-counter :initform 0))
48 rkreuter 1.1 (:documentation "Support for weak references, if needed"))
49    
50     (defgeneric make-weak-pointer (object container))
51    
52     #+(or sbcl cmu)
53     (defmethod make-weak-pointer (object container)
54     (declare (ignore container))
55     #+cmu (extensions:make-weak-pointer object)
56     #+sbcl (sb-ext:make-weak-pointer object))
57    
58 rstrandh 1.2 #+(or openmcl allegro)
59 rkreuter 1.1 (defmethod make-weak-pointer (object (container weak-pointer-container-mixin))
60 rstrandh 1.2 (let ((key (incf (slot-value container 'key-counter))))
61 rkreuter 1.1 (setf (gethash key (slot-value container 'weak-hash)) object)
62     key))
63    
64     (defgeneric weak-pointer-value (weak-pointer container))
65    
66     #+(or sbcl cmu)
67     (defmethod weak-pointer-value (weak-pointer container)
68     (declare (ignore container))
69     #+cmu (extensions:weak-pointer-value weak-pointer)
70     #+sbcl (sb-ext:weak-pointer-value weak-pointer))
71    
72 rstrandh 1.2 #+(or openmcl allegro)
73 rkreuter 1.1 (defmethod weak-pointer-value
74     (weak-pointer (container weak-pointer-container-mixin))
75 rstrandh 1.2 (let* ((table (slot-value container 'weak-hash))
76     (val (gethash weak-pointer table)))
77     #+allegro
78     (unless val
79     (remhash weak-pointer table))
80     val))
81 rkreuter 1.1
82     #-(or sbcl cmu openmcl)
83     (progn
84     (eval-when (:evaluate :compile-toplevel :load-toplevel)
85 rstrandh 1.2 (warn "No support for weak pointers in this implementation. Things may
86 rkreuter 1.1 get big and slow")
87     )
88     (defmethod make-weak-pointer (object container)
89     (declare (ignore container))
90     object)
91     (defmethod weak-pointer-value (weak-pointer container)
92     (declare (ignore container))
93     weak-pointer))

  ViewVC Help
Powered by ViewVC 1.1.5