1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / vector.impure.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; While most of SBCL is derived from the CMU CL system, the test
5 ;;;; files (like this one) were written from scratch after the fork
6 ;;;; from CMU CL.
7 ;;;;
8 ;;;; This software is in the public domain and is provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
10 ;;;; more information.
11
12 (cl:in-package "CL-USER")
13
14 ;;; test case from Utz-Uwe Haus
15 (defstruct some-struct
16   (a 0 :type integer))
17 (defun foo (m)
18   (declare (type (vector some-struct) m))
19   m)
20 (defun bar (m)
21   (declare (type (vector some-struct) m))
22   (let* ((subarray (make-array (- (length m) 1)
23                                :element-type 'some-struct
24                                :displaced-to m :displaced-index-offset 1)))
25     (foo subarray)))
26 (defvar *a-foo* (make-some-struct))
27 (defvar *a-foo-vec*
28   (make-array 2 :element-type 'some-struct :adjustable t
29               :initial-contents (list *a-foo* *a-foo*)))
30 (assert (typep (bar *a-foo-vec*) '(vector some-struct)))
31
32 ;;; some extra sanity checks
33 (compile (defun compiled-vector-t-p (x) (typep x '(vector t))))
34 (compile (defun compiled-simple-vector-p (x) (typep x 'simple-vector)))
35 (declaim (notinline opaque-identity))
36 (defun opaque-identity (x) x)
37 (defun evaluated-vector-t-p (x) (typep x (opaque-identity '(vector t))))
38 (defun evaluated-simple-vector-p (x)
39   (typep x (opaque-identity 'simple-vector)))
40
41 (defvar *simple-vector* (vector 1 2))
42 (defvar *adjustable-vector-t* (make-array 2 :adjustable t))
43 (defvar *adjustable-array* (make-array '(2 2) :adjustable t))
44 (defvar *vector-with-fill-pointer* (make-array 2 :fill-pointer t))
45 (defvar *vector-displaced-to-simple-vector*
46   (make-array 1 :displaced-to *simple-vector* :displaced-index-offset 1))
47 (defvar *vector-displaced-to-adjustable-vector-t*
48   (make-array 1 :displaced-to *adjustable-vector-t* :displaced-index-offset 1))
49 (defvar *vector-displaced-to-adjustable-array*
50   (make-array 1 :displaced-to *adjustable-array* :displaced-index-offset 3))
51 (defvar *vector-displaced-to-vector-with-fill-pointer*
52   (make-array 1 :displaced-to *vector-with-fill-pointer*
53               :displaced-index-offset 1))
54 (defvar *array-displaced-to-simple-vector*
55   (make-array '(1 1) :displaced-to *simple-vector*
56               :displaced-index-offset 0))
57 (defvar *array-displaced-to-adjustable-vector-t*
58   (make-array '(1 1) :displaced-to *adjustable-vector-t*
59               :displaced-index-offset 1))
60 (defvar *simple-array* (make-array '(1 1)))
61
62 (macrolet
63     ((frob (object simple-vector-p vector-t-p)
64        `(progn
65          (assert (eq (compiled-vector-t-p ,object) ,vector-t-p))
66          (assert (eq (compiled-simple-vector-p ,object) ,simple-vector-p))
67          (assert (eq (evaluated-vector-t-p ,object) ,vector-t-p))
68          (assert (eq (evaluated-simple-vector-p ,object) ,simple-vector-p)))))
69   (frob *simple-vector* t t)
70   (frob *adjustable-vector-t* nil t)
71   (frob *adjustable-array* nil nil)
72   (frob *vector-with-fill-pointer* nil t)
73   (frob *vector-displaced-to-simple-vector* nil t)
74   (frob *vector-displaced-to-adjustable-vector-t* nil t)
75   (frob *vector-displaced-to-adjustable-array* nil t)
76   (frob *vector-displaced-to-vector-with-fill-pointer* nil t)
77   (frob *array-displaced-to-simple-vector* nil nil)
78   (frob *array-displaced-to-adjustable-vector-t* nil nil)
79   (frob *simple-array* nil nil))