tests/compiler.pure-cload.lisp

   1 ;;;; miscellaneous tests of compiling toplevel forms
   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 ;;; Exercise a compiler bug (by causing a call to ERROR).
  15 ;;;
  16 ;;; This bug was in sbcl-0.6.11.6.
  17 (let ((a 1) (b 1))
  18   (declare (type (mod 1000) a b))
  19   (let ((tmp (= 10 (+ (incf a) (incf a) (incf b) (incf b)))))
  20     (or tmp (error "TMP not true"))))
  21
  22 ;;; Exercise a (byte-)compiler bug by causing a call to ERROR, not
  23 ;;; because the symbol isn't defined as a variable, but because
  24 ;;;  TYPE-ERROR in SB-KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
  25 ;;;     0 is not of type (OR FUNCTION SB-KERNEL:FDEFN).
  26 ;;; Correct behavior is to warn at compile time because the symbol
  27 ;;; isn't declared as a variable, but to set its SYMBOL-VALUE anyway.
  28 ;;;
  29 ;;; This bug was in sbcl-0.6.11.13.
  30 (locally (declare (sb-ext:muffle-conditions warning))
  31   (print (setq improperly-declared-var '(1 2))))
  32 (assert (equal (symbol-value 'improperly-declared-var) '(1 2)))
  33 (makunbound 'improperly-declared-var)
  34 ;;; This is a slightly different way of getting the same symptoms out
  35 ;;; of the sbcl-0.6.11.13 byte compiler bug.
  36 (print (setq *print-level* *print-level*))
  37
  38 ;;; PROGV with different numbers of variables and values
  39 (let ((a 1))
  40   (declare (special a))
  41   (assert (equal (list a (progv '(a b) '(:a :b :c)
  42                            (assert (eq (symbol-value 'nil) nil))
  43                            (list (symbol-value 'a) (symbol-value 'b)))
  44                        a)
  45                  '(1 (:a :b) 1)))
  46   (assert (equal (list a (progv '(a b) '(:a :b)
  47                            (assert (eq (symbol-value 'nil) nil))
  48                            (list (symbol-value 'a) (symbol-value 'b)))
  49                        a)
  50                  '(1 (:a :b) 1)))
  51   (assert (not (boundp 'b))))
  52
  53 (let ((a 1) (b 2))
  54   (declare (special a b))
  55   (assert (equal (list a b (progv '(a b) '(:a)
  56                              (assert (eq (symbol-value 'nil) nil))
  57                              (assert (not (boundp 'b)))
  58                              (symbol-value 'a))
  59                        a b)
  60                  '(1 2 :a 1 2))))
  61
  62 ;;; bug in LOOP, reported by ??? on c.l.l
  63 (flet ((foo (l)
  64          (loop for x in l
  65                when (symbolp x) return x
  66                while (numberp x)
  67                collect (list x))))
  68   (assert (equal (foo '(1 2 #\a 3)) '((1) (2))))
  69   (assert (equal (foo '(1 2 x 3)) 'x)))
  70
  71 ;;; compiler failure found by Paul Dietz' randomized tortuter
  72 (defun #:foo (a b c d)
  73   (declare (type (integer 240 100434465) a)
  74            (optimize (speed 3) (safety 1) (debug 1)))
  75   (logxor
  76    (if (ldb-test (byte 27 4) d)
  77        -1
  78        (max 55546856 -431))
  79    (logorc2
  80     (if (>= 0 b)
  81         (if (> b c) (logandc2 c d) (if (> d 224002) 0 d))
  82         (signum (logior c b)))
  83     (logior a -1))))
  84
  85 (defun #:foo (b c)
  86   (declare (type (integer -23228343 2) b)
  87            (type (integer -115581022 512244512) c)
  88            (optimize (speed 3) (safety 1) (debug 1)))
  89   (* (* (logorc2 3 (deposit-field 4667947 (byte 14 26) b))
  90         (deposit-field b (byte 25 27) -30424886))
  91      (dpb b (byte 23 29) c)))
  92
  93 (defun #:foo (x y)
  94   (declare (type (integer -1 1000000000000000000000000) x y)
  95            (optimize speed))
  96   (* x (* y x)))
  97
  98 (defun #:foo (b)
  99   (declare (type (integer -290488443 2) b)
 100            (optimize (speed 3) (safety 1) (debug 1)))
 101   (let ((v3 (min -1720 b))) (max v3 (logcount (if (= v3 b) b b)))))
 102
 103 (defun #:foo (d)
 104   (let ((v7 (flet ((%f16 () (labels ((%f3 () -8)) (%f3))))
 105               (labels ((%f7 () (%f16)))  d))))
 106     132887443))
 107
 108 ;;; RESULT-FORM in DO is not contained in the implicit TAGBODY
 109 (assert (eq (handler-case (eval `(do ((x '(1 2 3) (cdr x)))
 110                                      ((endp x) (go :loop))
 111                                   :loop
 112                                    (unless x (return :bad))))
 113               (error () :good))
 114             :good))
 115 (assert (eq (handler-case (eval `(do* ((x '(1 2 3) (cdr x)))
 116                                       ((endp x) (go :loop))
 117                                   :loop
 118                                    (unless x (return :bad))))
 119               (error () :good))
 120             :good))
 121
 122 ;;; bug 261
 123 (let ((x (list (the (values &optional fixnum) (eval '(values))))))
 124   (assert (equal x '(nil))))
 125
 126 ;;; Bug 125, reported by Gabe Garza: Python did not preserve identity
 127 ;;; of closures.
 128 (flet ((test-case (test-pred x)
 129          (let ((func (lambda () x)))
 130            (list (eq func func)
 131                  (funcall test-pred func func)
 132                  (delete func (list func))))))
 133   (assert (equal '(t t nil) (funcall (eval #'test-case) #'eq 3))))
 134
 135 ;;; compiler failure reported by Alan Shields:
 136 ;;; MAYBE-INFER-ITERATION-VAR-TYPE did not deal with types (REAL * (n)).
 137 (let ((s (loop for x from (- pi) below (floor (* 2 pi)) by (/ pi 75) count t)))
 138   (assert (= s 219)))
 139
 140 (with-test (:name :specialized-array-dumping)
 141   (macrolet
 142       ((make-tests ()
 143          `(progn
 144             ,@(loop for saetp across
 145                     sb-vm:*specialized-array-element-type-properties*
 146                     for specifier = (sb-vm:saetp-specifier saetp)
 147                     for init = (cond ((member specifier '(character base-char))
 148                                       '(:initial-element #\X))
 149                                      ((eq specifier 't) '(:initial-element :hello))
 150                                      (specifier
 151                                       `(:initial-element
 152                                         ,(sb-vm:saetp-initial-element-default saetp))))
 153                     for array = (apply 'make-array (if specifier 10 0)
 154                                        :element-type specifier init)
 155                     for make-array = `(make-array ,(if specifier 10 0)
 156                                                   :element-type ',specifier
 157                                                   ,@init)
 158                     collect `(assert (and (equal (type-of ,array)
 159                                                  ',(type-of array))
 160                                           (equalp ,array
 161                                                   ,make-array)))))))
 162     (make-tests)))
 163
 164 (defparameter *my-type-test-ran* 0)
 165 (deftype some-weird-type () '(satisfies my-thing-p))
 166 (defun my-thing-p (x)
 167   (incf *my-type-test-ran*)
 168   (member x '(nil :foo)))
 169
 170 (defun make-array-fill-nil ()
 171   (sb-int:dx-let ((a (make-array 5 :initial-element nil
 172                                  :element-type '(or (and complex) some-weird-type))))
 173     (values (stack-allocated-p a)
 174             *my-type-test-ran*)))
 175
 176 (with-test (:name :splat-nil)
 177   (multiple-value-bind (ok tested) (make-array-fill-nil)
 178     ;; should not inhibit stack allocation, should check that NIL is OK
 179     (assert (and ok (eql tested 1)))))
 180
 181 (defun push-values-constants (k)
 182   (let (*)
 183     (if k
 184         (eval k)
 185         (load-time-value t))))
 186
 187 (with-test (:name :push-values-constants)
 188   (assert (eql (push-values-constants 1) 1))
 189   (assert (eql (push-values-constants nil) t)))
 190
 191 (declaim (inline component-xep-references-i))
 192 (defun component-xep-references-i (x)
 193   x)
 194 (let ((x 0))
 195   (defun component-xep-references ()
 196     (incf x)
 197     (let ((x #'component-xep-references-i))
 198       (funcall x 10)))
 199   (defun component-xep-references.2 ()
 200     (component-xep-references-i 1)))
 201
 202 (declaim (maybe-inline component-xep-references-mi))
 203 (defun component-xep-references-mi (x)
 204   x)
 205 (let ((x 0))
 206   (declare (optimize speed (space 0)))
 207   (defun component-xep-references.3 ()
 208     (incf x)
 209     (let ((x #'component-xep-references-mi))
 210       (funcall x 10)))
 211   (defun component-xep-references.4 ()
 212     (component-xep-references-mi 1)))