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 use_test_subdirectory
  17
  18 tmpfilename="$TEST_FILESTEM.lisp"
  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 type inference should show that the call to FOO
  30 # has a wrong number of args.
  31 cat > $tmpfilename <<EOF
  32     (in-package :cl-user)
  33     (defun foo (x) (or x (foo x x)))
  34 EOF
  35 expect_failed_compile $tmpfilename
  36
  37 # This should fail, as we define a function multiply in the same file
  38 # (CLHS 3.2.2.3).
  39 cat > $tmpfilename <<EOF
  40     (in-package :cl-user)
  41     (defun foo (x) (list x))
  42     (defun foo (x) (cons x x))
  43 EOF
  44 expect_failed_compile $tmpfilename
  45
  46 # This shouldn't fail, as the inner FLETs should not be treated as
  47 # having the same name.
  48 cat > $tmpfilename <<EOF
  49     (in-package :cl-user)
  50     (defun foo (x)
  51       (flet ((baz (y) (load y)))
  52         (declare (notinline baz))
  53         (baz x)))
  54     (defun bar (x)
  55       (flet ((baz (y) (load y)))
  56         (declare (notinline baz))
  57         (baz x)))
  58 EOF
  59 expect_clean_compile $tmpfilename
  60
  61 # This shouldn't fail because it's not really a multiple definition
  62 cat > $tmpfilename <<EOF
  63     (in-package :cl-user)
  64     (eval-when (:compile-toplevel :load-toplevel :execute)
  65       (defun foo (x) x))
  66 EOF
  67 expect_clean_compile $tmpfilename
  68
  69 # Likewise
  70 cat > $tmpfilename <<EOF
  71     (in-package :cl-user)
  72     (eval-when (:compile-toplevel)
  73       (defun foo (x) x))
  74     (defun foo (x) x)
  75 EOF
  76 expect_clean_compile $tmpfilename
  77
  78 # This shouldn't fail despite the apparent type mismatch, because of
  79 # the NOTINLINE declamation.
  80 cat > $tmpfilename <<EOF
  81     (in-package :cl-user)
  82     (defun foo (x) (list x))
  83     (declaim (notinline foo))
  84     (defun bar (x) (1+ (foo x)))
  85 EOF
  86 expect_clean_compile $tmpfilename
  87
  88 # This shouldn't fail, but did until sbcl-0.8.10.4x
  89 cat > $tmpfilename <<EOF
  90     (in-package :cl-user)
  91     (declaim (inline foo))
  92     (defun foo (x)
  93       (1+ x))
  94     (defun bar (y)
  95       (list (foo y) (if (> y 1) (funcall (if (> y 0) #'foo #'identity) y))))
  96 EOF
  97 expect_clean_compile $tmpfilename
  98
  99 # This shouldn't fail despite the apparent type mismatch, because of
 100 # the NOTINLINE declaration.
 101 cat > $tmpfilename <<EOF
 102     (in-package :cl-user)
 103     (defun foo (x) (list x))
 104     (defun bar (x)
 105       (declare (notinline foo))
 106       (1+ (foo x)))
 107 EOF
 108 expect_clean_compile $tmpfilename
 109
 110 # This in an ideal world would fail (that is, return with FAILURE-P
 111 # set), but at present it doesn't.
 112 cat > $tmpfilename <<EOF
 113     (in-package :cl-user)
 114     (defun foo (x) (list x))
 115     (defun bar (x)
 116       (declare (notinline foo))
 117       (locally
 118         (declare (inline foo))
 119         (1+ (foo x))))
 120 EOF
 121 # expect_failed_compile $tmpfilename
 122
 123 # This used to not warn, because the VALUES derive-type optimizer was
 124 # insufficiently precise.
 125 cat > $tmpfilename <<EOF
 126     (in-package :cl-user)
 127     (defun foo (x) (declare (ignore x)) (values))
 128     (defun bar (x) (1+ (foo x)))
 129 EOF
 130 expect_failed_compile $tmpfilename
 131
 132 # Even after making the VALUES derive-type optimizer more precise, the
 133 # following should still be clean.
 134 cat > $tmpfilename <<EOF
 135     (in-package :cl-user)
 136     (defun foo (x) (declare (ignore x)) (values))
 137     (defun bar (x) (car x))
 138 EOF
 139 expect_clean_compile $tmpfilename
 140
 141 # NOTINLINE on known functions shouldn't inhibit type inference
 142 # (spotted by APD sbcl-devel 2003-06-14)
 143 cat > $tmpfilename <<EOF
 144     (in-package :cl-user)
 145     (defun foo (x)
 146       (declare (notinline list))
 147       (1+ (list x)))
 148 EOF
 149 expect_failed_compile $tmpfilename
 150
 151 # ERROR wants to check its format string for sanity...
 152 cat > $tmpfilename <<EOF
 153     (in-package :cl-user)
 154     (defun foo (x)
 155       (when x
 156         (error "~S")))
 157 EOF
 158 expect_failed_compile $tmpfilename
 159
 160 # ... but it (ERROR) shouldn't complain about being unable to optimize
 161 # when it's uncertain about its argument's type
 162 cat > $tmpfilename <<EOF
 163     (in-package :cl-user)
 164     (defun foo (x)
 165       (error x))
 166 EOF
 167 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 168
 169 # test case from Rudi for some CLOS WARNINGness that shouldn't have
 170 # been there
 171 cat > $tmpfilename <<EOF
 172     #+sb-eval (eval-when (:compile-toplevel)
 173                 (setf sb-ext:*evaluator-mode* :compile))
 174
 175     (eval-when (:compile-toplevel :load-toplevel :execute)
 176       (defstruct buffer-state
 177         (output-index 0)))
 178
 179     (defclass buffered-stream-mixin ()
 180       ((buffer-state :initform (make-buffer-state))))
 181
 182     (defgeneric frob (stream))
 183     (defmethod frob ((stream t))
 184       nil)
 185     (defmethod frob ((stream buffered-stream-mixin))
 186       (symbol-macrolet
 187             ((index (buffer-state-output-index (slot-value stream 'buffer-state))))
 188           (setf index 0))
 189       (call-next-method))
 190 EOF
 191 expect_clean_compile $tmpfilename
 192
 193 # undeclared unbound variables should cause a full warning, as they
 194 # invoke undefined behaviour
 195 cat > $tmpfilename <<EOF
 196     (defun foo () x)
 197 EOF
 198 expect_failed_compile $tmpfilename
 199
 200 cat > $tmpfilename <<EOF
 201     (declaim (special *x*))
 202     (defun foo () *x*)
 203 EOF
 204 expect_clean_compile $tmpfilename
 205
 206 cat > $tmpfilename <<EOF
 207     (defun foo () (declare (special x)) x)
 208 EOF
 209 expect_clean_compile $tmpfilename
 210
 211 # MUFFLE-CONDITIONS tests
 212 cat > $tmpfilename <<EOF
 213     (defun foo ()
 214       (declare (muffle-conditions style-warning))
 215       (bar))
 216 EOF
 217 expect_clean_compile $tmpfilename
 218
 219 cat > $tmpfilename <<EOF
 220     (defun foo ()
 221       (declare (muffle-conditions code-deletion-note))
 222       (if t (foo) (foo)))
 223 EOF
 224 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 225
 226 cat > $tmpfilename <<EOF
 227     (defun foo (x y)
 228       (declare (muffle-conditions compiler-note))
 229       (declare (optimize speed))
 230       (+ x y))
 231 EOF
 232 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 233
 234 cat > $tmpfilename <<EOF
 235     (declaim (muffle-conditions compiler-note))
 236     (defun foo (x y)
 237       (declare (optimize speed))
 238       (+ x y))
 239 EOF
 240 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 241
 242 cat > $tmpfilename <<EOF
 243     (declaim (muffle-conditions compiler-note))
 244     (defun foo (x y)
 245       (declare (unmuffle-conditions compiler-note))
 246       (declare (optimize speed))
 247       (+ x y))
 248 EOF
 249 expect_condition_during_compile sb-ext:compiler-note $tmpfilename
 250
 251 # undefined variable causes a WARNING
 252 cat > $tmpfilename <<EOF
 253     (declaim (muffle-conditions warning))
 254     (declaim (unmuffle-conditions style-warning))
 255     (defun foo () x)
 256 EOF
 257 expect_clean_compile $tmpfilename
 258
 259 # top level LOCALLY behaves nicely
 260 cat > $tmpfilename <<EOF
 261     (locally
 262       (declare (muffle-conditions warning))
 263       (defun foo () x))
 264 EOF
 265 expect_clean_compile $tmpfilename
 266
 267 cat > $tmpfilename <<EOF
 268     (locally
 269       (declare (muffle-conditions warning))
 270       (defun foo () x))
 271     (defun bar () x)
 272 EOF
 273 expect_failed_compile $tmpfilename
 274
 275 # This should fail, and fail nicely -- not eg. loop trying to dump
 276 # references to the unbound variable.
 277 cat > $tmpfilename <<EOF
 278 (defmacro macro-with-unbound-variables (foo)
 279   \`(print ,bar))
 280
 281 (macro-with-unbound-variables 'xxx)
 282 EOF
 283 expect_failed_compile $tmpfilename
 284
 285 # This should fail, as the MAKE-LOAD-FORM must be used for
 286 # externalizing conditions, and the method for CONDITION must signal
 287 # an error.
 288 cat > $tmpfilename <<EOF
 289 (defvar *oops* #.(make-condition 'condition))
 290 EOF
 291 expect_failed_compile $tmpfilename
 292
 293 # This should fail, as the MAKE-LOAD-FORM must be used for objects,
 294 # and the method for STANDARD.OBJECT is required to signal an error.
 295 cat > $tmpfilename <<EOF
 296 (defvar *oops* #.(make-instance 'standard-object))
 297 EOF
 298 expect_failed_compile $tmpfilename
 299
 300 # This should be clean
 301 cat > $tmpfilename <<EOF
 302 (defvar *string* (make-string 10 :element-type 'base-char))
 303 EOF
 304 expect_clean_compile $tmpfilename
 305
 306 # This should style-warn (but not warn or otherwise fail) as the call
 307 # to FORMAT has too many arguments, which is bad style but not
 308 # otherwise fatal.
 309 cat > $tmpfilename <<EOF
 310 (defun foo (a b)
 311   (format nil "abc~~def" a b))
 312 EOF
 313 expect_warned_compile $tmpfilename
 314
 315 # Tests that destructive-functions on known-constant data cause
 316 # compile-time warnings.
 317 cat > $tmpfilename <<EOF
 318 (let ((string "foo"))
 319   (defun foo ()
 320     (setf string "bar")))
 321 EOF
 322 expect_clean_compile $tmpfilename
 323
 324 cat > $tmpfilename <<EOF
 325 (defun foo ()
 326   (let (result)
 327     (nreverse result)))
 328 EOF
 329 expect_clean_compile $tmpfilename
 330
 331 cat > $tmpfilename <<EOF
 332 (defun bar ()
 333   (let ((result ""))
 334     (nreverse result)))
 335 EOF
 336 expect_clean_compile $tmpfilename
 337
 338 cat > $tmpfilename <<EOF
 339 (let ((string "foo"))
 340   (defun foo ()
 341     (replace string "bar")))
 342 EOF
 343 expect_failed_compile $tmpfilename
 344
 345 cat > $tmpfilename <<EOF
 346 (defun foo ()
 347   (setf (char "bar" 0) #\1))
 348 EOF
 349 expect_failed_compile $tmpfilename
 350
 351 cat > $tmpfilename <<EOF
 352 (let ((foo '(1 2 3)))
 353   (defun foo ()
 354     (nconc foo foo)))
 355 EOF
 356 expect_failed_compile $tmpfilename
 357
 358 cat > $tmpfilename <<EOF
 359 x
 360 y
 361 z
 362 EOF
 363 expect_failed_compile $tmpfilename
 364
 365 cat > $tmpfilename <<EOF
 366 (declaim (optimize (speed 3) (space 0) (safety 0)))
 367
 368 (defun foo (bar)
 369   (last bar))
 370 EOF
 371 expect_clean_compile $tmpfilename
 372
 373 cat > $tmpfilename <<EOF
 374 (defstruct foo
 375   (bar #p"/tmp/"))
 376 EOF
 377 expect_clean_compile $tmpfilename
 378
 379 cat > $tmpfilename <<EOF
 380 (eval-when (:compile-toplevel :load-toplevel :execute)
 381   (defstruct foox)
 382   (defmethod make-load-form ((foo foox) &optional env)
 383     (declare (ignore env))
 384     '(make-foox)))
 385 (defstruct bar
 386   (foo #.(make-foox)))
 387 EOF
 388 expect_clean_compile $tmpfilename
 389
 390 cat > $tmpfilename <<EOF
 391 (defun something (x) x)
 392 ...
 393 (defun something-more (x) x)
 394 EOF
 395 expect_aborted_compile $tmpfilename
 396
 397 cat > $tmpfilename <<EOF
 398 (if t (locally))
 399 EOF
 400 expect_clean_cload $tmpfilename
 401
 402 cat > $tmpfilename <<EOF
 403 (defconstant cl-package (find-package :cl))
 404 (defun cl-symbol-p (x)
 405   (eq (symbol-package x) cl-package))
 406 EOF
 407 expect_clean_cload $tmpfilename
 408
 409 cat > $tmpfilename <<EOF
 410 (and (eval-when (:compile-toplevel) (error "oops AND")))
 411 (or (eval-when (:compile-toplevel) (error "oops OR")))
 412 (cond (t (eval-when (:compile-toplevel) (error "oops COND"))))
 413 EOF
 414 expect_clean_cload $tmpfilename
 415
 416 # Test correct fasl-dumping of literals in arglist defaulting.
 417 # (LP Bug #310132)
 418 cat > $tmpfilename <<EOF
 419 (in-package :cl-user)
 420
 421 ;; These are CLHS examples from the dictionary entry for MAKE-LOAD-FORM.
 422 (eval-when (:compile-toplevel :load-toplevel :execute)
 423   (defstruct my-struct a b c)
 424   (defmethod make-load-form ((s my-struct) &optional environment)
 425     (make-load-form-saving-slots s :environment environment))
 426   (defclass my-class ()
 427     ((x :initarg :x :reader obj-x)
 428      (y :initarg :y :reader obj-y)
 429      (dist :accessor obj-dist)))
 430   (defmethod make-load-form ((self my-class) &optional environment)
 431     (make-load-form-saving-slots self
 432                                  :slot-names '(x y)
 433                                  :environment environment)))
 434
 435 (defun bar1 (&optional (x #.(make-my-struct)))
 436   x)
 437
 438 (defun bar2 (&optional (x #.(make-instance 'my-class)))
 439   x)
 440
 441 ;; Packages are externalizable.
 442 (defun bar3 (&optional (x #.*package*))
 443   x)
 444
 445 (assert (typep (bar1) 'my-struct))
 446 (assert (typep (bar2) 'my-class))
 447 (assert (eq (bar3) *package*))
 448
 449 EOF
 450 expect_clean_cload $tmpfilename
 451
 452 cat > $tmpfilename <<EOF
 453 (in-package :cl-user)
 454 (defmacro foo () (error "ERROR at macroexpansion time."))
 455 (defun bar () (foo))
 456 EOF
 457 expect_condition_during_compile sb-c:compiler-error $tmpfilename
 458
 459 cat > $tmpfilename <<EOF
 460 (eval-when (:compile-toplevel)
 461   (error "ERROR within EVAL-WHEN."))
 462 EOF
 463 expect_condition_during_compile simple-error $tmpfilename
 464
 465 cat > $tmpfilename <<EOF
 466 (defun slot-name-incf (s)
 467   (with-slots (no-such-slot) s
 468     (incf no-such-slot)))
 469 EOF
 470 expect_clean_cload $tmpfilename
 471
 472 cat > $tmpfilename <<EOF
 473 (in-package :cl-user)
 474
 475 (defun foo ()
 476   (declare (muffle-conditions warning))
 477   (let ((em 0d0))
 478     (declare (type double-float em))
 479     (dotimes (i 42)
 480       (setf em (float (1+ i))))))
 481 EOF
 482 expect_clean_compile $tmpfilename
 483
 484 cat > $tmpfilename <<EOF
 485 (in-package :cl-user)
 486
 487 (defun foo ()
 488   (declare (muffle-conditions warning))
 489   (flet ((foo ()
 490            (declare (values fixnum))
 491            nil))
 492     (foo)))
 493 EOF
 494 expect_clean_compile $tmpfilename
 495
 496 cat > $tmpfilename <<EOF
 497 (in-package :cl-user)
 498
 499 (defun foo (x)
 500   (declare (muffle-conditions warning)
 501            (type (vector (mod 7) 1) x))
 502   (setf (aref x 0) 8)
 503   x)
 504 EOF
 505 expect_clean_compile $tmpfilename
 506
 507 cat > $tmpfilename <<EOF
 508 (in-package :cl-user)
 509
 510 (declaim (notinline foo))
 511 (let ((i 0)) (defun foo (x) (incf i x)))
 512 (defun bar (x) (foo x))
 513 EOF
 514 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 515
 516 # success
 517 exit $EXIT_TEST_WIN