File: vector.impure.lisp

package info (click to toggle)
sbcl 1%3A0.9.16.0-1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 19,960 kB
  • ctags: 16,537
  • sloc: lisp: 231,164; ansic: 19,558; asm: 2,539; sh: 1,925; makefile: 308
file content (79 lines) | stat: -rw-r--r-- 3,408 bytes parent folder | download | duplicates (6)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.

(cl:in-package "CL-USER")

;;; test case from Utz-Uwe Haus
(defstruct some-struct
  (a 0 :type integer))
(defun foo (m)
  (declare (type (vector some-struct) m))
  m)
(defun bar (m)
  (declare (type (vector some-struct) m))
  (let* ((subarray (make-array (- (length m) 1)
                               :element-type 'some-struct
                               :displaced-to m :displaced-index-offset 1)))
    (foo subarray)))
(defvar *a-foo* (make-some-struct))
(defvar *a-foo-vec*
  (make-array 2 :element-type 'some-struct :adjustable t
              :initial-contents (list *a-foo* *a-foo*)))
(assert (typep (bar *a-foo-vec*) '(vector some-struct)))

;;; some extra sanity checks
(compile (defun compiled-vector-t-p (x) (typep x '(vector t))))
(compile (defun compiled-simple-vector-p (x) (typep x 'simple-vector)))
(declaim (notinline opaque-identity))
(defun opaque-identity (x) x)
(defun evaluated-vector-t-p (x) (typep x (opaque-identity '(vector t))))
(defun evaluated-simple-vector-p (x)
  (typep x (opaque-identity 'simple-vector)))

(defvar *simple-vector* (vector 1 2))
(defvar *adjustable-vector-t* (make-array 2 :adjustable t))
(defvar *adjustable-array* (make-array '(2 2) :adjustable t))
(defvar *vector-with-fill-pointer* (make-array 2 :fill-pointer t))
(defvar *vector-displaced-to-simple-vector*
  (make-array 1 :displaced-to *simple-vector* :displaced-index-offset 1))
(defvar *vector-displaced-to-adjustable-vector-t*
  (make-array 1 :displaced-to *adjustable-vector-t* :displaced-index-offset 1))
(defvar *vector-displaced-to-adjustable-array*
  (make-array 1 :displaced-to *adjustable-array* :displaced-index-offset 3))
(defvar *vector-displaced-to-vector-with-fill-pointer*
  (make-array 1 :displaced-to *vector-with-fill-pointer*
              :displaced-index-offset 1))
(defvar *array-displaced-to-simple-vector*
  (make-array '(1 1) :displaced-to *simple-vector*
              :displaced-index-offset 0))
(defvar *array-displaced-to-adjustable-vector-t*
  (make-array '(1 1) :displaced-to *adjustable-vector-t*
              :displaced-index-offset 1))
(defvar *simple-array* (make-array '(1 1)))

(macrolet
    ((frob (object simple-vector-p vector-t-p)
       `(progn
         (assert (eq (compiled-vector-t-p ,object) ,vector-t-p))
         (assert (eq (compiled-simple-vector-p ,object) ,simple-vector-p))
         (assert (eq (evaluated-vector-t-p ,object) ,vector-t-p))
         (assert (eq (evaluated-simple-vector-p ,object) ,simple-vector-p)))))
  (frob *simple-vector* t t)
  (frob *adjustable-vector-t* nil t)
  (frob *adjustable-array* nil nil)
  (frob *vector-with-fill-pointer* nil t)
  (frob *vector-displaced-to-simple-vector* nil t)
  (frob *vector-displaced-to-adjustable-vector-t* nil t)
  (frob *vector-displaced-to-adjustable-array* nil t)
  (frob *vector-displaced-to-vector-with-fill-pointer* nil t)
  (frob *array-displaced-to-simple-vector* nil nil)
  (frob *array-displaced-to-adjustable-vector-t* nil nil)
  (frob *simple-array* nil nil))