Import Upstream version 3a4upstream/3a4

1 files changed, 47 insertions, 34 deletions

diff --git a/array.scm b/array.scm
index 5f87b98..ff05fd0 100644
--- a/array.scm
+++ b/array.scm
@@ -1,5 +1,5 @@
 ;;;;"array.scm" Arrays for Scheme
-; Copyright (C) 2001, 2003, 2005 Aubrey Jaffer
+; Copyright (C) 2001, 2003, 2005, 2006 Aubrey Jaffer
 ;
 ;Permission to copy this software, to modify it, to redistribute it,
 ;to distribute modified versions, and to use it for any purpose is
@@ -110,21 +110,26 @@
 	 (and (pair? obj1) (pair? obj2)
 	      (equal? (car obj1) (car obj2))
 	      (equal? (cdr obj1) (cdr obj2))))
-	((or (string? obj1) (string? obj2))
-	 (and (string? obj1) (string? obj2)
-	      (string=? obj1 obj2)))
-	((or (vector? obj1) (vector? obj2))
-	 (and (vector? obj1) (vector? obj2)
-	      (equal? (vector-length obj1) (vector-length obj2))
+	((and (string? obj1) (string? obj2))
+	 (string=? obj1 obj2))
+	((and (vector? obj1) (vector? obj2))
+	 (and (equal? (vector-length obj1) (vector-length obj2))
 	      (do ((idx (+ -1 (vector-length obj1)) (+ -1 idx)))
 		  ((or (negative? idx)
 		       (not (equal? (vector-ref obj1 idx)
 				    (vector-ref obj2 idx))))
 		   (negative? idx)))))
-	((or (array? obj1) (array? obj2))
-	 (and (array? obj1) (array? obj2)
-	      (equal? (array:dimensions obj1) (array:dimensions obj2))
-	      (equal? (array:store obj1) (array:store obj2))))
+	((and (array? obj1) (array? obj2))
+	 (and (equal? (array:dimensions obj1) (array:dimensions obj2))
+	      (letrec ((rascan
+			(lambda (dims idxs)
+			  (if (null? dims)
+			      (equal? (apply array-ref obj1 idxs)
+				      (apply array-ref obj2 idxs))
+			      (do ((res #t (rascan (cdr dims) (cons idx idxs)))
+				   (idx (+ -1 (car dims)) (+ -1 idx)))
+				  ((or (not res) (negative? idx)) res))))))
+		(rascan (reverse (array:dimensions obj1)) '()))))
 	(else #f)))
 
 ;;@body
@@ -155,24 +160,30 @@
 ;;array are unspecified.  Otherwise, the returned array will be filled
 ;;with the element at the origin of @1.
 (define (make-array prototype . dimensions)
+  (define prot (array:store prototype))
+  (define pdims (array:dimensions prototype))
+  (define onedim? (eqv? 1 (length dimensions)))
   (define tcnt (apply * dimensions))
-  (let ((store
-	 (if (string? prototype)
-	     (case (string-length prototype)
-	       ((0) (make-string tcnt))
-	       (else (make-string tcnt
-				  (string-ref prototype 0))))
-	     (let ((pdims (array:dimensions prototype)))
-	       (case (apply * pdims)
-		 ((0) (make-vector tcnt))
-		 (else (make-vector tcnt
-				    (apply array-ref prototype
-					   (map (lambda (x) 0) pdims)))))))))
-    (define (loop dims scales)
-      (if (null? dims)
-	  (array:construct dimensions (cdr scales) 0 store)
-	  (loop (cdr dims) (cons (* (car dims) (car scales)) scales)))) 
-    (loop (reverse dimensions) '(1))))
+  (let ((initializer
+	 (if (zero? (apply * pdims)) '()
+	     (list
+	      (apply array-ref prototype
+		     (map (lambda (x) 0) pdims))))))
+    (cond ((and onedim? (string? prot))
+	   (apply make-string (car dimensions) initializer))
+	  ((and onedim? (vector? prot))
+	   (apply make-vector (car dimensions) initializer))
+	  (else
+	   (let ((store
+		  (if (string? prot)
+		      (apply make-string tcnt initializer)
+		      (apply make-vector tcnt initializer))))
+	     (define (loop dims scales)
+	       (if (null? dims)
+		   (array:construct dimensions (cdr scales) 0 store)
+		   (loop (cdr dims)
+			 (cons (* (car dims) (car scales)) scales))))
+	     (loop (reverse dimensions) '(1)))))))
 ;;@args prototype k1 @dots{}
 ;;@0 is an alias for @code{make-array}.
 (define create-array make-array)
@@ -203,7 +214,9 @@
   (define shape
     (map (lambda (dim) (if (list? dim) dim (list 0 (+ -1 dim)))) dimensions))
   (do ((idx (+ -1 rank) (+ -1 idx))
-       (uvt (append (cdr (vector->list (make-vector rank 0))) '(1))
+       (uvt (if (zero? rank)
+		'()
+		(append (cdr (vector->list (make-vector rank 0))) '(1)))
 	    (append (cdr uvt) '(0)))
        (uvts '() (cons uvt uvts)))
       ((negative? idx)
@@ -269,7 +282,7 @@
 	(do ((lst '() (cons (ra2l (cdr dims) (cons idx idxs)) lst))
 	     (idx (+ -1 (car dims)) (+ -1 idx)))
 	    ((negative? idx) lst))))
-  (ra2l (array-dimensions ra) '()))
+  (ra2l (array:dimensions ra) '()))
 
 ;;@args vect proto dim1 @dots{}
 ;;@1 must be a vector of length equal to the product of exact
@@ -312,19 +325,19 @@
 ;;                @result{} #(ho)
 ;;@end example
 (define (array->vector ra)
-  (define dims (array-dimensions ra))
+  (define dims (array:dimensions ra))
   (let* ((vdx (apply * dims))
 	 (vect (make-vector vdx)))
     (define (ra2v dims idxs)
       (if (null? dims)
 	  (let ((val (apply array-ref ra (reverse idxs))))
 	    (set! vdx (+ -1 vdx))
-	    (vector-set! vect vdx val)
-	    vect)
+	    (vector-set! vect vdx val))
 	  (do ((idx (+ -1 (car dims)) (+ -1 idx)))
 	      ((negative? idx) vect)
 	    (ra2v (cdr dims) (cons idx idxs)))))
-    (ra2v dims '())))
+    (ra2v dims '())
+    vect))
 
 (define (array:in-bounds? array indices)
   (do ((bnds (array:dimensions array) (cdr bnds))