1 ;;;; miscellaneous compiler tests with side effects (e.g. DEFUN
2 ;;;; changing FDEFINITIONs and globaldb stuff)
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; While most of SBCL is derived from the CMU CL system, the test
8 ;;;; files (like this one) were written from scratch after the fork
11 ;;;; This software is in the public domain and is provided with
12 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
13 ;;;; more information.
15 (cl:in-package :cl-user)
18 (use-package "ASSERTOID")
20 (declaim (optimize (debug 3) (speed 2) (space 1)))
22 ;;; Until version 0.6.9 or so, SBCL's version of Python couldn't do
23 ;;; this correctly, due to the bug patched by Rob MacLachlan on the
24 ;;; cmucl-imp list 2000-06-21, and applied to SBCL by Martin Atzmueller.
25 ;;; (The effectiveness of the test also depends on the implicit
26 ;;; function typing of Python (where DEFUN is like DECLAIM FTYPE),
27 ;;; which violates the ANSI spec, and should be fixed. Once that
28 ;;; unrelated bug is fixed, this code will no longer test the type
29 ;;; inference behavior it's intended to test.)
30 (defun emptyvalues (&rest rest) (declare (ignore rest)) (values))
33 (let ((res (emptyvalues)))
34 (unless (typep res 'foo)
36 (assert (eq (bar) 'expected-value))
38 (declaim (ftype (function (real) (values integer single-float)) valuesify))
41 (coerce x 'single-float)))
42 (defun exercise-valuesify (x)
43 (multiple-value-bind (i f) (valuesify x)
44 (declare (type integer i))
45 (declare (type single-float f))
47 (assert (= (exercise-valuesify 1.25) 2.25))
49 ;;; An early version (sbcl-0.6.11.33) of code to check FTYPEs from DEFUN
50 ;;; against DECLAIMed FTYPEs blew up when an FTYPE was DECLAIMed
51 ;;; to be pure FUNCTION, because the internal representation of
52 ;;; FUNCTION itself (as opposed to subtypes of FUNCTION, such as
53 ;;; (FUNCTION () T)) is a BUILT-IN-CLASS object, not a FUN-TYPE
55 (declaim (ftype function i-am-just-a-function))
56 (defun i-am-just-a-function (x y) (+ x y 1))
58 ;;; Stig E Sandoe reported in cclan-Bugs-431263 that SBCL couldn't
59 ;;; compile this. sbcl-0.6.12.26 died in CIRCULAR-LIST-P with "The
60 ;;; value \"EST\" is not of type LIST." Dan Barlow fixed it.
62 '((5 "EDT" . "EST") (6 "CDT" . "CST") (7 "MDT" .
63 "MST") (8 "PDT" . "PST")
64 (0 "GMT" . "GDT") (-2 "MET" . "MET DST"))
65 "*The string representations of the time zones.")
67 ;;; The old CMU CL Python compiler assumed that it was safe to infer
68 ;;; function types (including return types) from function definitions
69 ;;; and then use them to optimize code later. This is of course bad
70 ;;; when functions are redefined. The problem was fixed in
82 (assert (eql (bar 11) :real))
83 (assert (eql (bar -11) :fixnum))
84 (setf (symbol-function 'foo) #'identity)
85 (assert (eql (bar 11) :fixnum))
86 (assert (eql (bar -11.0) :real))
87 (assert (eql (bar "this is a test") :string))
88 (assert (eql (bar (make-hash-table)) :t))
90 ;;; bug reported by Brian Spilsbury sbcl-devel 2001-09-30, fixed by
91 ;;; Alexey Dejneka patch sbcl-devel 2001-10-02
92 (defun pixarray-element-size (pixarray)
93 (let ((eltype (array-element-type pixarray)))
94 (cond ((eq eltype 'bit) 1)
96 (eq (first eltype) 'unsigned-byte))
99 (error "Invalid pixarray: ~S." pixarray)))))
100 (assert (eql 1 (pixarray-element-size #*110)))
102 ;;; bug 31 turned out to be a manifestation of non-ANSI array type
103 ;;; handling, fixed by CSR in sbcl-0.7.3.8.
104 (defun array-element-type-handling (x)
105 (declare (type (vector cons) x))
106 (when (consp (aref x 0))
108 (assert (eq (array-element-type-handling
109 (make-array 3 :element-type t :initial-element 0))
112 ;;; bug 220: type check inserted after all arguments in MV-CALL caused
113 ;;; failure of stack analysis
114 (defun bug220-helper ()
116 (assert (equal (multiple-value-call #'list
117 (the integer (bug220-helper))
121 ;;; bug 221: sbcl 0.7.9.13 failed to compile the following function
122 (declaim (ftype (function (fixnum) (values package boolean)) bug221-f1))
123 (declaim (ftype (function (t) (values package boolean)) bug221-f2))
125 (funcall (if b #'bug221-f1 #'bug221-f2) x))
127 ;;; bug 166: compiler failure
129 (defmethod permanentize ((uustk bug166s))
130 (flet ((frob (hash-table test-for-deletion)
132 (obj-entry.stale? (oe)
133 (destructuring-bind (key . datum) oe
134 (declare (type simple-vector key))
135 (deny0 (void? datum))
136 (some #'stale? key))))
137 (declare (inline frob obj-entry.stale?))
138 (frob (uustk.args-hash->obj-alist uustk)
140 (frob (uustk.hash->memoized-objs-list uustk)
144 ;;; bugs 115, 226: compiler failure in lifetime analysis
146 (declare (optimize (speed 2) (debug 3)))
148 (unwind-protect nil)))
154 (declare (optimize (speed 2) (debug 3)))
164 (declare (optimize (speed 0) (safety 3) (debug 3)))
165 (flet ((safe-format (stream string &rest r)
166 (unless (ignore-errors (progn
167 (apply #'format stream string r)
169 (format stream "~&foo ~S" string))))
171 ((eq my-result :ERROR)
173 ((ignore-errors (typep condition result))
174 (safe-format t "~&bar ~S" result))
176 (safe-format t "~&baz ~S (~A) ~S" condition condition result)))))))
178 ;;; bug 231: SETQ did not check the type of the variable being set
180 (declare (optimize safety) (type (integer 0 8) x))
182 (assert (raises-error? (bug231-1 8) type-error))
185 (declare (optimize safety) (type (integer 0 8) x))
186 (list (lambda (y) (setq x y))
188 (destructuring-bind (set get) (bug231-2 0)
190 (assert (eql (funcall get) 8))
191 (assert (raises-error? (funcall set 9) type-error))
192 (assert (eql (funcall get) 8)))
194 (sb-ext:quit :unix-status 104) ; success