tests/info.impure.lisp

   1 ;;;; tests of the INFO/globaldb system
   2 ;;;;
   3 ;;;; KLUDGE: Unlike most of the system's tests, these are not in the
   4 ;;;; problem domain, but in the implementation domain, so modification
   5 ;;;; of the system could cause these tests to fail even if the system
   6 ;;;; was still a correct implementation of ANSI Common Lisp + SBCL
   7 ;;;; extensions. Perhaps such tests should be separate from tests in
   8 ;;;; the problem domain. -- WHN 2001-02-11
   9
  10 ;;;; This software is part of the SBCL system. See the README file for
  11 ;;;; more information.
  12 ;;;;
  13 ;;;; While most of SBCL is derived from the CMU CL system, the test
  14 ;;;; files (like this one) were written from scratch after the fork
  15 ;;;; from CMU CL.
  16 ;;;;
  17 ;;;; This software is in the public domain and is provided with
  18 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  19 ;;;; more information.
  20
  21 (in-package :cl-user)
  22
  23 (defun foo (a) (list a))
  24 (let ((x 1)) (foo x))
  25
  26 (assert (eq (sb-int:info :function :where-from 'foo)
  27             :defined))
  28
  29 (defun foo (a b) (list a b))
  30 (let ((x 1)) (foo x 2))
  31
  32 (flet ((foo (a b c)
  33          (list a b c)))
  34   (foo 1 2 3))
  35
  36 ;;; FIXME: This one is commented out since it doesn't work when
  37 ;;; the DEFUN is just LOADed instead of COMPILE-FILEd, and it's
  38 ;;; not immediately obvious what's the best way to set up
  39 ;;; the COMPILE-FILE test.
  40 #||
  41 (assert
  42   (equal
  43    (format nil "~A" (sb-int:info :function :type 'foo))
  44    "#<FUN-TYPE (FUNCTION (T T) LIST)>"))
  45 ||#
  46
  47 (with-test (:name :bug-458015)
  48   ;; Make sure layouts have sane source-locations
  49   (dolist (env sb-c::*info-environment*)
  50     (sb-c::do-info (env :class class :type type :name info-name :value value)
  51       (when (and (symbolp info-name)
  52                  (eql class :type)
  53                  (eql type :kind))
  54         (let* ((classoid (sb-kernel:find-classoid info-name nil))
  55                (layout (and classoid (sb-kernel:classoid-layout classoid)))
  56                (srcloc (and layout (sb-kernel::layout-source-location layout))))
  57           (when (and layout)
  58             (assert (or (sb-c::definition-source-location-p srcloc)
  59                         (null srcloc)))))))))
  60
  61 ;;; success