Really restore clisp cross-compilation.
[sbcl.git] / 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