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))