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