Update of /project/gsharp/cvsroot/gsharp/Flexichain In directory common-lisp.net:/tmp/cvs-serv18364 Modified Files: flexicursor.lisp utilities.lisp Log Message: Generalized weak pointer support and added an implementation for OpenMCL. Date: Fri Jan 14 17:12:42 2005 Author: tmoore Index: gsharp/Flexichain/flexicursor.lisp diff -u gsharp/Flexichain/flexicursor.lisp:1.9 gsharp/Flexichain/flexicursor.lisp:1.10 --- gsharp/Flexichain/flexicursor.lisp:1.9 Mon Jan 3 07:44:42 2005 +++ gsharp/Flexichain/flexicursor.lisp Fri Jan 14 17:12:41 2005 @@ -96,18 +96,11 @@ (defgeneric (setf element>) (object cursor) (:documentation "Replaces the element immediately after the cursor.")) -(defclass standard-cursorchain (cursorchain standard-flexichain) +(defclass standard-cursorchain + (weak-pointer-container-mixin cursorchain standard-flexichain) ((cursors :initform '())) (:documentation "The standard instantiable subclass of CURSORCHAIN")) -(defun make-wp (value) - #+sbcl (sb-ext:make-weak-pointer value) - #+cmu (ext:make-weak-pointer value)) - -(defun wp-value (wp) - #+sbcl (sb-ext:weak-pointer-value wp) - #+cmu (ext:weak-pointer-value wp)) - (defclass standard-flexicursor (flexicursor) ((chain :reader chain :initarg :chain) (index :accessor flexicursor-index)) @@ -123,7 +116,7 @@ (with-slots (index chain) cursor (setf index (position-index chain (1- position))) (with-slots (cursors) chain - (push (make-wp cursor) cursors)))) + (push (make-weak-pointer cursor chain) cursors)))) (defmethod initialize-instance :after ((cursor right-sticky-flexicursor) &rest initargs &key (position 0)) @@ -131,30 +124,32 @@ (with-slots (index chain) cursor (setf index (position-index chain position)) (with-slots (cursors) chain - (push (make-wp cursor) cursors)))) + (push (make-weak-pointer cursor chain) cursors)))) -(defun adjust-cursors (cursors start end increment) +(defun adjust-cursors (chain cursors start end increment) (let ((acc '())) - (loop while cursors - do (cond ((null (wp-value (car cursors))) - (pop cursors)) - ((<= start (flexicursor-index (wp-value (car cursors))) end) - (incf (flexicursor-index (wp-value (car cursors))) increment) + (loop + for cursor = (and cursors (weak-pointer-value (car cursors) chain)) + while cursors + do (cond ((null cursor) + (pop cursors)) + ((<= start (flexicursor-index cursor) end) + (incf (flexicursor-index cursor) increment) (let ((rest (cdr cursors))) (setf (cdr cursors) acc acc cursors cursors rest))) - (t - (let ((rest (cdr cursors))) - (setf (cdr cursors) acc - acc cursors - cursors rest))))) + (t + (let ((rest (cdr cursors))) + (setf (cdr cursors) acc + acc cursors + cursors rest))))) acc)) (defmethod move-elements :after ((cc standard-cursorchain) to from start1 start2 end2) (declare (ignore to from)) (with-slots (cursors) cc - (setf cursors (adjust-cursors cursors start2 (1- end2) (- start1 start2))))) + (setf cursors (adjust-cursors cc cursors start2 (1- end2) (- start1 start2))))) (defmethod clone-cursor ((cursor standard-flexicursor)) (make-instance (class-of cursor) @@ -200,7 +195,7 @@ (with-slots (cursors) chain (let* ((old-index (position-index chain position))) (loop for cursor-wp in cursors - as cursor = (wp-value cursor-wp) + as cursor = (weak-pointer-value cursor-wp chain) when (and cursor (= old-index (flexicursor-index cursor))) do (typecase cursor (right-sticky-flexicursor (incf (cursor-pos cursor))) Index: gsharp/Flexichain/utilities.lisp diff -u gsharp/Flexichain/utilities.lisp:1.1 gsharp/Flexichain/utilities.lisp:1.2 --- gsharp/Flexichain/utilities.lisp:1.1 Sun Aug 1 17:27:19 2004 +++ gsharp/Flexichain/utilities.lisp Fri Jan 14 17:12:41 2005 @@ -34,17 +34,52 @@ (values nil nil) (values (elt sequence position) t)))) -(defun make-weak-pointer (object) - "Returns a weak pointer to OBJECT." - #+cmu (extensions:make-weak-pointer object) - #+sbcl (sb-ext:make-weak-pointer object) - #-(or cmu sbcl) (error "MAKE-WEAK-POINTER not implemented.")) - -(defun weak-pointer-value (weak-pointer) - ;; TODO: check other CL implementations behavior wrt. return values - "Returns the object pointed to by WEAK-POINTER or NIL if the pointer -is broken." +;;; CMUCL and SBCL have direct support for weak pointers. In OpenMCL 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 () + #+openmcl + ((weak-hash :initform (make-hash-table :test #'eq :weak :value))) + (:documentation "Support for weak references, if needed")) + +(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)) + +#+openmcl +(defmethod make-weak-pointer (object (container weak-pointer-container-mixin)) + (let ((key (cons nil nil))) + (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 cmu sbcl) (error "WEAK-POINTER-VALUE not implemented.")) + #+sbcl (sb-ext:weak-pointer-value weak-pointer)) + +#+openmcl +(defmethod weak-pointer-value + (weak-pointer (container weak-pointer-container-mixin)) + (gethash weak-pointer (slot-value container 'weak-hash) nil)) +#-(or sbcl cmu openmcl) +(progn + (eval-when (:evaluate :compile-toplevel :load-toplevel) + (warning "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))