gencgc: Simpler conservative root validation on non-x86oids.

[sbcl.git] / contrib / sb-introspect / xref-test-data.lisp

diff --git a/contrib/sb-introspect/xref-test-data.lisp b/contrib/sb-introspect/xref-test-data.lisp
index f529839..aebc327 100644 (file)
--- a/contrib/sb-introspect/xref-test-data.lisp
+++ b/contrib/sb-introspect/xref-test-data.lisp
@@ -1,3 +1,17 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(defpackage :sb-introspect-test/xref
+  (:use "SB-INTROSPECT" "CL" "SB-RT"))
+
+(in-package :sb-introspect-test/xref)
+
 (defvar *a* nil)
 (defconstant +z+ 'zzz)
 
@@ -102,6 +116,13 @@
       ;; Doesn't count as calling xref/3, or referring to +z+ / *a*
       (inline/1))))
 
+;; last node of block should also be taken into account
+(defun xref/13 (x)
+  (setf *a* x))
+
+(defun xref/14 ()
+  *a*)
+
 ;; calling a function in a macro body
 (defmacro macro/1 ()
   (when nil
@@ -154,4 +175,52 @@
                  (macro/1)))
       (inner-m))))
 
-;;; Test references to / from compiler-macros
+;;; Inlining functions with non-trivial lambda-lists.
+(declaim (inline inline/3))
+(defun inline/3 (a &optional b &key c d)
+  (list a b c d))
+(defun inline/3-user/1 (a)
+  (inline/3 a))
+(defun inline/3-user/2 (a b)
+  (inline/3 a b))
+(defun inline/3-user/3 (a b c)
+  (inline/3 a b :c c))
+(defun inline/3-user/4 (a b c d)
+  (inline/3 a b :d d :c c))
+
+(declaim (inline inline/4))
+(defun inline/4 (a &rest more)
+  (cons a more))
+(defun inline/4-user ()
+  (inline/4 :a :b :c))
+
+;;; Test references to / from compiler-macros and source-transforms
+
+(define-compiler-macro cmacro (x)
+  `(+ ,x 42))
+(defstruct struct slot)
+(defun source-user (x)
+  (cmacro (struct-slot x)))
+
+;;; Test specialization
+
+(defclass a-class () ())
+(defclass a-subclass (a-class) ())
+
+(defstruct a-structure)
+(defstruct (a-substructure (:include a-structure)))
+
+(defvar *an-instance-of-a-class* (make-instance 'a-class))
+(defvar *an-instance-of-a-subclass* (make-instance 'a-subclass))
+
+(defvar *an-instance-of-a-structure* (make-a-structure))
+(defvar *an-instance-of-a-substructure* (make-a-substructure))
+
+(defmethod a-gf-1 ((x a-class)))
+(defmethod a-gf-1 ((x a-structure)))
+
+(defmethod a-gf-2 ((x (eql *an-instance-of-a-class*))))
+(defmethod a-gf-2 ((x (eql *an-instance-of-a-structure*))))
+
+(defmethod a-gf-3 ((x (eql *an-instance-of-a-subclass*))))
+(defmethod a-gf-3 ((x (eql *an-instance-of-a-substructure*))))