[flexichain-cvs] CVS update: flexichain/flexichain.lisp

[Cyrus Harmon]

Update of /project/flexichain/cvsroot/flexichain
In directory clnet:/tmp/cvs-serv25155

Modified Files:
	flexichain.lisp 
Log Message:

 * typep -> subtypep in array element type check
 * add new standard-flexichain initargs :initial-nb-elements
   and initial element. This allows for non-consing construction of
   flexichains filled with a given element, in addition to the old way
   of using :initial-contents.

Date: Fri Nov  3 18:24:09 2006
Author: charmon

Index: flexichain/flexichain.lisp
diff -u flexichain/flexichain.lisp:1.2 flexichain/flexichain.lisp:1.3
--- flexichain/flexichain.lisp:1.2	Tue Oct 17 12:02:02 2006
+++ flexichain/flexichain.lisp	Fri Nov  3 18:24:09 2006
@@ -154,7 +154,10 @@
 
 (defmethod initialize-instance :after ((chain standard-flexichain)
                                        &rest initargs
-                                       &key initial-contents)
+                                       &key
+                                       initial-contents
+                                       (initial-nb-elements 0)
+                                       (initial-element nil))
   (declare (ignore initargs))
   ;; Check initial-contents if provided
   (unless (null initial-contents)
@@ -169,22 +172,32 @@
                                offending-element element-type)))))
   ;; Initialize slots
   (with-slots (element-type fill-element buffer) chain
-     (let* ((data-length (length initial-contents))
+     (let* ((data-length (if (> (length initial-contents) initial-nb-elements)
+                             (length initial-contents)
+                             initial-nb-elements))
 	    (size (required-space chain data-length))
 	    (fill-size (- size data-length 2))
 	    (sentinel-list (make-list 2 :initial-element fill-element))
 	    (fill-list (make-list fill-size :initial-element fill-element)))
        (setf buffer
-	     (make-array size
-			 :element-type element-type
-			 :initial-contents (concatenate 'list
-							sentinel-list
-							initial-contents
-							fill-list)))))
-  (with-slots (gap-start gap-end data-start) chain
-     (setf gap-start (+ 2 (length initial-contents))
-	   gap-end 0
-	   data-start 1)))
+             (if initial-contents
+                 (make-array size
+                             :element-type element-type
+                             :initial-contents (concatenate 'list
+                                                            sentinel-list
+                                                            initial-contents
+                                                            fill-list))
+                 (let ((arr (make-array size
+                                        :element-type element-type
+                                        :initial-element initial-element)))
+                   (fill arr fill-element :end (length sentinel-list))
+                   (fill arr fill-element
+                         :start (+ (length sentinel-list) initial-nb-elements)
+                         :end size))))
+       (with-slots (gap-start gap-end data-start) chain
+         (setf gap-start (+ 2 data-length)
+               gap-end 0
+               data-start 1)))))
 
 (defmacro with-virtual-gap ((bl ds gs ge) chain &body body)
   (let ((c (gensym)))
@@ -252,7 +265,7 @@
   (with-slots (element-type buffer gap-start) chain
      (assert (<= 0 position (nb-elements chain)) ()
 	     'flexi-position-error :chain chain :position position)
-     (assert (typep (array-element-type  vector) element-type) ()
+     (assert (subtypep (array-element-type  vector) element-type) ()
 	     'flexi-incompatible-type-error :element vector :chain chain)
      (ensure-gap-position chain position)
      (ensure-room chain (+ (nb-elements chain) (length vector)))