tests/compiler.test.sh

   1 #!/bin/sh
   2
   3 # This software is part of the SBCL system. See the README file for
   4 # more information.
   5 #
   6 # While most of SBCL is derived from the CMU CL system, the test
   7 # files (like this one) were written from scratch after the fork
   8 # from CMU CL.
   9 #
  10 # This software is in the public domain and is provided with
  11 # absolutely no warranty. See the COPYING and CREDITS files for
  12 # more information.
  13
  14 . ./expect.sh
  15
  16 base_tmpfilename="compiler-test-$$-tmp"
  17 tmpfilename="$base_tmpfilename.lisp"
  18 compiled_tmpfilename="$base_tmpfilename.fasl"
  19
  20 # This should fail, as type inference should show that the call to FOO
  21 # will return something of the wrong type.
  22 cat > $tmpfilename <<EOF
  23     (in-package :cl-user)
  24     (defun foo (x) (list x))
  25     (defun bar (x) (1+ (foo x)))
  26 EOF
  27 expect_failed_compile $tmpfilename
  28
  29 # This should fail, as we define a function multiply in the same file
  30 # (CLHS 3.2.2.3).
  31 cat > $tmpfilename <<EOF
  32     (in-package :cl-user)
  33     (defun foo (x) (list x))
  34     (defun foo (x) (cons x x))
  35 EOF
  36 expect_failed_compile $tmpfilename
  37
  38 # This shouldn't fail, as the inner FLETs should not be treated as
  39 # having the same name.
  40 cat > $tmpfilename <<EOF
  41     (in-package :cl-user)
  42     (defun foo (x)
  43       (flet ((baz (y) (load y)))
  44         (declare (notinline baz))
  45         (baz x)))
  46     (defun bar (x)
  47       (flet ((baz (y) (load y)))
  48         (declare (notinline baz))
  49         (baz x)))
  50 EOF
  51 expect_clean_compile $tmpfilename
  52
  53 # This shouldn't fail because it's not really a multiple definition
  54 cat > $tmpfilename <<EOF
  55     (in-package :cl-user)
  56     (eval-when (:compile-toplevel :load-toplevel :execute)
  57       (defun foo (x) x))
  58 EOF
  59 expect_clean_compile $tmpfilename
  60
  61 # Likewise
  62 cat > $tmpfilename <<EOF
  63     (in-package :cl-user)
  64     (eval-when (:compile-toplevel)
  65       (defun foo (x) x))
  66     (defun foo (x) x)
  67 EOF
  68 expect_clean_compile $tmpfilename
  69
  70 # This shouldn't fail despite the apparent type mismatch, because of
  71 # the NOTINLINE declamation.
  72 cat > $tmpfilename <<EOF
  73     (in-package :cl-user)
  74     (defun foo (x) (list x))
  75     (declaim (notinline foo))
  76     (defun bar (x) (1+ (foo x)))
  77 EOF
  78 expect_clean_compile $tmpfilename
  79
  80 # This shouldn't fail, but did until sbcl-0.8.10.4x
  81 cat > $tmpfilename <<EOF
  82     (in-package :cl-user)
  83     (declaim (inline foo))
  84     (defun foo (x)
  85       (1+ x))
  86     (defun bar (y)
  87       (list (foo y) (if (> y 1) (funcall (if (> y 0) #'foo #'identity) y))))
  88 EOF
  89 expect_clean_compile $tmpfilename
  90
  91 # This shouldn't fail despite the apparent type mismatch, because of
  92 # the NOTINLINE declaration.
  93 cat > $tmpfilename <<EOF
  94     (in-package :cl-user)
  95     (defun foo (x) (list x))
  96     (defun bar (x)
  97       (declare (notinline foo))
  98       (1+ (foo x)))
  99 EOF
 100 expect_clean_compile $tmpfilename
 101
 102 # This in an ideal world would fail (that is, return with FAILURE-P
 103 # set), but at present it doesn't.
 104 cat > $tmpfilename <<EOF
 105     (in-package :cl-user)
 106     (defun foo (x) (list x))
 107     (defun bar (x)
 108       (declare (notinline foo))
 109       (locally
 110         (declare (inline foo))
 111         (1+ (foo x))))
 112 EOF
 113 # expect_failed_compile $tmpfilename
 114
 115 # This used to not warn, because the VALUES derive-type optimizer was
 116 # insufficiently precise.
 117 cat > $tmpfilename <<EOF
 118     (in-package :cl-user)
 119     (defun foo (x) (declare (ignore x)) (values))
 120     (defun bar (x) (1+ (foo x)))
 121 EOF
 122 expect_failed_compile $tmpfilename
 123
 124 # Even after making the VALUES derive-type optimizer more precise, the
 125 # following should still be clean.
 126 cat > $tmpfilename <<EOF
 127     (in-package :cl-user)
 128     (defun foo (x) (declare (ignore x)) (values))
 129     (defun bar (x) (car x))
 130 EOF
 131 expect_clean_compile $tmpfilename
 132
 133 # NOTINLINE on known functions shouldn't inhibit type inference
 134 # (spotted by APD sbcl-devel 2003-06-14)
 135 cat > $tmpfilename <<EOF
 136     (in-package :cl-user)
 137     (defun foo (x)
 138       (declare (notinline list))
 139       (1+ (list x)))
 140 EOF
 141 expect_failed_compile $tmpfilename
 142
 143 # ERROR wants to check its format string for sanity...
 144 cat > $tmpfilename <<EOF
 145     (in-package :cl-user)
 146     (defun foo (x)
 147       (when x
 148         (error "~S")))
 149 EOF
 150 expect_failed_compile $tmpfilename
 151
 152 # ... but it (ERROR) shouldn't complain about being unable to optimize
 153 # when it's uncertain about its argument's type
 154 cat > $tmpfilename <<EOF
 155     (in-package :cl-user)
 156     (defun foo (x)
 157       (error x))
 158 EOF
 159 fail_on_compiler_note $tmpfilename
 160
 161 # test case from Rudi for some CLOS WARNINGness that shouldn't have
 162 # been there
 163 cat > $tmpfilename <<EOF
 164     #+sb-eval (eval-when (:compile-toplevel)
 165                 (setf sb-ext:*evaluator-mode* :compile))
 166
 167     (eval-when (:compile-toplevel :load-toplevel :execute)
 168       (defstruct buffer-state
 169         (output-index 0)))
 170
 171     (defclass buffered-stream-mixin ()
 172       ((buffer-state :initform (make-buffer-state))))
 173
 174     (defgeneric frob (stream))
 175     (defmethod frob ((stream t))
 176       nil)
 177     (defmethod frob ((stream buffered-stream-mixin))
 178       (symbol-macrolet
 179             ((index (buffer-state-output-index (slot-value stream 'buffer-state))))
 180           (setf index 0))
 181       (call-next-method))
 182 EOF
 183 expect_clean_compile $tmpfilename
 184
 185 # undeclared unbound variables should cause a full warning, as they
 186 # invoke undefined behaviour
 187 cat > $tmpfilename <<EOF
 188     (defun foo () x)
 189 EOF
 190 expect_failed_compile $tmpfilename
 191
 192 cat > $tmpfilename <<EOF
 193     (declaim (special *x*))
 194     (defun foo () *x*)
 195 EOF
 196 expect_clean_compile $tmpfilename
 197
 198 cat > $tmpfilename <<EOF
 199     (defun foo () (declare (special x)) x)
 200 EOF
 201 expect_clean_compile $tmpfilename
 202
 203 # MUFFLE-CONDITIONS tests
 204 cat > $tmpfilename <<EOF
 205     (defun foo ()
 206       (declare (muffle-conditions style-warning))
 207       (bar))
 208 EOF
 209 expect_clean_compile $tmpfilename
 210
 211 cat > $tmpfilename <<EOF
 212     (defun foo ()
 213       (declare (muffle-conditions code-deletion-note))
 214       (if t (foo) (foo)))
 215 EOF
 216 fail_on_compiler_note $tmpfilename
 217
 218 cat > $tmpfilename <<EOF
 219     (defun foo (x y)
 220       (declare (muffle-conditions compiler-note))
 221       (declare (optimize speed))
 222       (+ x y))
 223 EOF
 224 fail_on_compiler_note $tmpfilename
 225
 226 cat > $tmpfilename <<EOF
 227     (declaim (muffle-conditions compiler-note))
 228     (defun foo (x y)
 229       (declare (optimize speed))
 230       (+ x y))
 231 EOF
 232 fail_on_compiler_note $tmpfilename
 233
 234 cat > $tmpfilename <<EOF
 235     (declaim (muffle-conditions compiler-note))
 236     (defun foo (x y)
 237       (declare (unmuffle-conditions compiler-note))
 238       (declare (optimize speed))
 239       (+ x y))
 240 EOF
 241 expect_compiler_note $tmpfilename
 242
 243 # undefined variable causes a WARNING
 244 cat > $tmpfilename <<EOF
 245     (declaim (muffle-conditions warning))
 246     (declaim (unmuffle-conditions style-warning))
 247     (defun foo () x)
 248 EOF
 249 expect_clean_compile $tmpfilename
 250
 251 # top level LOCALLY behaves nicely
 252 cat > $tmpfilename <<EOF
 253     (locally
 254       (declare (muffle-conditions warning))
 255       (defun foo () x))
 256 EOF
 257 expect_clean_compile $tmpfilename
 258
 259 cat > $tmpfilename <<EOF
 260     (locally
 261       (declare (muffle-conditions warning))
 262       (defun foo () x))
 263     (defun bar () x)
 264 EOF
 265 expect_failed_compile $tmpfilename
 266
 267 # This should fail, and fail nicely -- not eg. loop trying to dump
 268 # references to the unbound variable.
 269 cat > $tmpfilename <<EOF
 270 (defmacro macro-with-unbound-variables (foo)
 271   \`(print ,bar))
 272
 273 (macro-with-unbound-variables 'xxx)
 274 EOF
 275 expect_failed_compile $tmpfilename
 276
 277 # This should fail, as the MAKE-LOAD-FORM must be used for
 278 # externalizing conditions, and the method for CONDITION must signal
 279 # an error.
 280 cat > $tmpfilename <<EOF
 281 (defvar *oops* #.(make-condition 'condition))
 282 EOF
 283 expect_failed_compile $tmpfilename
 284
 285 # This should fail, as the MAKE-LOAD-FORM must be used for objects,
 286 # and the method for STANDARD.OBJECT is required to signal an error.
 287 cat > $tmpfilename <<EOF
 288 (defvar *oops* #.(make-instance 'standard-object))
 289 EOF
 290 expect_failed_compile $tmpfilename
 291
 292 # This should be clean
 293 cat > $tmpfilename <<EOF
 294 (defvar *string* (make-string 10 :element-type 'base-char))
 295 EOF
 296 expect_clean_compile $tmpfilename
 297
 298 # This should style-warn (but not warn or otherwise fail) as the call
 299 # to FORMAT has too many arguments, which is bad style but not
 300 # otherwise fatal.
 301 cat > $tmpfilename <<EOF
 302 (defun foo (a b)
 303   (format nil "abc~~def" a b))
 304 EOF
 305 expect_warned_compile $tmpfilename
 306
 307 # Tests that destructive-functions on known-constant data cause
 308 # compile-time warnings.
 309 cat > $tmpfilename <<EOF
 310 (let ((string "foo"))
 311   (defun foo ()
 312     (setf string "bar")))
 313 EOF
 314 expect_clean_compile $tmpfilename
 315
 316 cat > $tmpfilename <<EOF
 317 (defun foo ()
 318   (let (result)
 319     (nreverse result)))
 320 EOF
 321 expect_clean_compile $tmpfilename
 322
 323 cat > $tmpfilename <<EOF
 324 (defun bar ()
 325   (let ((result ""))
 326     (nreverse result)))
 327 EOF
 328 expect_clean_compile $tmpfilename
 329
 330 cat > $tmpfilename <<EOF
 331 (let ((string "foo"))
 332   (defun foo ()
 333     (replace string "bar")))
 334 EOF
 335 expect_failed_compile $tmpfilename
 336
 337 cat > $tmpfilename <<EOF
 338 (defun foo ()
 339   (setf (char "bar" 0) #\1))
 340 EOF
 341 expect_failed_compile $tmpfilename
 342
 343 cat > $tmpfilename <<EOF
 344 (let ((foo '(1 2 3)))
 345   (defun foo ()
 346     (nconc foo foo)))
 347 EOF
 348 expect_failed_compile $tmpfilename
 349
 350 cat > $tmpfilename <<EOF
 351 (declaim (optimize (speed 3) (space 0) (safety 0)))
 352
 353 (defun foo (bar)
 354   (last bar))
 355 EOF
 356 expect_clean_compile $tmpfilename
 357
 358 cat > $tmpfilename <<EOF
 359 (defstruct foo
 360   (bar #p"/tmp/"))
 361 EOF
 362 expect_clean_compile $tmpfilename
 363
 364 cat > $tmpfilename <<EOF
 365 (eval-when (:compile-toplevel :load-toplevel :execute)
 366   (defstruct foox)
 367   (defmethod make-load-form ((foo foox) &optional env)
 368     (declare (ignore env))
 369     '(make-foox)))
 370 (defstruct bar
 371   (foo #.(make-foox)))
 372 EOF
 373 expect_clean_compile $tmpfilename
 374
 375 cat > $tmpfilename <<EOF
 376 (defun something (x) x)
 377 ...
 378 (defun something-more (x) x)
 379 EOF
 380 expect_aborted_compile $tmpfilename
 381
 382 rm $tmpfilename
 383
 384 # success
 385 exit 104