1 ;;;; This file is for compiler tests which have side effects (e.g.
2 ;;;; executing DEFUN) but which don't need any special side-effecting
3 ;;;; environmental stuff (e.g. DECLAIM of particular optimization
4 ;;;; settings). Similar tests which *do* expect special settings may
5 ;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
7 ;;;; This software is part of the SBCL system. See the README file for
10 ;;;; While most of SBCL is derived from the CMU CL system, the test
11 ;;;; files (like this one) were written from scratch after the fork
14 ;;;; This software is in the public domain and is provided with
15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
16 ;;;; more information.
18 (cl:in-package :cl-user)
20 (load "assertoid.lisp")
22 ;;; Old CMU CL code assumed that the names of "keyword" arguments are
23 ;;; necessarily self-evaluating symbols, but ANSI Common Lisp allows
24 ;;; them to be any symbols, not necessarily keywords, and thus not
25 ;;; necessarily self-evaluating. Make sure that this works.
26 (defun newfangled-cons (&key ((left-thing x)) ((right-thing y)))
28 (assert (equal (cons 1 2) (newfangled-cons 'right-thing 2 'left-thing 1)))
30 ;;; ANSI specifically says that duplicate keys are OK in lambda lists,
31 ;;; with no special exception for macro lambda lists. (As reported by
32 ;;; Pierre Mai on cmucl-imp 2001-03-30, Python didn't think so. The
33 ;;; rest of the thread had some entertainment value, at least for me
34 ;;; (WHN). The unbelievers were besmote and now even CMU CL will
35 ;;; conform to the spec in this regard. Who needs diplomacy when you
36 ;;; have brimstone?:-)
37 (defmacro ayup-duplicate-keys-are-ok-i-see-the-lite (&key k)
39 (assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 112) 112))
40 (assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 'x :k 'y) 'x))
42 ;;; As reported by Alexey Dejneka (sbcl-devel 2002-01-30), in
43 ;;; sbcl-0.7.1 plus his patch (i.e. essentially sbcl-0.7.1.2), the
44 ;;; compiler barfed on this, blowing up in FIND-IN-PHYSENV looking for
45 ;;; the LAMBDA-VAR named NUM. That was fixed in sbcl-0.7.1.3.
46 (defun parse-num (index)
53 (when (and (digs) (digs)) x))))
55 ;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH
56 ;;; tags. This was fixed by Alexey Dejneka in sbcl-0.7.1.14. (INTEGER
57 ;;; catch tags are still a bad idea because EQ is used to compare
58 ;;; tags, and EQ comparison on INTEGERs is unportable; but now it's a
59 ;;; compiler warning instead of a failure to compile.)
61 (catch 0 (print 1331)))
63 ;;; Bug 150: In sbcl-0.7.1.15, compiling this code caused a failure in
64 ;;; SB-C::ADD-TEST-CONSTRAINTS:
65 ;;; The value NIL is not of type SB-C::CONTINUATION.
66 ;;; This bug was fixed by APD in sbcl-0.7.1.30.
67 (defun bug150-test1 ()
69 (flet ((wufn () (glorp table1 4.9)))
70 (gleep *uustk* #'wufn "#1" (list)))
71 (if (eql (lo foomax 3.2))
73 (error "not ~S" '(eql (lo foomax 3.2))))
75 ;;; A simpler test case for bug 150: The compiler died with the
76 ;;; same type error when trying to compile this.
77 (defun bug150-test2 ()
81 ;;; bug 147, fixed by APD 2002-04-28
83 ;;; This test case used to crash the compiler, e.g. with
84 ;;; failed AVER: "(= (LENGTH (BLOCK-SUCC CALL-BLOCK)) 1)"
85 (defun bug147 (string ind)
89 (typep (char string ind) '(member #\1)))
92 ;;; bug reported and fixed by Matthias Hoelzl sbcl-devel 2002-05-13
93 (defmacro foo-2002-05-13 () ''x)
94 (eval '(foo-2002-05-13))
95 (compile 'foo-2002-05-13)
96 (foo-2002-05-13) ; (The bug caused UNDEFINED-FUNCTION to be signalled here.)
98 ;;; floating point pain on the PPC.
100 ;;; This test case used to fail to compile on most powerpcs prior to
101 ;;; sbcl-0.7.4.2x, as floating point traps were being incorrectly
103 (defun floating-point-pain (x)
104 (declare (single-float x))
107 ;;; bug found and fixed ca. sbcl-0.7.5.12: The INTERSECTION-TYPE
108 ;;; here satisfies "is a subtype of ARRAY-TYPE", but can't be
109 ;;; accessed with ARRAY-TYPE accessors like
110 ;;; ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE, so ARRAY-related
111 ;;; DEFTRANSFORMs died with TYPE-ERROR at compile time when
112 ;;; compiling the DEFUN here.
113 (defun stupid-input-to-smart-array-deftransforms-0-7-5-12 (v)
114 (declare (type (and simple-vector fwd-type-ref) v))
117 ;;; Ca. sbcl-0.7.5.15 the compiler would fail an internal consistency
118 ;;; check on this code because it expected all calls to %INSTANCE-REF
119 ;;; to be transformed away, but its expectations were dashed by perverse
120 ;;; code containing app programmer errors like this.
121 (defstruct something-known-to-be-a-struct x y)
122 (multiple-value-bind (fun warnings-p failure-p)
126 (cond (t (a4 a2 a3))))
128 (declare (type (or simple-vector null) a5 a6))
129 (something-known-to-be-a-struct-x a5))
133 (cond ((and (funcall a12 a2)
138 (let ((a15 (a1 a2 a3)))
141 (values #'a17 #'a11))))
142 ;; Python sees the structure accessor on the known-not-to-be-a-struct
143 ;; A5 value and is very, very disappointed in you. (But it doesn't
144 ;; signal BUG any more.)
147 ;;;; tests not in the problem domain, but of the consistency of the
148 ;;;; compiler machinery itself
152 ;;; Hunt for wrong-looking things in fundamental compiler definitions,
153 ;;; and gripe about them.
155 ;;; FIXME: It should be possible to (1) repair the things that this
156 ;;; code gripes about, and then (2) make the code signal errors
157 ;;; instead of just printing complaints to standard output, in order
158 ;;; to prevent the code from later falling back into disrepair.
159 (defun grovel-results (function)
160 (dolist (template (fun-info-templates (info :function :info function)))
161 (when (template-more-results-type template)
162 (format t "~&Template ~A has :MORE results, and translates ~A.~%"
163 (template-name template)
166 (when (eq (template-result-types template) :conditional)
169 (let ((types (template-result-types template))
170 (result-type (fun-type-returns (info :function :type function))))
172 ((values-type-p result-type)
173 (do ((ltypes (append (args-type-required result-type)
174 (args-type-optional result-type))
176 (types types (rest types)))
179 (format t "~&More types than ltypes in ~A, translating ~A.~%"
180 (template-name template)
184 (unless (null ltypes)
185 (format t "~&More ltypes than types in ~A, translating ~A.~%"
186 (template-name template)
189 ((eq result-type (specifier-type nil))
191 (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%"
192 (template-name template)
195 ((/= (length types) 1)
196 (format t "~&Template ~A isn't returning 1 value for ~A.~%"
197 (template-name template)
201 (defun identify-suspect-vops (&optional (env (first
202 (last *info-environment*))))
203 (do-info (env :class class :type type :name name :value value)
204 (when (and (eq class :function) (eq type :type))
205 ;; OK, so we have an entry in the INFO database. Now, if ...
206 (let* ((info (info :function :info name))
207 (templates (and info (fun-info-templates info))))
209 ;; ... it has translators
210 (grovel-results name))))))
211 (identify-suspect-vops)
214 (quit :unix-status 104)