Update of /project/flexichain/cvsroot/flexichain
In directory clnet:/tmp/cvs-serv25104
Modified Files:
flexichain.lisp flexicursor.lisp flexirank.lisp utilities.lisp
Log Message:
Patches to make weak pointers work on a number of platforms.
Thanks to Luís Oliveira.
Date: Tue Oct 17 12:02:02 2006
Author: rstrandh
Index: flexichain/flexichain.lisp
diff -u flexichain/flexichain.lisp:1.1.1.1 flexichain/flexichain.lisp:1.2
--- flexichain/flexichain.lisp:1.1.1.1 Wed Feb 8 21:51:06 2006
+++ flexichain/flexichain.lisp Tue Oct 17 12:02:02 2006
@@ -99,6 +99,12 @@
than the length of CHAIN, the FLEXI-POSITION-ERROR condition will be
signaled."))
+(defgeneric insert-vector* (chain position vector)
+ (:documentation "Inserts the elements of VECTOR before the
+element at POSITION in the chain. If POSITION is out of
+range (less than 0 or greater than the length of CHAIN, the
+FLEXI-POSITION-ERROR condition will be signaled."))
+
(defgeneric delete* (chain position)
(:documentation "Deletes an element at POSITION of the chain.
If POSITION is out of range (less than 0 or greater than or equal
Index: flexichain/flexicursor.lisp
diff -u flexichain/flexicursor.lisp:1.1.1.1 flexichain/flexicursor.lisp:1.2
--- flexichain/flexicursor.lisp:1.1.1.1 Wed Feb 8 21:51:06 2006
+++ flexichain/flexicursor.lisp Tue Oct 17 12:02:02 2006
@@ -96,8 +96,7 @@
(defgeneric (setf element>) (object cursor)
(:documentation "Replaces the element immediately after the cursor."))
-(defclass standard-cursorchain
- (weak-pointer-container-mixin cursorchain standard-flexichain)
+(defclass standard-cursorchain (cursorchain standard-flexichain)
((cursors :initform '()))
(:documentation "The standard instantiable subclass of CURSORCHAIN"))
@@ -116,7 +115,7 @@
(with-slots (index chain) cursor
(setf index (position-index chain (1- position)))
(with-slots (cursors) chain
- (push (make-weak-pointer cursor chain) cursors))))
+ (push (make-weak-pointer cursor) cursors))))
(defmethod initialize-instance :after ((cursor right-sticky-flexicursor)
&rest initargs &key (position 0))
@@ -124,12 +123,12 @@
(with-slots (index chain) cursor
(setf index (position-index chain position))
(with-slots (cursors) chain
- (push (make-weak-pointer cursor chain) cursors))))
+ (push (make-weak-pointer cursor) cursors))))
-(defun adjust-cursors (chain cursors start end increment)
+(defun adjust-cursors (cursors start end increment)
(let ((acc '()))
(loop
- for cursor = (and cursors (weak-pointer-value (car cursors) chain))
+ for cursor = (and cursors (weak-pointer-value (car cursors)))
while cursors
do (cond ((null cursor)
(pop cursors))
@@ -149,7 +148,7 @@
(defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2)
(declare (ignore to from))
(with-slots (cursors) cc
- (setf cursors (adjust-cursors cc cursors start2 (1- end2) (- start1 start2)))))
+ (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2)))))
(defmethod clone-cursor ((cursor standard-flexicursor))
(make-instance (class-of cursor)
@@ -195,7 +194,7 @@
(with-slots (cursors) chain
(let* ((old-index (position-index chain position)))
(loop for cursor-wp in cursors
- as cursor = (weak-pointer-value cursor-wp chain)
+ as cursor = (weak-pointer-value cursor-wp)
when (and cursor (= old-index (flexicursor-index cursor)))
do (typecase cursor
(right-sticky-flexicursor (incf (cursor-pos cursor)))
Index: flexichain/flexirank.lisp
diff -u flexichain/flexirank.lisp:1.2 flexichain/flexirank.lisp:1.3
--- flexichain/flexirank.lisp:1.2 Mon Mar 13 13:13:33 2006
+++ flexichain/flexirank.lisp Tue Oct 17 12:02:02 2006
@@ -58,6 +58,7 @@
(defclass flexirank-mixin () ())
(defmethod move-elements :before ((chain flexirank-mixin) to from start1 start2 end2)
+ (declare (ignore to))
(loop for old from start2 below end2
for new from start1
do (let ((element (aref from old)))
Index: flexichain/utilities.lisp
diff -u flexichain/utilities.lisp:1.2 flexichain/utilities.lisp:1.3
--- flexichain/utilities.lisp:1.2 Mon Mar 13 13:13:33 2006
+++ flexichain/utilities.lisp Tue Oct 17 12:02:02 2006
@@ -34,60 +34,52 @@
(values nil nil)
(values (elt sequence position) t))))
-;;; CMUCL and SBCL have direct support for weak pointers. In OpenMCL and
-;;; Allegro weak references are only supported via weak hash tables. This class
-;;; provides the means for other classes to manage their weak references.
-;;; TODO: check other CL implementations behavior wrt. return values
-(defclass weak-pointer-container-mixin ()
- (#+(or openmcl allegro)
- (weak-hash :initform (make-hash-table :test #'eql
- ;; Get it together guys!
- #+openmcl :weak #+openmcl :value
- #+allegro :values #+allegro :weak))
- (key-counter :initform 0))
- (:documentation "Support for weak references, if needed"))
+;;;; Weak pointers
-(defgeneric make-weak-pointer (object container))
-
-#+(or sbcl cmu)
-(defmethod make-weak-pointer (object container)
- (declare (ignore container))
- #+cmu (extensions:make-weak-pointer object)
- #+sbcl (sb-ext:make-weak-pointer object))
-
-#+(or openmcl allegro)
-(defmethod make-weak-pointer (object (container weak-pointer-container-mixin))
- (let ((key (incf (slot-value container 'key-counter))))
- (setf (gethash key (slot-value container 'weak-hash)) object)
- key))
-
-(defgeneric weak-pointer-value (weak-pointer container))
-
-#+(or sbcl cmu)
-(defmethod weak-pointer-value (weak-pointer container)
- (declare (ignore container))
- #+cmu (extensions:weak-pointer-value weak-pointer)
- #+sbcl (sb-ext:weak-pointer-value weak-pointer))
-
-#+(or openmcl allegro)
-(defmethod weak-pointer-value
- (weak-pointer (container weak-pointer-container-mixin))
- (let* ((table (slot-value container 'weak-hash))
- (val (gethash weak-pointer table)))
- #+allegro
- (unless val
- (remhash weak-pointer table))
- val))
-
-#-(or sbcl cmu openmcl)
-(progn
- (eval-when (:evaluate :compile-toplevel :load-toplevel)
- (warn "No support for weak pointers in this implementation. Things may
-get big and slow")
- )
- (defmethod make-weak-pointer (object container)
- (declare (ignore container))
- object)
- (defmethod weak-pointer-value (weak-pointer container)
- (declare (ignore container))
- weak-pointer))
+#+:openmcl
+(defvar *weak-pointers* (make-hash-table :test 'eq :weak :value)
+ "Weak value hash-table mapping between pseudo weak pointers and its values.")
+
+#+:openmcl
+(defstruct (weak-pointer (:constructor %make-weak-pointer)))
+
+(defun make-weak-pointer (object)
+ "Creates a new weak pointer which points to OBJECT. For
+ portability reasons, OBJECT most not be NIL."
+ (assert (not (null object)))
+ #+:sbcl (sb-ext:make-weak-pointer object)
+ #+:cmu (ext:make-weak-pointer object)
+ #+:clisp (ext:make-weak-pointer object)
+ #+:allegro
+ (let ((wv (excl:weak-vector 1)))
+ (setf (svref wv 0) object)
+ wv)
+ #+:openmcl
+ (let ((wp (%make-weak-pointer)))
+ (setf (gethash wp *weak-pointers*) object)
+ wp)
+ #+:corman (ccl:make-weak-pointer object)
+ #+:lispworks
+ (let ((array (make-array 1)))
+ (hcl:set-array-weak array t)
+ (setf (svref array 0) object)
+ array)
+ #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks)
+ object)
+
+(defun weak-pointer-value (weak-pointer)
+ "If WEAK-POINTER is valid, returns its value. Otherwise, returns NIL."
+ #+:sbcl (prog1 (sb-ext:weak-pointer-value weak-pointer))
+ #+:cmu (prog1 (ext:weak-pointer-value weak-pointer))
+ #+:clisp (prog1 (ext:weak-pointer-value weak-pointer))
+ #+:allegro (svref weak-pointer 0)
+ #+:openmcl (prog1 (gethash weak-pointer *weak-pointers*))
+ #+:corman (ccl:weak-pointer-obj weak-pointer)
+ #+:lispworks (svref weak-pointer 0)
+ #-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks)
+ weak-pointer)
+
+#-(or :sbcl :cmu :clisp :allegro :openmcl :corman :lispworks)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (warn "No support for weak pointers in this implementation. ~
+ Things may get big and slow."))
