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 # It's unclear why the majority of these tests are written in shell script when
  19 # many look as though they would be perfectly happy as lisp tests.
  20 # This test, on the other hand, would have a tough time as a lisp test,
  21 # because it needs to make a symlink which would either mean calling run-program
  22 # or using alien-funcall on symlink(). Shell is easier.
  23 mkdir -p inscrutable/f00
  24 echo '(defun zook (x) (declare (integer x)) (length x))' > inscrutable/f00/f00_xyz_bad
  25 ln -s inscrutable/f00/f00_xyz_bad good.lisp
  26 run_sbcl --eval '(setq *default-pathname-defaults* #P"")' \
  27   --eval '(compile-file "good.lisp" :verbose t)' --quit >stdout.out 2>stderr.out
  28 egrep -q 'compiling file ".*good' stdout.out
  29 stdout_ok=$?
  30 egrep -q 'file:.+good' stderr.out
  31 stderr_ok=$?
  32 if [ $stdout_ok = 0 -a $stderr_ok = 0 ] ; then
  33     rm -r good.* stdout.out stderr.out inscrutable
  34     echo "untruenames: PASS"
  35 else
  36     cat stdout.out stderr.out
  37     echo "untruenames: FAIL"
  38     exit $EXIT_LOSE
  39 fi
  40
  41 ## FIXME: all these tests need to be more silent. Too much noise to parse
  42
  43 tmpfilename="$TEST_FILESTEM.lisp"
  44
  45 # This should fail, as type inference should show that the call to FOO
  46 # will return something of the wrong type.
  47 cat > $tmpfilename <<EOF
  48     (in-package :cl-user)
  49     (defun foo (x) (list x))
  50     (defun bar (x) (1+ (foo x)))
  51 EOF
  52 expect_failed_compile $tmpfilename
  53
  54 # This should fail, as type inference should show that the call to FOO
  55 # has a wrong number of args.
  56 cat > $tmpfilename <<EOF
  57     (in-package :cl-user)
  58     (defun foo (x) (or x (foo x x)))
  59 EOF
  60 expect_failed_compile $tmpfilename
  61
  62 # This should fail, as we define a function multiply in the same file
  63 # (CLHS 3.2.2.3).
  64 cat > $tmpfilename <<EOF
  65     (in-package :cl-user)
  66     (defun foo (x) (list x))
  67     (defun foo (x) (cons x x))
  68 EOF
  69 expect_failed_compile $tmpfilename
  70
  71 # This shouldn't fail, as the inner FLETs should not be treated as
  72 # having the same name.
  73 cat > $tmpfilename <<EOF
  74     (in-package :cl-user)
  75     (defun foo (x)
  76       (flet ((baz (y) (load y)))
  77         (declare (notinline baz))
  78         (baz x)))
  79     (defun bar (x)
  80       (flet ((baz (y) (load y)))
  81         (declare (notinline baz))
  82         (baz x)))
  83 EOF
  84 expect_clean_compile $tmpfilename
  85
  86 # This shouldn't fail because it's not really a multiple definition
  87 cat > $tmpfilename <<EOF
  88     (in-package :cl-user)
  89     (eval-when (:compile-toplevel :load-toplevel :execute)
  90       (defun foo (x) x))
  91 EOF
  92 expect_clean_compile $tmpfilename
  93
  94 # Likewise
  95 cat > $tmpfilename <<EOF
  96     (in-package :cl-user)
  97     (eval-when (:compile-toplevel)
  98       (defun foo (x) x))
  99     (defun foo (x) x)
 100 EOF
 101 expect_clean_compile $tmpfilename
 102
 103 # This shouldn't fail despite the apparent type mismatch, because of
 104 # the NOTINLINE declamation.
 105 cat > $tmpfilename <<EOF
 106     (in-package :cl-user)
 107     (defun foo (x) (list x))
 108     (declaim (notinline foo))
 109     (defun bar (x) (1+ (foo x)))
 110 EOF
 111 expect_clean_compile $tmpfilename
 112
 113 # This shouldn't fail, but did until sbcl-0.8.10.4x
 114 cat > $tmpfilename <<EOF
 115     (in-package :cl-user)
 116     (declaim (inline foo))
 117     (defun foo (x)
 118       (1+ x))
 119     (defun bar (y)
 120       (list (foo y) (if (> y 1) (funcall (if (> y 0) #'foo #'identity) y))))
 121 EOF
 122 expect_clean_compile $tmpfilename
 123
 124 # This shouldn't fail despite the apparent type mismatch, because of
 125 # the NOTINLINE declaration.
 126 cat > $tmpfilename <<EOF
 127     (in-package :cl-user)
 128     (defun foo (x) (list x))
 129     (defun bar (x)
 130       (declare (notinline foo))
 131       (1+ (foo x)))
 132 EOF
 133 expect_clean_compile $tmpfilename
 134
 135 # This in an ideal world would fail (that is, return with FAILURE-P
 136 # set), but at present it doesn't.
 137 cat > $tmpfilename <<EOF
 138     (in-package :cl-user)
 139     (defun foo (x) (list x))
 140     (defun bar (x)
 141       (declare (notinline foo))
 142       (locally
 143         (declare (inline foo))
 144         (1+ (foo x))))
 145 EOF
 146 # expect_failed_compile $tmpfilename
 147
 148 # This used to not warn, because the VALUES derive-type optimizer was
 149 # insufficiently precise.
 150 cat > $tmpfilename <<EOF
 151     (in-package :cl-user)
 152     (defun foo (x) (declare (ignore x)) (values))
 153     (defun bar (x) (1+ (foo x)))
 154 EOF
 155 expect_failed_compile $tmpfilename
 156
 157 # Even after making the VALUES derive-type optimizer more precise, the
 158 # following should still be clean.
 159 cat > $tmpfilename <<EOF
 160     (in-package :cl-user)
 161     (defun foo (x) (declare (ignore x)) (values))
 162     (defun bar (x) (car x))
 163 EOF
 164 expect_clean_compile $tmpfilename
 165
 166 # NOTINLINE on known functions shouldn't inhibit type inference
 167 # (spotted by APD sbcl-devel 2003-06-14)
 168 cat > $tmpfilename <<EOF
 169     (in-package :cl-user)
 170     (defun foo (x)
 171       (declare (notinline list))
 172       (1+ (list x)))
 173 EOF
 174 expect_failed_compile $tmpfilename
 175
 176 # ERROR wants to check its format string for sanity...
 177 cat > $tmpfilename <<EOF
 178     (in-package :cl-user)
 179     (defun foo (x)
 180       (when x
 181         (error "~S")))
 182 EOF
 183 expect_failed_compile $tmpfilename
 184
 185 # ... but it (ERROR) shouldn't complain about being unable to optimize
 186 # when it's uncertain about its argument's type
 187 cat > $tmpfilename <<EOF
 188     (in-package :cl-user)
 189     (defun foo (x)
 190       (error x))
 191 EOF
 192 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 193
 194 # test case from Rudi for some CLOS WARNINGness that shouldn't have
 195 # been there
 196 cat > $tmpfilename <<EOF
 197     (eval-when (:compile-toplevel)
 198        (setf sb-ext:*evaluator-mode* :compile))
 199
 200     (eval-when (:compile-toplevel :load-toplevel :execute)
 201       (defstruct buffer-state
 202         (output-index 0)))
 203
 204     (defclass buffered-stream-mixin ()
 205       ((buffer-state :initform (make-buffer-state))))
 206
 207     (defgeneric frob (stream))
 208     (defmethod frob ((stream t))
 209       nil)
 210     (defmethod frob ((stream buffered-stream-mixin))
 211       (symbol-macrolet
 212             ((index (buffer-state-output-index (slot-value stream 'buffer-state))))
 213           (setf index 0))
 214       (call-next-method))
 215 EOF
 216 expect_clean_compile $tmpfilename
 217
 218 # undeclared unbound variables should cause a full warning, as they
 219 # invoke undefined behaviour
 220 cat > $tmpfilename <<EOF
 221     (defun foo () x)
 222 EOF
 223 expect_failed_compile $tmpfilename
 224
 225 cat > $tmpfilename <<EOF
 226     (declaim (special *x*))
 227     (defun foo () *x*)
 228 EOF
 229 expect_clean_compile $tmpfilename
 230
 231 cat > $tmpfilename <<EOF
 232     (defun foo () (declare (special x)) x)
 233 EOF
 234 expect_clean_compile $tmpfilename
 235
 236 # MUFFLE-CONDITIONS tests
 237 cat > $tmpfilename <<EOF
 238     (defun foo ()
 239       (declare (muffle-conditions style-warning))
 240       (bar))
 241 EOF
 242 expect_clean_compile $tmpfilename
 243
 244 cat > $tmpfilename <<EOF
 245     (defun foo ()
 246       (declare (muffle-conditions code-deletion-note))
 247       (if t (foo) (foo)))
 248 EOF
 249 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 250
 251 cat > $tmpfilename <<EOF
 252     (defun foo (x y)
 253       (declare (muffle-conditions compiler-note))
 254       (declare (optimize speed))
 255       (+ x y))
 256 EOF
 257 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 258
 259 cat > $tmpfilename <<EOF
 260     (declaim (muffle-conditions compiler-note))
 261     (defun foo (x y)
 262       (declare (optimize speed))
 263       (+ x y))
 264 EOF
 265 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 266
 267 cat > $tmpfilename <<EOF
 268     (declaim (optimize debug)
 269              (muffle-conditions compiler-note))
 270     (defun foo (x y)
 271       (declare (optimize speed))
 272       (+ x y))
 273 EOF
 274 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 275
 276 cat > $tmpfilename <<EOF
 277     (declaim (muffle-conditions compiler-note))
 278     (defun foo (x y)
 279       (declare (unmuffle-conditions compiler-note))
 280       (declare (optimize speed))
 281       (+ x y))
 282 EOF
 283 expect_condition_during_compile sb-ext:compiler-note $tmpfilename
 284
 285 # undefined variable causes a WARNING
 286 cat > $tmpfilename <<EOF
 287     (declaim (muffle-conditions warning))
 288     (declaim (unmuffle-conditions style-warning))
 289     (defun foo () x)
 290 EOF
 291 expect_clean_compile $tmpfilename
 292
 293 # top level LOCALLY behaves nicely
 294 cat > $tmpfilename <<EOF
 295     (locally
 296       (declare (muffle-conditions warning))
 297       (defun foo () x))
 298 EOF
 299 expect_clean_compile $tmpfilename
 300
 301 cat > $tmpfilename <<EOF
 302     (locally
 303       (declare (muffle-conditions warning))
 304       (defun foo () x))
 305     (defun bar () x)
 306 EOF
 307 expect_failed_compile $tmpfilename
 308
 309 cat > $tmpfilename <<EOF
 310     (declaim (optimize debug))
 311     (locally
 312       (declare (muffle-conditions warning))
 313       (defun foo () x))
 314     (defun bar () x)
 315 EOF
 316 expect_failed_compile $tmpfilename
 317
 318 cat > $tmpfilename <<EOF
 319     (defun foo ()
 320       (locally (declare (muffle-conditions warning))
 321         (+ x x))
 322       x)
 323 EOF
 324 expect_failed_compile $tmpfilename
 325
 326 # This should fail, and fail nicely -- not eg. loop trying to dump
 327 # references to the unbound variable.
 328 cat > $tmpfilename <<EOF
 329 (defmacro macro-with-unbound-variables (foo)
 330   \`(print ,bar))
 331
 332 (macro-with-unbound-variables 'xxx)
 333 EOF
 334 expect_failed_compile $tmpfilename
 335
 336 # This should fail, as the MAKE-LOAD-FORM must be used for
 337 # externalizing conditions, and the method for CONDITION must signal
 338 # an error.
 339 cat > $tmpfilename <<EOF
 340 (defvar *oops* #.(make-condition 'condition))
 341 EOF
 342 expect_failed_compile $tmpfilename
 343
 344 # This should fail, as the MAKE-LOAD-FORM must be used for objects,
 345 # and the method for STANDARD.OBJECT is required to signal an error.
 346 cat > $tmpfilename <<EOF
 347 (defvar *oops* #.(make-instance 'standard-object))
 348 EOF
 349 expect_failed_compile $tmpfilename
 350
 351 # This should be clean
 352 cat > $tmpfilename <<EOF
 353 (defvar *string* (make-string 10 :element-type 'base-char))
 354 EOF
 355 expect_clean_compile $tmpfilename
 356
 357 # This should style-warn (but not warn or otherwise fail) as the call
 358 # to FORMAT has too many arguments, which is bad style but not
 359 # otherwise fatal.
 360 cat > $tmpfilename <<EOF
 361 (defun foo (a b)
 362   (format nil "abc~~def" a b))
 363 EOF
 364 expect_warned_compile $tmpfilename
 365
 366 # Tests that destructive-functions on known-constant data cause
 367 # compile-time warnings.
 368 cat > $tmpfilename <<EOF
 369 (let ((string "foo"))
 370   (defun foo ()
 371     (setf string "bar")))
 372 EOF
 373 expect_clean_compile $tmpfilename
 374
 375 cat > $tmpfilename <<EOF
 376 (defun foo ()
 377   (let (result)
 378     (nreverse result)))
 379 EOF
 380 expect_clean_compile $tmpfilename
 381
 382 cat > $tmpfilename <<EOF
 383 (defun bar ()
 384   (let ((result ""))
 385     (nreverse result)))
 386 EOF
 387 expect_clean_compile $tmpfilename
 388
 389 cat > $tmpfilename <<EOF
 390 (let ((string "foo"))
 391   (defun foo ()
 392     (replace string "bar")))
 393 EOF
 394 expect_failed_compile $tmpfilename
 395
 396 cat > $tmpfilename <<EOF
 397 (defun foo ()
 398   (setf (char "bar" 0) #\1))
 399 EOF
 400 expect_failed_compile $tmpfilename
 401
 402 cat > $tmpfilename <<EOF
 403 (let ((foo '(1 2 3)))
 404   (defun foo ()
 405     (nconc foo foo)))
 406 EOF
 407 expect_failed_compile $tmpfilename
 408
 409 cat > $tmpfilename <<EOF
 410 x
 411 y
 412 z
 413 EOF
 414 expect_failed_compile $tmpfilename
 415
 416 cat > $tmpfilename <<EOF
 417 (declaim (optimize (speed 3) (space 0) (safety 0)))
 418
 419 (defun foo (bar)
 420   (last bar))
 421 EOF
 422 expect_clean_compile $tmpfilename
 423
 424 cat > $tmpfilename <<EOF
 425 (defstruct foo
 426   (bar #p"/tmp/"))
 427 EOF
 428 expect_clean_compile $tmpfilename
 429
 430 cat > $tmpfilename <<EOF
 431 (eval-when (:compile-toplevel :load-toplevel :execute)
 432   (defstruct foox)
 433   (defmethod make-load-form ((foo foox) &optional env)
 434     (declare (ignore env))
 435     '(make-foox)))
 436 (defstruct bar
 437   (foo #.(make-foox)))
 438 EOF
 439 expect_clean_compile $tmpfilename
 440
 441 cat > $tmpfilename <<EOF
 442 (defun something (x) x)
 443 ...
 444 (defun something-more (x) x)
 445 EOF
 446 expect_aborted_compile $tmpfilename
 447
 448 cat > $tmpfilename <<EOF
 449 (if t (locally))
 450 EOF
 451 expect_clean_cload $tmpfilename
 452
 453 cat > $tmpfilename <<EOF
 454 (defconstant cl-package (find-package :cl))
 455 (defun cl-symbol-p (x)
 456   (eq (symbol-package x) cl-package))
 457 EOF
 458 expect_clean_cload $tmpfilename
 459
 460 cat > $tmpfilename <<EOF
 461 (and (eval-when (:compile-toplevel) (error "oops AND")))
 462 (or (eval-when (:compile-toplevel) (error "oops OR")))
 463 (cond (t (eval-when (:compile-toplevel) (error "oops COND"))))
 464 EOF
 465 expect_clean_cload $tmpfilename
 466
 467 # Test correct fasl-dumping of literals in arglist defaulting.
 468 # (LP Bug #310132)
 469 cat > $tmpfilename <<EOF
 470 (in-package :cl-user)
 471
 472 ;; These are CLHS examples from the dictionary entry for MAKE-LOAD-FORM.
 473 (eval-when (:compile-toplevel :load-toplevel :execute)
 474   (defstruct my-struct a b c)
 475   (defmethod make-load-form ((s my-struct) &optional environment)
 476     (make-load-form-saving-slots s :environment environment))
 477   (defclass my-class ()
 478     ((x :initarg :x :reader obj-x)
 479      (y :initarg :y :reader obj-y)
 480      (dist :accessor obj-dist)))
 481   (defmethod make-load-form ((self my-class) &optional environment)
 482     (make-load-form-saving-slots self
 483                                  :slot-names '(x y)
 484                                  :environment environment)))
 485
 486 (defun bar1 (&optional (x #.(make-my-struct)))
 487   x)
 488
 489 (defun bar2 (&optional (x #.(make-instance 'my-class)))
 490   x)
 491
 492 ;; Packages are externalizable.
 493 (defun bar3 (&optional (x #.*package*))
 494   x)
 495
 496 (assert (typep (bar1) 'my-struct))
 497 (assert (typep (bar2) 'my-class))
 498 (assert (eq (bar3) *package*))
 499
 500 EOF
 501 expect_clean_cload $tmpfilename
 502
 503 cat > $tmpfilename <<EOF
 504 (in-package :cl-user)
 505 (defmacro foo () (error "ERROR at macroexpansion time."))
 506 (defun bar () (foo))
 507 EOF
 508 expect_condition_during_compile sb-c:compiler-error $tmpfilename
 509
 510 cat > $tmpfilename <<EOF
 511 (eval-when (:compile-toplevel)
 512   (error "ERROR within EVAL-WHEN."))
 513 EOF
 514 expect_condition_during_compile simple-error $tmpfilename
 515
 516 cat > $tmpfilename <<EOF
 517 (defun slot-name-incf (s)
 518   (with-slots (no-such-slot) s
 519     (incf no-such-slot)))
 520 EOF
 521 expect_clean_cload $tmpfilename
 522
 523 cat > $tmpfilename <<EOF
 524 (in-package :cl-user)
 525
 526 (defun foo ()
 527   (declare (muffle-conditions warning))
 528   (let ((em 0d0))
 529     (declare (type double-float em))
 530     (dotimes (i 42)
 531       (setf em (float (1+ i))))))
 532 EOF
 533 expect_clean_compile $tmpfilename
 534
 535 cat > $tmpfilename <<EOF
 536 (in-package :cl-user)
 537
 538 (defun foo ()
 539   (declare (muffle-conditions warning))
 540   (flet ((foo ()
 541            (declare (values fixnum))
 542            nil))
 543     (foo)))
 544 EOF
 545 expect_clean_compile $tmpfilename
 546
 547 cat > $tmpfilename <<EOF
 548 (in-package :cl-user)
 549
 550 (defun foo (x)
 551   (declare (muffle-conditions warning)
 552            (type (vector (mod 7) 1) x))
 553   (setf (aref x 0) 8)
 554   x)
 555 EOF
 556 expect_clean_compile $tmpfilename
 557
 558 cat > $tmpfilename <<EOF
 559 (in-package :cl-user)
 560
 561 (declaim (notinline foo))
 562 (let ((i 0)) (defun foo (x) (incf i x)))
 563 (defun bar (x) (foo x))
 564 EOF
 565 fail_on_condition_during_compile sb-ext:compiler-note $tmpfilename
 566
 567 cat > $tmpfilename <<EOF
 568 (in-package :cl-user)
 569
 570 (eval-when (:compile-toplevel :load-toplevel :execute)
 571   (defclass subclass (superclass) ((zslot2 :initarg :zslot2 :accessor zslot2))))
 572
 573 (eval-when (:compile-toplevel :load-toplevel :execute)
 574   (defclass superclass () ((c :initarg c :accessor c))))
 575
 576 (eval-when (:compile-toplevel :load-toplevel :execute)
 577   (sb-kernel::%invalidate-layout (sb-pcl::class-wrapper (find-class 'subclass))))
 578
 579 ;; This test file is weird. It expects to see warnings from a COMPILE inside
 580 ;; a method body that is compiled (and not necessarily invoked).
 581 ;; To force the warnings to happen, we have to force the method to get called,
 582 ;; which we can do by asking a SUBTYPEP question.
 583 (eval-when (:compile-toplevel :load-toplevel :execute)
 584   (defmethod sb-mop:finalize-inheritance :after (class)
 585     (eval '(defmethod z (x) (abcde)))
 586     (funcall (compile nil '(lambda () (defun zz (x) (defgh))))))
 587   (assert (not (sb-kernel:csubtypep (sb-kernel:specifier-type 'subclass)
 588                                     (sb-kernel:specifier-type 'condition)))))
 589
 590 (defun subclass-p (x)
 591   (typep x 'subclass))
 592 EOF
 593 expect_warned_compile $tmpfilename
 594
 595 cat > $tmpfilename <<EOF
 596 (let ((a (load-time-value (funcall (lambda () 128)))))
 597   (declare (fixnum a))
 598   (print a)
 599   (terpri))
 600 EOF
 601 expect_clean_cload $tmpfilename
 602
 603 # Test compiler warning generation for unbound variables from type declaration...
 604 cat > $tmpfilename <<EOF
 605 (defun foo (bar)
 606   (declare (type vector baz))
 607   (length bar))
 608 EOF
 609 expect_failed_compile $tmpfilename
 610
 611 # ... extent declaration ...
 612 cat > $tmpfilename <<EOF
 613 (defun foo (n)
 614   (declare (type (mod 32) n))
 615   (let ((vect (make-array n :element-type 'fixnum)))
 616     (declare (dynamic-extent vec))
 617     (1+ (length vect))))
 618 EOF
 619 expect_failed_compile $tmpfilename
 620
 621 # ... and setq
 622 cat > $tmpfilename <<EOF
 623 (setq nonexistent t)
 624 EOF
 625 expect_failed_compile $tmpfilename
 626
 627 # success
 628 exit $EXIT_TEST_WIN