/[gcl]/gcl/ansi-tests/make-array.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/make-array.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by pfdietz, Sun Jan 19 15:23:19 2003 UTC revision 1.10 by pfdietz, Wed Jan 22 02:44:51 2003 UTC
# Line 5  Line 5 
5    
6  (in-package :cl-test)  (in-package :cl-test)
7    
8  (defun make-array-check-upgrading (type)  ;;; See array-aux.lsp for auxiliary functions
   (subtypep* type (array-element-type (make-array 0 :element-type type))))  
   
 (defun make-array-with-checks (dimensions  
                                &rest options  
                                &key  
                                (element-type t element-type-p)  
                                (initial-contents nil intial-contents-p)  
                                (initial-element nil initial-element-p)  
                                (adjustable nil)  
                                (fill-pointer nil)  
                                (displaced-to nil)  
                                (displaced-index-offset 0 dio-p)  
                                &aux  
                                (dimensions-list (if (listp dimensions)  
                                                     dimensions  
                                                   (list dimensions))))  
   "Call MAKE-ARRAY and do sanity tests on the output."  
   (let ((a (apply #'make-array dimensions options)))  
     (cond  
      ((not (typep a 'array)) :fail-not-array)  
      ((and (eq t element-type)  
            (not adjustable)  
            (not fill-pointer)  
            (not displaced-to)  
            (not (typep a 'simple-array)))  
       :fail-not-simple-array)  
      ((and (eq (length dimensions-list) 1)  
            (cond  
             ((not (typep a 'vector))  
              :fail-not-vector)  
             ((and (subtypep 'bit element-type)  
                   (subtypep element-type 'bit)  
                   (or (not (bit-vector-p a))  
                       (not (typep a 'bit-vector))))  
              :fail-not-bit-vector)  
             ((and (not adjustable)  
                   (not fill-pointer)  
                   (not displaced-to)  
                   (cond  
                    ((and (eq t element-type)  
                          (or (not (simple-vector-p a))  
                              (not (typep a 'simple-vector))))  
                     :fail-not-simple-vector)  
                    ((and (subtypep 'bit element-type)  
                          (subtypep element-type 'bit)  
                          (or (not (simple-bit-vector-p a))  
                              (not (typep a 'simple-bit-vector))))  
                     :fail-not-simple-bit-vector) ))) )))  
      ((not (equal (array-dimensions a) dimensions-list))  
       :fail-array-dimensions)  
      ((not (equal (array-rank a) (length dimensions-list)))  
       :fail-array-rank)  
      ((multiple-value-bind (sub good)  
           (subtypep element-type (array-element-type a))  
         (and good  
              (not sub)  
              :failed-array-element-type)))  
      ((and adjustable  
            (not (adjustable-array-p a))  
            :fail-adjustable))  
      ((and fill-pointer  
            (not (array-has-fill-pointer-p a))  
            :fail-has-fill-pointer))  
      ((and (integerp fill-pointer)  
            (not (eql fill-pointer (fill-pointer a)))  
            :fail-fill-pointer-1))  
      ((and (eq fill-pointer t)  
            (not (eql (first dimensions-list) (fill-pointer a)))  
            :fail-fill-pointer-2))  
      (t a))))  
9    
10  (deftest make-array.1  (deftest make-array.1
11    (let ((a (make-array-with-checks 10)))    (let ((a (make-array-with-checks 10)))
# Line 283  Line 213 
213                :nonsense-argument t)                :nonsense-argument t)
214    #(x x x x))    #(x x x x))
215    
216    (deftest make-array.28
217      (let ((*package* (find-package :cl-test)))
218        (let ((len (1- (min 10000 array-rank-limit))))
219          (equalpt (make-array (make-list len :initial-element 1) :initial-element 'x)
220                   (read-from-string (concatenate
221                                      'string
222                                      (format nil "#~dA" len)
223                                      (make-string len :initial-element #\()
224                                      "x"
225                                      (make-string len :initial-element #\)))))))
226      t)
227    
228  ;;; Adjustable arrays  ;;; Adjustable arrays
229    
# Line 561  Line 502 
502                              :adjustable t))                              :adjustable t))
503    #(f g h i j k l m))    #(f g h i j k l m))
504    
505    (deftest make-array.displaced.27
506      (let ((a (make-array '(10)
507                           :initial-contents '(1 2 3 4 5 6 7 8 9 10)
508                           :fill-pointer t)))
509        (make-array-with-checks '(2 4) :displaced-to a))
510      #2a((1 2 3 4) (5 6 7 8)))
511    
512    (deftest make-array.displaced.28
513      (let ((a (make-array '(10)
514                           :initial-contents '(1 2 3 4 5 6 7 8 9 10)
515                           :fill-pointer 4)))
516        (make-array-with-checks '(2 4) :displaced-to a))
517      #2a((1 2 3 4) (5 6 7 8)))
518    
519    (deftest make-array.displaced.29
520      (let ((a (make-array '(10) :initial-element 0)))
521        (prog1
522            (make-array-with-checks '(2 4) :displaced-to a)
523          (loop for i below 10 do (setf (aref a i) (1+ i)))))
524      #2a((1 2 3 4) (5 6 7 8)))
525    
526    (deftest make-array.displaced.30
527      (let* ((a1 (make-array '(10) :initial-element 0))
528             (a2 (make-array '(10) :displaced-to a1)))
529        (prog1
530            (make-array-with-checks '(2 4) :displaced-to a2)
531          (loop for i below 10 do (setf (aref a2 i) (1+ i)))))
532      #2a((1 2 3 4) (5 6 7 8)))
533    
534    (deftest make-array.displaced.31
535      (let* ((a1 (make-array '(10) :initial-element 0))
536             (a2 (make-array '(10) :displaced-to a1)))
537        (prog1
538            (make-array-with-checks '(2 4) :displaced-to a2)
539          (loop for i below 10 do (setf (aref a1 i) (1+ i)))))
540      #2a((1 2 3 4) (5 6 7 8)))
541    
542    
543  ;;; Keywords tests  ;;; Keywords tests
544    
545  (deftest make-array.allow-other-keys.1  (deftest make-array.allow-other-keys.1

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26