-
Notifications
You must be signed in to change notification settings - Fork 0
/
compiler.pure-cload.lisp
191 lines (171 loc) · 7.05 KB
/
compiler.pure-cload.lisp
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
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
;;;; miscellaneous tests of compiling toplevel forms
;;;; 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.
(in-package :cl-user)
;;; Exercise a compiler bug (by causing a call to ERROR).
;;;
;;; This bug was in sbcl-0.6.11.6.
(let ((a 1) (b 1))
(declare (type (mod 1000) a b))
(let ((tmp (= 10 (+ (incf a) (incf a) (incf b) (incf b)))))
(or tmp (error "TMP not true"))))
;;; Exercise a (byte-)compiler bug by causing a call to ERROR, not
;;; because the symbol isn't defined as a variable, but because
;;; TYPE-ERROR in SB-KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
;;; 0 is not of type (OR FUNCTION SB-KERNEL:FDEFN).
;;; Correct behavior is to warn at compile time because the symbol
;;; isn't declared as a variable, but to set its SYMBOL-VALUE anyway.
;;;
;;; This bug was in sbcl-0.6.11.13.
(print (setq improperly-declared-var '(1 2)))
(assert (equal (symbol-value 'improperly-declared-var) '(1 2)))
(makunbound 'improperly-declared-var)
;;; This is a slightly different way of getting the same symptoms out
;;; of the sbcl-0.6.11.13 byte compiler bug.
(print (setq *print-level* *print-level*))
;;; PROGV with different numbers of variables and values
(let ((a 1))
(declare (special a))
(assert (equal (list a (progv '(a b) '(:a :b :c)
(assert (eq (symbol-value 'nil) nil))
(list (symbol-value 'a) (symbol-value 'b)))
a)
'(1 (:a :b) 1)))
(assert (equal (list a (progv '(a b) '(:a :b)
(assert (eq (symbol-value 'nil) nil))
(list (symbol-value 'a) (symbol-value 'b)))
a)
'(1 (:a :b) 1)))
(assert (not (boundp 'b))))
(let ((a 1) (b 2))
(declare (special a b))
(assert (equal (list a b (progv '(a b) '(:a)
(assert (eq (symbol-value 'nil) nil))
(assert (not (boundp 'b)))
(symbol-value 'a))
a b)
'(1 2 :a 1 2))))
;;; bug in LOOP, reported by ??? on c.l.l
(flet ((foo (l)
(loop for x in l
when (symbolp x) return x
while (numberp x)
collect (list x))))
(assert (equal (foo '(1 2 #\a 3)) '((1) (2))))
(assert (equal (foo '(1 2 x 3)) 'x)))
;;; compiler failure found by Paul Dietz' randomized tortuter
(defun #:foo (a b c d)
(declare (type (integer 240 100434465) a)
(optimize (speed 3) (safety 1) (debug 1)))
(logxor
(if (ldb-test (byte 27 4) d)
-1
(max 55546856 -431))
(logorc2
(if (>= 0 b)
(if (> b c) (logandc2 c d) (if (> d 224002) 0 d))
(signum (logior c b)))
(logior a -1))))
(defun #:foo (b c)
(declare (type (integer -23228343 2) b)
(type (integer -115581022 512244512) c)
(optimize (speed 3) (safety 1) (debug 1)))
(* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b))
(deposit-field b (byte 25 27) -30424886))
(dpb b (byte 23 29) c)))
(defun #:foo (x y)
(declare (type (integer -1 1000000000000000000000000) x y)
(optimize speed))
(* x (* y x)))
(defun #:foo (b)
(declare (type (integer -290488443 2) b)
(optimize (speed 3) (safety 1) (debug 1)))
(let ((v3 (min -1720 b))) (max v3 (logcount (if (= v3 b) b b)))))
(defun #:foo (d)
(let ((v7 (flet ((%f16 () (labels ((%f3 () -8)) (%f3))))
(labels ((%f7 () (%f16))) d))))
132887443))
;;; RESULT-FORM in DO is not contained in the implicit TAGBODY
(assert (eq (handler-case (eval `(do ((x '(1 2 3) (cdr x)))
((endp x) (go :loop))
:loop
(unless x (return :bad))))
(error () :good))
:good))
(assert (eq (handler-case (eval `(do* ((x '(1 2 3) (cdr x)))
((endp x) (go :loop))
:loop
(unless x (return :bad))))
(error () :good))
:good))
;;; bug 282
;;;
;;; Verify type checking policy in full calls: the callee is supposed
;;; to perform check, but the results should not be used before the
;;; check will be actually performed.
(locally
(declare (optimize (safety 3)))
(flet ((bar (f a)
(declare (type (simple-array (unsigned-byte 32) (*)) a))
(declare (type (function (fixnum)) f))
(funcall f (aref a 0))))
#-64-bit
(assert
(eval `(let ((n (1+ most-positive-fixnum)))
(if (not (typep n '(unsigned-byte 32)))
(warn 'style-warning
"~@<This test is written for platforms with ~
~@<(proper-subtypep 'fixnum '(unsigned-byte 32))~:@>.~:@>")
(block nil
(funcall ,#'bar
(lambda (x) (when (eql x n) (return t)))
(make-array 1 :element-type '(unsigned-byte 32)
:initial-element n))
nil)))))))
;;; bug 261
(let ((x (list (the (values &optional fixnum) (eval '(values))))))
(assert (equal x '(nil))))
;;; Bug 125, reported by Gabe Garza: Python did not preserve identity
;;; of closures.
(flet ((test-case (test-pred x)
(let ((func (lambda () x)))
(list (eq func func)
(funcall test-pred func func)
(delete func (list func))))))
(assert (equal '(t t nil) (funcall (eval #'test-case) #'eq 3))))
;;; compiler failure reported by Alan Shields:
;;; MAYBE-INFER-ITERATION-VAR-TYPE did not deal with types (REAL * (n)).
(let ((s (loop for x from (- pi) below (floor (* 2 pi)) by (/ pi 75) count t)))
(assert (= s 219)))
(with-test (:name :specialized-array-dumping)
(macrolet
((make-tests ()
`(progn
,@(loop for saetp across
sb-vm:*specialized-array-element-type-properties*
for specifier = (sb-vm:saetp-specifier saetp)
for array = (make-array (if specifier 10 0)
:element-type specifier)
for make-array = `(make-array ,(if specifier 10 0)
:element-type ',specifier)
collect `(assert (and (equal (type-of ,array)
',(type-of array))
(equalp ,array
,make-array)))))))
(make-tests)))
(lambda () (the string (+ 1 x)))
(lambda ()
(macrolet ((x (&rest args)
(declare (ignore args))
'a))
(let (a)
(declare (type vector a))
(x #.#'list))))