← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/array-displacement.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/array-displacement.lsp
 
1
;-*- Mode:     Lisp -*-
 
2
;;;; Author:   Paul Dietz
 
3
;;;; Created:  Tue Jan 21 06:20:51 2003
 
4
;;;; Contains: Tests for ARRAY-DISPLACEMENT
 
5
 
 
6
(in-package :cl-test)
 
7
 
 
8
;;; The tests in make-array.lsp also test array-displacement
 
9
 
 
10
;;; The standard is contradictory about whether arrays created with
 
11
;;; :displaced-to NIL should return NIL as their primary value or
 
12
;;; not.  I will assume (as per Kent Pitman's comment on comp.lang.lisp)
 
13
;;; that an implementation is free to implement all arrays as actually
 
14
;;; displaced.  Therefore, I've omitted all the tests of not-expressly
 
15
;;; displaced arrays.
 
16
 
 
17
;;; Behavior on expressly displaced arrays
 
18
 
 
19
(deftest array-displacement.7
 
20
  (let* ((a (make-array '(10)))
 
21
         (b (make-array '(10) :displaced-to a)))
 
22
    (multiple-value-bind* (dt disp)
 
23
        (array-displacement b)
 
24
      (and (eqt a dt)
 
25
           (eqlt disp 0))))
 
26
  t)
 
27
 
 
28
(deftest array-displacement.8
 
29
  (let* ((a (make-array '(10)))
 
30
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2)))
 
31
    (multiple-value-bind* (dt disp)
 
32
        (array-displacement b)
 
33
      (and (eqt a dt)
 
34
           (eqlt disp 2))))
 
35
  t)
 
36
 
 
37
(deftest array-displacement.9
 
38
  (let* ((a (make-array '(10) :element-type 'base-char))
 
39
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2
 
40
                        :element-type 'base-char)))
 
41
    (multiple-value-bind* (dt disp)
 
42
        (array-displacement b)
 
43
      (and (eqt a dt)
 
44
           (eqlt disp 2))))
 
45
  t)
 
46
 
 
47
(deftest array-displacement.10
 
48
  (let* ((a (make-array '(10) :element-type 'base-char))
 
49
         (b (make-array '(5) :displaced-to a
 
50
                        :element-type 'base-char)))
 
51
    (multiple-value-bind* (dt disp)
 
52
        (array-displacement b)
 
53
      (and (eqt a dt)
 
54
           (eqlt disp 0))))
 
55
  t)
 
56
 
 
57
(deftest array-displacement.11
 
58
  (let* ((a (make-array '(10) :element-type 'bit))
 
59
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2
 
60
                        :element-type 'bit)))
 
61
    (multiple-value-bind* (dt disp)
 
62
        (array-displacement b)
 
63
      (and (eqt a dt)
 
64
           (eqlt disp 2))))
 
65
  t)
 
66
 
 
67
(deftest array-displacement.12
 
68
  (let* ((a (make-array '(10) :element-type 'bit))
 
69
         (b (make-array '(5) :displaced-to a
 
70
                        :element-type 'bit)))
 
71
    (multiple-value-bind* (dt disp)
 
72
        (array-displacement b)
 
73
      (and (eqt a dt)
 
74
           (eqlt disp 0))))
 
75
  t)
 
76
 
 
77
(deftest array-displacement.13
 
78
  (let* ((a (make-array '(10) :element-type '(integer 0 255)))
 
79
         (b (make-array '(5) :displaced-to a :displaced-index-offset 2
 
80
                        :element-type '(integer 0 255))))
 
81
    (multiple-value-bind* (dt disp)
 
82
        (array-displacement b)
 
83
      (and (eqt a dt)
 
84
           (eqlt disp 2))))
 
85
  t)
 
86
 
 
87
(deftest array-displacement.14
 
88
  (let* ((a (make-array '(10) :element-type '(integer 0 255)))
 
89
         (b (make-array '(5) :displaced-to a
 
90
                        :element-type '(integer 0 255))))
 
91
    (multiple-value-bind* (dt disp)
 
92
        (array-displacement b)
 
93
      (and (eqt a dt)
 
94
           (eqlt disp 0))))
 
95
  t)
 
96
 
 
97
(deftest array-displacement.order.1
 
98
  (let* ((a (make-array '(10)))
 
99
         (b (make-array '(10) :displaced-to a))
 
100
         (i 0))
 
101
    (multiple-value-bind* (dt disp)
 
102
        (array-displacement (progn (incf i) b))
 
103
      (and (eql i 1)
 
104
           (eqt a dt)
 
105
           (eqlt disp 0))))
 
106
  t)
 
107
 
 
108
;;; Error tests
 
109
 
 
110
(deftest array-displacement.error.1
 
111
  (signals-error (array-displacement) program-error)
 
112
  t)
 
113
 
 
114
(deftest array-displacement.error.2
 
115
  (signals-error (array-displacement #(a b c) nil) program-error)
 
116
  t)
 
117
 
 
118
(deftest array-displacement.error.3
 
119
  (loop for e in *mini-universe*
 
120
        unless (or (typep e 'array)
 
121
                   (eval `(signals-error (array-displacement ',e)
 
122
                                         type-error)))
 
123
        collect e)
 
124
  nil)
 
125
 
 
126
(deftest array-displacement.error.4
 
127
  (signals-error (array-displacement nil) type-error)
 
128
  t)
 
129
 
 
130
(deftest array-displacement.error.5
 
131
  (signals-error (let ((x nil)) (array-displacement x))
 
132
                 type-error)
 
133
  t)
 
134
 
 
135