-
Notifications
You must be signed in to change notification settings - Fork 7
/
compiler-1.impure-cload.lisp
240 lines (217 loc) · 8.36 KB
/
compiler-1.impure-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
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
;;;; miscellaneous compiler tests with side effects (e.g. DEFUN
;;;; changing FDEFINITIONs and globaldb stuff)
;;;; 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)
(eval-when (:compile-toplevel :load-toplevel :execute)
(load "assertoid")
(use-package "ASSERTOID"))
(declaim (optimize (debug 3) (speed 2) (space 1)))
;;; Until version 0.6.9 or so, SBCL's version of Python couldn't do
;;; this correctly, due to the bug patched by Rob MacLachlan on the
;;; cmucl-imp list 2000-06-21, and applied to SBCL by Martin Atzmueller.
;;; (The effectiveness of the test also depends on the implicit
;;; function typing of Python (where DEFUN is like DECLAIM FTYPE),
;;; which violates the ANSI spec, and should be fixed. Once that
;;; unrelated bug is fixed, this code will no longer test the type
;;; inference behavior it's intended to test.)
(defun emptyvalues (&rest rest) (declare (ignore rest)) (values))
(defstruct foo x y)
(defun bar ()
(let ((res (emptyvalues)))
(unless (typep res 'foo)
'expected-value)))
(assert (eq (bar) 'expected-value))
(declaim (ftype (function (real) (values integer single-float)) valuesify))
(defun valuesify (x)
(values (round x)
(coerce x 'single-float)))
(defun exercise-valuesify (x)
(multiple-value-bind (i f) (valuesify x)
(declare (type integer i))
(declare (type single-float f))
(+ i f)))
(assert (= (exercise-valuesify 1.25) 2.25))
;;; An early version (sbcl-0.6.11.33) of code to check FTYPEs from DEFUN
;;; against DECLAIMed FTYPEs blew up when an FTYPE was DECLAIMed
;;; to be pure FUNCTION, because the internal representation of
;;; FUNCTION itself (as opposed to subtypes of FUNCTION, such as
;;; (FUNCTION () T)) is a BUILT-IN-CLASS object, not a FUN-TYPE
;;; object.
(declaim (ftype function i-am-just-a-function))
(defun i-am-just-a-function (x y) (+ x y 1))
;;; Stig E Sandoe reported in cclan-Bugs-431263 that SBCL couldn't
;;; compile this. sbcl-0.6.12.26 died in CIRCULAR-LIST-P with "The
;;; value \"EST\" is not of type LIST." Dan Barlow fixed it.
(defvar +time-zones+
'((5 "EDT" . "EST") (6 "CDT" . "CST") (7 "MDT" .
"MST") (8 "PDT" . "PST")
(0 "GMT" . "GDT") (-2 "MET" . "MET DST"))
"*The string representations of the time zones.")
(declaim (optimize (debug 1) (speed 1) (space 1)))
;;; The old CMU CL Python compiler assumed that it was safe to infer
;;; function types (including return types) from function definitions
;;; and then use them to optimize code later [and it was almost
;;; right!]. This is of course bad when functions are redefined. The
;;; problem was fixed in sbcl-0.6.12.57.
(defun foo (x)
(if (plusp x)
1.0
0))
(eval '(locally
(defun bar (x)
(typecase (foo x)
(fixnum :fixnum)
(real :real)
(string :string)
(t :t)))
(compile 'bar)))
(assert (eql (bar 11) :real))
(assert (eql (bar -11) :fixnum))
(setf (symbol-function 'foo) #'identity)
(assert (eql (bar 11) :fixnum))
(assert (eql (bar -11.0) :real))
(assert (eql (bar "this is a test") :string))
(assert (eql (bar (make-hash-table)) :t))
;;; bug reported by Brian Spilsbury sbcl-devel 2001-09-30, fixed by
;;; Alexey Dejneka patch sbcl-devel 2001-10-02
(defun pixarray-element-size (pixarray)
(let ((eltype (array-element-type pixarray)))
(cond ((eq eltype 'bit) 1)
((and (listp eltype)
(eq (first eltype) 'unsigned-byte))
(second eltype))
(t
(error "Invalid pixarray: ~S." pixarray)))))
(assert (eql 1 (pixarray-element-size #*110)))
;;; bug 31 turned out to be a manifestation of non-ANSI array type
;;; handling, fixed by CSR in sbcl-0.7.3.8.
(defun array-element-type-handling (x)
(declare (optimize safety))
(declare (type (vector cons) x))
(when (consp (aref x 0))
(aref x 0)))
(assert (raises-error?
(array-element-type-handling
(make-array 3 :element-type t :initial-element 0))
type-error))
;;; bug 220: type check inserted after all arguments in MV-CALL caused
;;; failure of stack analysis
(defun bug220-helper ()
13)
(assert (equal (multiple-value-call #'list
(the integer (bug220-helper))
nil)
'(13 nil)))
;;; bug 221: sbcl 0.7.9.13 failed to compile the following function
(declaim (ftype (function (fixnum) (values package boolean)) bug221-f1))
(declaim (ftype (function (t) (values package boolean)) bug221-f2))
(defun bug221 (b x)
(funcall (if b #'bug221-f1 #'bug221-f2) x))
;;; bug 166: compiler failure
(defstruct bug166s)
(defmethod permanentize ((uustk bug166s))
(flet ((frob (hash-table test-for-deletion)
)
(obj-entry.stale? (oe)
(destructuring-bind (key . datum) oe
(declare (type simple-vector key))
(deny0 (void? datum))
(some #'stale? key))))
(declare (inline frob obj-entry.stale?))
(frob (uustk.args-hash->obj-alist uustk)
#'obj-entry.stale?)
(frob (uustk.hash->memoized-objs-list uustk)
#'objs.stale?))
(call-next-method))
;;; bugs 115, 226: compiler failure in lifetime analysis
(defun bug115-1 ()
(declare (optimize (speed 2) (debug 3)))
(flet ((m1 ()
(unwind-protect nil)))
(if (catch nil)
(m1)
(m1))))
(defun bug115-2 ()
(declare (optimize (speed 2) (debug 3)))
(flet ((m1 ()
(bar (if (foo) 1 2))
(let ((x (foo)))
(bar x (list x)))))
(if (catch nil)
(m1)
(m1))))
(defun bug226 ()
(declare (optimize (speed 0) (safety 3) (debug 3)))
(flet ((safe-format (stream string &rest r)
(unless (ignore-errors (progn
(apply #'format stream string r)
t))
(format stream "~&foo ~S" string))))
(cond
((eq my-result :ERROR)
(cond
((ignore-errors (typep condition result))
(safe-format t "~&bar ~S" result))
(t
(safe-format t "~&baz ~S (~A) ~S" condition condition result)))))))
;;; bug 231: SETQ did not check the type of the variable being set
(defun bug231a-1 (x)
(declare (optimize safety) (type (integer 0 8) x))
(incf x))
(assert (raises-error? (bug231a-1 8) type-error))
(defun bug231a-2 (x)
(declare (optimize safety) (type (integer 0 8) x))
(list (lambda (y) (setq x y))
(lambda () x)))
(destructuring-bind (set get) (bug231a-2 0)
(funcall set 8)
(assert (eql (funcall get) 8))
(assert (raises-error? (funcall set 9) type-error))
(assert (eql (funcall get) 8)))
(defun bug231b (x z)
(declare (optimize safety) (type integer x))
(locally
(declare (type (real 1) x))
(setq x z))
(list x z))
(assert (raises-error? (bug231b nil 1) type-error))
(assert (raises-error? (bug231b 0 1.5) type-error))
(assert (raises-error? (bug231b 0 0) type-error))
;;; A bug appeared in flaky7_branch. Python got lost in unconverting
;;; embedded tail calls during let-conversion.
(defun bug239 (bit-array-2 &optional result-bit-array)
(declare (type (array bit) bit-array-2)
(type (or (array bit) (member t nil)) result-bit-array))
(unless (simple-bit-vector-p bit-array-2)
(multiple-value-call
(lambda (data1 start1)
(multiple-value-call
(lambda (data2 start2)
(multiple-value-call
(lambda (data3 start3)
(declare (ignore start3))
(print (list data1 data2)))
(values 0 0)))
(values bit-array-2 0)))
(values 444 0))))
(assert (equal (bug239 (make-array 4 :element-type 'bit
:adjustable t
:initial-element 0)
nil)
'(444 #*0000)))
(defstruct some-structure a)
(eval-when (:compile-toplevel)
;; in the big CLASS reorganization in pre8, this would fail with
;; SOME-STRUCTURE-A is not FBOUNDP. Fixed in 0.pre8.64
(find-class 'some-structure nil))
(eval-when (:load-toplevel)
(assert (typep (find-class 'some-structure) 'class)))