contrib/sb-introspect/xref-test-data.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (defpackage :sb-introspect-test/xref
  11   (:use "SB-INTROSPECT" "CL" "SB-RT"))
  12
  13 (in-package :sb-introspect-test/xref)
  14
  15 (defvar *a* nil)
  16 (defconstant +z+ 'zzz)
  17
  18 (defun foo () 1)
  19 (defun bar (x) x)
  20
  21 ;; Should:
  22 ;;   reference *a*
  23 ;;   call bar
  24 ;;   not call foo
  25 ;;   not call xref/2
  26 (defun xref/1 ()
  27   (flet ((foo ()
  28            (bar *a*)))
  29     (flet ((xref/2 ()
  30              1))
  31       (foo)
  32       (xref/2))))
  33
  34 ;; Should:
  35 ;;   reference *a*, set *a*, bind *a*
  36 ;;   call xref/1
  37 ;;   not bind b
  38 (defun xref/2 ()
  39   (setf *a* *a*)
  40   (let* ((b 1)
  41          (*a* b))
  42     (when nil
  43       (xref/1))))
  44
  45 (let ((x 1))
  46   ;; Should:
  47   ;;   call bar
  48   ;;   not reference *a*
  49   (defun xref/3 ()
  50     (bar x))
  51   ;; Should:
  52   ;;   not call bar
  53   ;;   reference *a*
  54   (defun xref/4 ()
  55     (setf x *a*)))
  56
  57
  58 (flet ((z ()
  59          (xref/2)))
  60   ;; Should:
  61   ;;   call xref/2
  62   ;;   not call z
  63   (defun xref/5 ()
  64     (z))
  65   ;; Should:
  66   ;;   call xref/2
  67   ;;   not call z
  68   (defun xref/6 ()
  69     (z)))
  70
  71 (defun xref/7 ()
  72   (flet ((a ()
  73            (xref/6)))
  74     #'a))
  75
  76 ;; call xref/2
  77 (let ((a 1))
  78   (defvar *b* (or (xref/2) a)))
  79
  80 ;; call xref/6
  81 (defvar *c* (xref/6))
  82
  83 ;; call xref/2 twice (not three times)
  84 (defun xref/8 ()
  85   (flet ((a ()
  86            (xref/2)))
  87     (a)
  88     (a)
  89     (xref/2)))
  90
  91 ;; Methods work, even ones with lots of arguments.
  92 (defmethod xref/10 (a b c d e f g h (i fixnum))
  93   (xref/2))
  94
  95 ;; Separate methods are indeed separate
  96 (defmethod xref/11 ((a fixnum))
  97   (declare (ignore a))
  98   (xref/2))
  99
 100 (defmethod xref/11 ((a (eql 'z)))
 101   (declare (ignore a))
 102   (xref/2))
 103
 104 (defmethod xref/11 ((a float))
 105   (declare (ignore a))
 106   (xref/3))
 107
 108 (declaim (inline inline/1))
 109 (defun inline/1 ()
 110   (xref/3)
 111   (values +z+ *a*))
 112
 113 (eval-when (:compile-toplevel :load-toplevel)
 114   (defun xref/12 ()
 115     (flet ((a ()
 116              ;; Counts as calling xref/2
 117              (xref/2)))
 118       (declare (inline a))
 119       (a)
 120       ;; Doesn't count as calling xref/3, or referring to +z+ / *a*
 121       (inline/1))))
 122
 123 ;; last node of block should also be taken into account
 124 (defun xref/13 (x)
 125   (setf *a* x))
 126
 127 (defun xref/14 ()
 128   *a*)
 129
 130 (sb-ext:defglobal **global** 31)
 131
 132 (defun xref/15 ()
 133   **global**)
 134
 135 (defun xref/16 (x)
 136   (setf **global** x))
 137
 138 ;; calling a function in a macro body
 139 (defmacro macro/1 ()
 140   (when nil
 141     (xref/12))
 142   nil)
 143
 144 ;; expanding a macro
 145 (defun macro-use/1 ()
 146   (macro/1))
 147
 148 ;; expanding a macro in an flet/labels
 149 (defun macro-use/2 ()
 150   (flet ((inner-flet ()
 151            (macro/1)))
 152     (inner-flet)))
 153
 154 ;; expanding a macro in an toplevel flet/labels
 155 (flet ((outer-flet ()
 156          (macro/1)))
 157   (defun macro-use/3 ()
 158     (outer-flet)))
 159
 160 ;; expanding a macro in an inlined flet/labels
 161 (defun macro-use/4 ()
 162   (flet ((inner-flet ()
 163            (macro/1)))
 164     (declare (inline inner-flet))
 165     (inner-flet)))
 166
 167 (declaim (inline inline/2))
 168 (defun inline/2 ()
 169   (macro/1))
 170
 171 ;; Inlining inline/3 doesn't count as macroexpanding macro/1
 172 (defun macro-use/5 ()
 173   (inline/2))
 174
 175 ;;; Code in the macrolet definition bodies is currently not considered
 176 ;;; at all for XREF. Maybe it should be, but it's slightly tricky to
 177 ;;; implement.
 178 #+nil
 179 (progn
 180   (defun macrolet/1 ()
 181     (macrolet ((a ()
 182                  (inline/2)
 183                1))
 184       (a)))
 185   (defun macrolet/2 ()
 186     (macrolet ((inner-m ()
 187                  (macro/1)))
 188       (inner-m))))
 189
 190 ;;; Inlining functions with non-trivial lambda-lists.
 191 (declaim (inline inline/3))
 192 (defun inline/3 (a &optional b &key c d)
 193   (list a b c d))
 194 (defun inline/3-user/1 (a)
 195   (inline/3 a))
 196 (defun inline/3-user/2 (a b)
 197   (inline/3 a b))
 198 (defun inline/3-user/3 (a b c)
 199   (inline/3 a b :c c))
 200 (defun inline/3-user/4 (a b c d)
 201   (inline/3 a b :d d :c c))
 202
 203 (declaim (inline inline/4))
 204 (defun inline/4 (a &rest more)
 205   (cons a more))
 206 (defun inline/4-user ()
 207   (inline/4 :a :b :c))
 208
 209 ;;; Test references to / from compiler-macros and source-transforms
 210
 211 (define-compiler-macro cmacro (x)
 212   `(+ ,x 42))
 213 (defstruct struct slot)
 214 (defun source-user (x)
 215   (cmacro (struct-slot x)))
 216
 217 ;;; Test specialization
 218
 219 (defclass a-class () ())
 220 (defclass a-subclass (a-class) ())
 221
 222 (defstruct a-structure)
 223 (defstruct (a-substructure (:include a-structure)))
 224
 225 (defvar *an-instance-of-a-class* (make-instance 'a-class))
 226 (defvar *an-instance-of-a-subclass* (make-instance 'a-subclass))
 227
 228 (defvar *an-instance-of-a-structure* (make-a-structure))
 229 (defvar *an-instance-of-a-substructure* (make-a-substructure))
 230
 231 (defmethod a-gf-1 ((x a-class)))
 232 (defmethod a-gf-1 ((x a-structure)))
 233
 234 (defmethod a-gf-2 ((x (eql *an-instance-of-a-class*))))
 235 (defmethod a-gf-2 ((x (eql *an-instance-of-a-structure*))))
 236
 237 (defmethod a-gf-3 ((x (eql *an-instance-of-a-subclass*))))
 238 (defmethod a-gf-3 ((x (eql *an-instance-of-a-substructure*))))
 239
 240 (defun called-by-traced-fun ())
 241
 242 (defun traced-fun ()
 243   (called-by-traced-fun))
 244 (trace traced-fun)
 245
 246 #+sb-eval
 247 (progn
 248   (defun called-by-interpreted-funs ())
 249
 250   (let ((sb-ext:*evaluator-mode* :interpret))
 251     (eval '(defun interpreted-fun ()
 252              (called-by-interpreted-funs))))
 253
 254   (let ((sb-ext:*evaluator-mode* :interpret))
 255     (eval '(defun traced-interpreted-fun ()
 256             (called-by-interpreted-funs))))
 257   (trace traced-interpreted-fun))