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."))