[gsharp-cvs] CVS update: gsharp/Flexichain/flexicursor.lisp gsharp/Flexichain/utilities.lisp

[Timothy Moore]

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