Greetings! And thanks for your report!
If you would cae to try out the pach below, I'd be most appreciative!
=============================================================================
Index: lsp/gcl_arraylib.lsp
===================================================================
RCS file: /sources/gcl/gcl/lsp/gcl_arraylib.lsp,v
retrieving revision 1.1.2.1
diff -u -u -r1.1.2.1 gcl_arraylib.lsp
--- lsp/gcl_arraylib.lsp 14 Sep 2003 02:30:35 -0000 1.1.2.1
+++ lsp/gcl_arraylib.lsp 18 Jan 2012 17:58:46 -0000
@@ -74,47 +74,73 @@
(defun make-array (dimensions
&key (element-type t)
- (initial-element nil)
+ initial-element
(initial-contents nil initial-contents-supplied-p)
adjustable fill-pointer
displaced-to (displaced-index-offset 0)
static)
(when (integerp dimensions) (setq dimensions (list dimensions)))
- (setq element-type (best-array-element-type element-type))
- (cond ((= (length dimensions) 1)
- (let ((x (si:make-vector element-type (car dimensions)
- adjustable fill-pointer
- displaced-to displaced-index-offset
- static initial-element)))
- (when initial-contents-supplied-p
- (do ((n (car dimensions))
- (i 0 (1+ i)))
- ((>= i n))
- (declare (fixnum n i))
- (si:aset x i (elt initial-contents i))))
- x))
- (t
- (let ((x
- (make-array1
- (the fixnum(get-aelttype element-type))
- static initial-element
- displaced-to (the fixnum displaced-index-offset)
- dimensions)))
- (if fill-pointer (error "fill pointer for 1 dimensional arrays
only"))
- (unless (member 0 dimensions)
- (when initial-contents-supplied-p
- (do ((cursor
- (make-list (length dimensions)
- :initial-element 0)))
- (nil)
- (declare (:dynamic-extent cursor))
- (aset-by-cursor x
- (sequence-cursor initial-contents
- cursor)
- cursor)
- (when (increment-cursor cursor dimensions)
- (return nil)))))
- x))))
+ (setq element-type (or (upgraded-array-element-type element-type)
'character))
+ (if (= (length dimensions) 1)
+ (let ((x (si:make-vector element-type (car dimensions) adjustable (when
fill-pointer (car dimensions))
+ displaced-to displaced-index-offset static
initial-element)))
+ (when initial-contents-supplied-p
+ (replace x initial-contents))
+ (when (and fill-pointer (not (eq t fill-pointer))) (setf (fill-pointer
x) fill-pointer))
+ x)
+ (let ((x (make-array1 (get-aelttype element-type) static initial-element
displaced-to displaced-index-offset dimensions)))
+ (if fill-pointer (error "fill pointer for 1 dimensional arrays only"))
+ (unless (member 0 dimensions)
+ (when initial-contents-supplied-p
+ (do ((j nil t)(cursor (make-list (length dimensions) :initial-element
0)))
+ ((when j (increment-cursor cursor dimensions)))
+ (declare (:dynamic-extent cursor))
+ (aset-by-cursor x (sequence-cursor initial-contents cursor)
cursor))))
+ x)))
+
+;; (defun make-array (dimensions
+;; &key (element-type t)
+;; (initial-element nil)
+;; (initial-contents nil initial-contents-supplied-p)
+;; adjustable fill-pointer
+;; displaced-to (displaced-index-offset 0)
+;; static)
+;; (when (integerp dimensions) (setq dimensions (list dimensions)))
+;; (setq element-type (best-array-element-type element-type))
+;; (cond ((= (length dimensions) 1)
+;; (let ((x (si:make-vector element-type (car dimensions)
+;; adjustable fill-pointer
+;; displaced-to displaced-index-offset
+;; static initial-element)))
+;; (when initial-contents-supplied-p
+;; (do ((n (car dimensions))
+;; (i 0 (1+ i)))
+;; ((>= i n))
+;; (declare (fixnum n i))
+;; (si:aset x i (elt initial-contents i))))
+;; x))
+;; (t
+;; (let ((x
+;; (make-array1
+;; (the fixnum(get-aelttype element-type))
+;; static initial-element
+;; displaced-to (the fixnum displaced-index-offset)
+;; dimensions)))
+;; (if fill-pointer (error "fill pointer for 1 dimensional arrays
only"))
+;; (unless (member 0 dimensions)
+;; (when initial-contents-supplied-p
+;; (do ((cursor
+;; (make-list (length dimensions)
+;; :initial-element 0)))
+;; (nil)
+;; (declare (:dynamic-extent cursor))
+;; (aset-by-cursor x
+;; (sequence-cursor initial-contents
+;; cursor)
+;; cursor)
+;; (when (increment-cursor cursor dimensions)
+;; (return nil)))))
+;; x))))
(defun increment-cursor (cursor dimensions)
Index: lsp/gcl_seqlib.lsp
===================================================================
RCS file: /sources/gcl/gcl/lsp/gcl_seqlib.lsp,v
retrieving revision 1.1.2.2
diff -u -u -r1.1.2.2 gcl_seqlib.lsp
--- lsp/gcl_seqlib.lsp 20 Mar 2004 02:00:01 -0000 1.1.2.2
+++ lsp/gcl_seqlib.lsp 18 Jan 2012 17:58:46 -0000
@@ -149,33 +149,53 @@
(setf (elt sequence i) item))))
-(defun replace (sequence1 sequence2
- &key start1 end1
- start2 end2 )
- (with-start-end start1 end1 sequence1
- (with-start-end start2 end2 sequence2
- (if (and (eq sequence1 sequence2)
- (> start1 start2))
- (do* ((i 0 (f+ 1 i))
- (l (if (< (f- end1 start1)
- (f- end2 start2))
- (f- end1 start1)
- (f- end2 start2)))
- (s1 (f+ start1 (f+ -1 l)) (f+ -1 s1))
- (s2 (f+ start2 (f+ -1 l)) (f+ -1 s2)))
- ((>= i l) sequence1)
- (declare (fixnum i l s1 s2))
- (setf (elt sequence1 s1) (elt sequence2 s2)))
- (do ((i 0 (f+ 1 i))
- (l (if (< (f- end1 start1)
- (f- end2 start2))
- (f- end1 start1)
- (f- end2 start2)))
- (s1 start1 (f+ 1 s1))
- (s2 start2 (f+ 1 s2)))
- ((>= i l) sequence1)
- (declare (fixnum i l s1 s2))
- (setf (elt sequence1 s1) (elt sequence2 s2)))))))
+(defun replace (s1 s2 &key (start1 0) end1 (start2 0) end2 &aux (os1 s1) s3)
+ (declare (optimize (safety 1))(notinline make-list)(dynamic-extent s3))
+ (check-type s1 sequence)
+ (check-type s2 sequence)
+ (check-type start1 seqind)
+ (check-type start2 seqind)
+ (check-type end1 (or null seqind))
+ (check-type end2 (or null seqind))
+ (when (and (eq s1 s2) (> start1 start2))
+ (setq s3 (make-list (length s2)) s2 (replace s3 s2)))
+ (let* ((lp1 (listp s1)) (lp2 (listp s2))
+ (e1 (or end1 (if lp1 array-dimension-limit (length s1))))
+ (e2 (or end2 (if lp2 array-dimension-limit (length s2)))))
+ (do ((i1 start1 (1+ i1))(i2 start2 (1+ i2))
+ (s1 (if lp1 (nthcdr start1 s1) s1) (if lp1 (cdr s1) s1))
+ (s2 (if lp2 (nthcdr start2 s2) s2) (if lp2 (cdr s2) s2)))
+ ((or (not s1) (>= i1 e1) (not s2) (>= i2 e2)) os1)
+ (let ((e2 (if lp2 (car s2) (aref s2 i2))))
+ (if lp1 (setf (car s1) e2) (setf (aref s1 i1) e2))))))
+
+;; (defun replace (sequence1 sequence2
+;; &key start1 end1
+;; start2 end2 )
+;; (with-start-end start1 end1 sequence1
+;; (with-start-end start2 end2 sequence2
+;; (if (and (eq sequence1 sequence2)
+;; (> start1 start2))
+;; (do* ((i 0 (f+ 1 i))
+;; (l (if (< (f- end1 start1)
+;; (f- end2 start2))
+;; (f- end1 start1)
+;; (f- end2 start2)))
+;; (s1 (f+ start1 (f+ -1 l)) (f+ -1 s1))
+;; (s2 (f+ start2 (f+ -1 l)) (f+ -1 s2)))
+;; ((>= i l) sequence1)
+;; (declare (fixnum i l s1 s2))
+;; (setf (elt sequence1 s1) (elt sequence2 s2)))
+;; (do ((i 0 (f+ 1 i))
+;; (l (if (< (f- end1 start1)
+;; (f- end2 start2))
+;; (f- end1 start1)
+;; (f- end2 start2)))
+;; (s1 start1 (f+ 1 s1))
+;; (s2 start2 (f+ 1 s2)))
+;; ((>= i l) sequence1)
+;; (declare (fixnum i l s1 s2))
+;; (setf (elt sequence1 s1) (elt sequence2 s2)))))))
;;; DEFSEQ macro.
=============================================================================
John Lapeyre <lapeyre.math1...@gmail.com> writes:
> In gcl make-array with :initial-contents from a list
> is poorly implemented in that the copying is O(n^2).
> A test on one machine shows that initializing a
> list of length of 5 10^4 takes 1 minute in gcl and a few ms in sbcl.
>
> This potentially affects some code in the share directory.
>
> The relevant part of the gcl code in make-array is:
>
> ((= (length dimensions) 1)
> (let ((x (si:make-vector element-type (car dimensions)
> adjustable fill-pointer
> displaced-to displaced-index-offset
> static initial-element)))
> (when initial-contents-supplied-p
> (do ((n (car dimensions))
> (i 0 (1+ i)))
> ((>= i n))
> (declare (fixnum n i))
> (si:aset x i (elt initial-contents i))))
> x))
>
> The following passed a quick test:
>
> ((= (length dimensions) 1)
> (let ((x (si:make-vector element-type (car dimensions)
> adjustable fill-pointer
> displaced-to displaced-index-offset
> static initial-element)))
> (when initial-contents-supplied-p
> (if (listp initial-contents)
> (do ( (e initial-contents (cdr e))
> (i 0 (1+ i)))
> ((null e))
> (declare (fixnum i))
> (si:aset x i (car e)))
> (do ((n (car dimensions))
> (i 0 (1+ i)))
> ((>= i n))
> (declare (fixnum n i))
> (si:aset x i (elt initial-contents i)))))
> x))
>
> -- John Lapeyre
> _______________________________________________
> Maxima mailing list
> max...@math.utexas.edu
> http://www.math.utexas.edu/mailman/listinfo/maxima
>
>
>
>
--
Camm Maguire c...@maguirefamily.org
==========================================================================
"The earth is but one country, and mankind its citizens." -- Baha'u'llah
_______________________________________________
Gcl-devel mailing list
Gcl-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/gcl-devel
