tests/compiler.impure.lisp

   1 ;;;; This file is for compiler tests which have side effects (e.g.
   2 ;;;; executing DEFUN) but which don't need any special side-effecting
   3 ;;;; environmental stuff (e.g. DECLAIM of particular optimization
   4 ;;;; settings). Similar tests which *do* expect special settings may
   5 ;;;; be in files compiler-1.impure.lisp, compiler-2.impure.lisp, etc.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; While most of SBCL is derived from the CMU CL system, the test
  11 ;;;; files (like this one) were written from scratch after the fork
  12 ;;;; from CMU CL.
  13 ;;;;
  14 ;;;; This software is in the public domain and is provided with
  15 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  16 ;;;; more information.
  17
  18 (cl:in-package :cl-user)
  19
  20 (load "assertoid.lisp")
  21
  22 ;;; Old CMU CL code assumed that the names of "keyword" arguments are
  23 ;;; necessarily self-evaluating symbols, but ANSI Common Lisp allows
  24 ;;; them to be any symbols, not necessarily keywords, and thus not
  25 ;;; necessarily self-evaluating. Make sure that this works.
  26 (defun newfangled-cons (&key ((left-thing x)) ((right-thing y)))
  27   (cons x y))
  28 (assert (equal (cons 1 2) (newfangled-cons 'right-thing 2 'left-thing 1)))
  29
  30 ;;; ANSI specifically says that duplicate keys are OK in lambda lists,
  31 ;;; with no special exception for macro lambda lists. (As reported by
  32 ;;; Pierre Mai on cmucl-imp 2001-03-30, Python didn't think so. The
  33 ;;; rest of the thread had some entertainment value, at least for me
  34 ;;; (WHN). The unbelievers were besmote and now even CMU CL will
  35 ;;; conform to the spec in this regard. Who needs diplomacy when you
  36 ;;; have brimstone?:-)
  37 (defmacro ayup-duplicate-keys-are-ok-i-see-the-lite (&key k)
  38   k)
  39 (assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 112) 112))
  40 (assert (equal (ayup-duplicate-keys-are-ok-i-see-the-lite :k 'x :k 'y) 'x))
  41
  42 ;;; As reported by Alexey Dejneka (sbcl-devel 2002-01-30), in
  43 ;;; sbcl-0.7.1 plus his patch (i.e. essentially sbcl-0.7.1.2), the
  44 ;;; compiler barfed on this, blowing up in FIND-IN-PHYSENV looking for
  45 ;;; the LAMBDA-VAR named NUM. That was fixed in sbcl-0.7.1.3.
  46 (defun parse-num (index)
  47   (let (num x)
  48     (flet ((digs ()
  49              (setq num index))
  50            (z ()
  51              (let ()
  52                (setq x nil))))
  53       (when (and (digs) (digs)) x))))
  54
  55 ;;; Bug 132: The compiler used to fail to compile INTEGER-valued CATCH
  56 ;;; tags. This was fixed by Alexey Dejneka in sbcl-0.7.1.14. (INTEGER
  57 ;;; catch tags are still a bad idea because EQ is used to compare
  58 ;;; tags, and EQ comparison on INTEGERs is unportable; but now it's a
  59 ;;; compiler warning instead of a failure to compile.)
  60 (defun foo ()
  61   (catch 0 (print 1331)))
  62
  63 ;;; Bug 150: In sbcl-0.7.1.15, compiling this code caused a failure in
  64 ;;; SB-C::ADD-TEST-CONSTRAINTS:
  65 ;;;    The value NIL is not of type SB-C::CONTINUATION.
  66 ;;; This bug was fixed by APD in sbcl-0.7.1.30.
  67 (defun bug150-test1 ()
  68   (let* ()
  69     (flet ((wufn () (glorp table1 4.9)))
  70       (gleep *uustk* #'wufn "#1" (list)))
  71     (if (eql (lo foomax 3.2))
  72         (values)
  73         (error "not ~S" '(eql (lo foomax 3.2))))
  74     (values)))
  75 ;;; A simpler test case for bug 150: The compiler died with the
  76 ;;; same type error when trying to compile this.
  77 (defun bug150-test2 ()
  78   (let ()
  79     (<)))
  80
  81 ;;; bug 147, fixed by APD 2002-04-28
  82 ;;;
  83 ;;; This test case used to crash the compiler, e.g. with
  84 ;;;   failed AVER: "(= (LENGTH (BLOCK-SUCC CALL-BLOCK)) 1)"
  85 (defun bug147 (string ind)
  86   (flet ((digs ()
  87            (let (old-index)
  88              (if (and (< ind ind)
  89                       (typep (char string ind) '(member #\1)))
  90                  nil))))))
  91 \f
  92 ;;;; tests not in the problem domain, but of the consistency of the
  93 ;;;; compiler machinery itself
  94
  95 (in-package "SB-C")
  96
  97 ;;; Hunt for wrong-looking things in fundamental compiler definitions,
  98 ;;; and gripe about them.
  99 ;;;
 100 ;;; FIXME: It should be possible to (1) repair the things that this
 101 ;;; code gripes about, and then (2) make the code signal errors
 102 ;;; instead of just printing complaints to standard output, in order
 103 ;;; to prevent the code from later falling back into disrepair.
 104 (defun grovel-results (function)
 105   (dolist (template (fun-info-templates (info :function :info function)))
 106     (when (template-more-results-type template)
 107       (format t "~&Template ~A has :MORE results, and translates ~A.~%"
 108               (template-name template)
 109               function)
 110       (return nil))
 111     (when (eq (template-result-types template) :conditional)
 112       ;; dunno.
 113       (return t))
 114     (let ((types (template-result-types template))
 115           (result-type (fun-type-returns (info :function :type function))))
 116       (cond
 117         ((values-type-p result-type)
 118          (do ((ltypes (append (args-type-required result-type)
 119                               (args-type-optional result-type))
 120                       (rest ltypes))
 121               (types types (rest types)))
 122              ((null ltypes)
 123               (unless (null types)
 124                 (format t "~&More types than ltypes in ~A, translating ~A.~%"
 125                         (template-name template)
 126                         function)
 127                 (return nil)))
 128            (when (null types)
 129              (unless (null ltypes)
 130                (format t "~&More ltypes than types in ~A, translating ~A.~%"
 131                        (template-name template)
 132                        function)
 133                (return nil)))))
 134         ((eq result-type (specifier-type nil))
 135          (unless (null types)
 136            (format t "~&Template ~A returns values for function ~A with RESULT-TYPE NIL.~%"
 137                    (template-name template)
 138                    function)
 139            (return nil)))
 140         ((/= (length types) 1)
 141          (format t "~&Template ~A isn't returning 1 value for ~A.~%"
 142                  (template-name template)
 143                  function)
 144          (return nil))
 145         (t t)))))
 146 (defun identify-suspect-vops (&optional (env (first
 147                                               (last *info-environment*))))
 148   (do-info (env :class class :type type :name name :value value)
 149     (when (and (eq class :function) (eq type :type))
 150       ;; OK, so we have an entry in the INFO database. Now, if ...
 151       (let* ((info (info :function :info name))
 152              (templates (and info (fun-info-templates info))))
 153         (when templates
 154           ;; ... it has translators
 155           (grovel-results name))))))
 156 (identify-suspect-vops)
 157 \f
 158 ;;; success
 159 (quit :unix-status 104)