array-displacement.lsp 4.13 KB
Newer Older
pfdietz's avatar
pfdietz committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Tue Jan 21 06:20:51 2003
;;;; Contains: Tests for ARRAY-DISPLACEMENT

(in-package :cl-test)

;;; The tests in make-array.lsp also test array-displacement

;;; The standard is contradictory about whether arrays created with
;;; :displaced-to NIL should return NIL as their primary value or
;;; not.  I will assume (as per Kent Pitman's comment on comp.lang.lisp)
;;; that an implementation is free to implement all arrays as actually
;;; displaced.  Therefore, I've omitted all the tests of not-expressly
;;; displaced arrays.

;;; Behavior on expressly displaced arrays

(deftest array-displacement.7
  (let* ((a (make-array '(10)))
sds's avatar
sds committed
21
         (b (make-array '(10) :displaced-to a)))
22
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
23
        (array-displacement b)
pfdietz's avatar
pfdietz committed
24
      (and (eqt a dt)
sds's avatar
sds committed
25
           (eqlt disp 0))))
pfdietz's avatar
pfdietz committed
26 27 28 29
  t)

(deftest array-displacement.8
  (let* ((a (make-array '(10)))
sds's avatar
sds committed
30
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2)))
31
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
32
        (array-displacement b)
pfdietz's avatar
pfdietz committed
33
      (and (eqt a dt)
sds's avatar
sds committed
34
           (eqlt disp 2))))
pfdietz's avatar
pfdietz committed
35 36 37 38
  t)

(deftest array-displacement.9
  (let* ((a (make-array '(10) :element-type 'base-char))
sds's avatar
sds committed
39 40
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2
                        :element-type 'base-char)))
41
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
42
        (array-displacement b)
pfdietz's avatar
pfdietz committed
43
      (and (eqt a dt)
sds's avatar
sds committed
44
           (eqlt disp 2))))
pfdietz's avatar
pfdietz committed
45 46 47 48
  t)

(deftest array-displacement.10
  (let* ((a (make-array '(10) :element-type 'base-char))
sds's avatar
sds committed
49 50
         (b (make-array '(5) :displaced-to a
                        :element-type 'base-char)))
51
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
52
        (array-displacement b)
pfdietz's avatar
pfdietz committed
53
      (and (eqt a dt)
sds's avatar
sds committed
54
           (eqlt disp 0))))
pfdietz's avatar
pfdietz committed
55 56 57 58
  t)

(deftest array-displacement.11
  (let* ((a (make-array '(10) :element-type 'bit))
sds's avatar
sds committed
59 60
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2
                        :element-type 'bit)))
61
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
62
        (array-displacement b)
pfdietz's avatar
pfdietz committed
63
      (and (eqt a dt)
sds's avatar
sds committed
64
           (eqlt disp 2))))
pfdietz's avatar
pfdietz committed
65 66 67 68
  t)

(deftest array-displacement.12
  (let* ((a (make-array '(10) :element-type 'bit))
sds's avatar
sds committed
69 70
         (b (make-array '(5) :displaced-to a
                        :element-type 'bit)))
71
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
72
        (array-displacement b)
pfdietz's avatar
pfdietz committed
73
      (and (eqt a dt)
sds's avatar
sds committed
74
           (eqlt disp 0))))
pfdietz's avatar
pfdietz committed
75 76 77 78
  t)

(deftest array-displacement.13
  (let* ((a (make-array '(10) :element-type '(integer 0 255)))
sds's avatar
sds committed
79 80
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2
                        :element-type '(integer 0 255))))
81
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
82
        (array-displacement b)
pfdietz's avatar
pfdietz committed
83
      (and (eqt a dt)
sds's avatar
sds committed
84
           (eqlt disp 2))))
pfdietz's avatar
pfdietz committed
85 86 87 88
  t)

(deftest array-displacement.14
  (let* ((a (make-array '(10) :element-type '(integer 0 255)))
sds's avatar
sds committed
89 90
         (b (make-array '(5) :displaced-to a
                        :element-type '(integer 0 255))))
91
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
92
        (array-displacement b)
pfdietz's avatar
pfdietz committed
93
      (and (eqt a dt)
sds's avatar
sds committed
94
           (eqlt disp 0))))
pfdietz's avatar
pfdietz committed
95 96
  t)

97 98
(deftest array-displacement.15
  (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))
sds's avatar
sds committed
99
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2)))
100 101 102 103 104 105 106 107 108 109 110
    (macrolet
     ((%m (z) z))
     (multiple-value-bind
      (x y)
      (array-displacement (expand-in-current-env (%m b)))
      (values (eqlt x a) y))))
  t 2)

;;; FIXME: Add tests for other kinds of specialized arrays
;;;  (character, other integer types, float types, complex types)

111 112
(deftest array-displacement.order.1
  (let* ((a (make-array '(10)))
sds's avatar
sds committed
113 114
         (b (make-array '(10) :displaced-to a))
         (i 0))
115
    (multiple-value-bind* (dt disp)
sds's avatar
sds committed
116
        (array-displacement (progn (incf i) b))
117
      (and (eql i 1)
sds's avatar
sds committed
118 119
           (eqt a dt)
           (eqlt disp 0))))
120 121
  t)

pfdietz's avatar
pfdietz committed
122 123 124
;;; Error tests

(deftest array-displacement.error.1
125 126
  (signals-error (array-displacement) program-error)
  t)
pfdietz's avatar
pfdietz committed
127 128

(deftest array-displacement.error.2
129 130
  (signals-error (array-displacement #(a b c) nil) program-error)
  t)
pfdietz's avatar
pfdietz committed
131 132

(deftest array-displacement.error.3
133
  (check-type-error #'array-displacement #'arrayp)
pfdietz's avatar
pfdietz committed
134
  nil)
135 136

(deftest array-displacement.error.4
137
  (signals-type-error x nil (array-displacement x))
138
  t)