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 float))
 101   (declare (ignore a))
 102   (xref/3))
 103
 104 (declaim (inline inline/1))
 105 (defun inline/1 ()
 106   (xref/3)
 107   (values +z+ *a*))
 108
 109 (eval-when (:compile-toplevel :load-toplevel)
 110   (defun xref/12 ()
 111     (flet ((a ()
 112              ;; Counts as calling xref/2
 113              (xref/2)))
 114       (declare (inline a))
 115       (a)
 116       ;; Doesn't count as calling xref/3, or referring to +z+ / *a*
 117       (inline/1))))
 118
 119 ;; last node of block should also be taken into account
 120 (defun xref/13 (x)
 121   (setf *a* x))
 122
 123 (defun xref/14 ()
 124   *a*)
 125
 126 ;; calling a function in a macro body
 127 (defmacro macro/1 ()
 128   (when nil
 129     (xref/12))
 130   nil)
 131
 132 ;; expanding a macro
 133 (defun macro-use/1 ()
 134   (macro/1))
 135
 136 ;; expanding a macro in an flet/labels
 137 (defun macro-use/2 ()
 138   (flet ((inner-flet ()
 139            (macro/1)))
 140     (inner-flet)))
 141
 142 ;; expanding a macro in an toplevel flet/labels
 143 (flet ((outer-flet ()
 144          (macro/1)))
 145   (defun macro-use/3 ()
 146     (outer-flet)))
 147
 148 ;; expanding a macro in an inlined flet/labels
 149 (defun macro-use/4 ()
 150   (flet ((inner-flet ()
 151            (macro/1)))
 152     (declare (inline inner-flet))
 153     (inner-flet)))
 154
 155 (declaim (inline inline/2))
 156 (defun inline/2 ()
 157   (macro/1))
 158
 159 ;; Inlining inline/3 doesn't count as macroexpanding macro/1
 160 (defun macro-use/5 ()
 161   (inline/2))
 162
 163 ;;; Code in the macrolet definition bodies is currently not considered
 164 ;;; at all for XREF. Maybe it should be, but it's slightly tricky to
 165 ;;; implement.
 166 #+nil
 167 (progn
 168   (defun macrolet/1 ()
 169     (macrolet ((a ()
 170                  (inline/2)
 171                1))
 172       (a)))
 173   (defun macrolet/2 ()
 174     (macrolet ((inner-m ()
 175                  (macro/1)))
 176       (inner-m))))
 177
 178 ;;; Inlining functions with non-trivial lambda-lists.
 179 (declaim (inline inline/3))
 180 (defun inline/3 (a &optional b &key c d)
 181   (list a b c d))
 182 (defun inline/3-user/1 (a)
 183   (inline/3 a))
 184 (defun inline/3-user/2 (a b)
 185   (inline/3 a b))
 186 (defun inline/3-user/3 (a b c)
 187   (inline/3 a b :c c))
 188 (defun inline/3-user/4 (a b c d)
 189   (inline/3 a b :d d :c c))
 190
 191 (declaim (inline inline/4))
 192 (defun inline/4 (a &rest more)
 193   (cons a more))
 194 (defun inline/4-user ()
 195   (inline/4 :a :b :c))
 196
 197 ;;; Test references to / from compiler-macros and source-transforms
 198
 199 (define-compiler-macro cmacro (x)
 200   `(+ ,x 42))
 201 (defstruct struct slot)
 202 (defun source-user (x)
 203   (cmacro (struct-slot x)))
 204
 205 ;;; Test specialization
 206
 207 (defclass a-class () ())
 208 (defclass a-subclass (a-class) ())
 209
 210 (defstruct a-structure)
 211 (defstruct (a-substructure (:include a-structure)))
 212
 213 (defvar *an-instance-of-a-class* (make-instance 'a-class))
 214 (defvar *an-instance-of-a-subclass* (make-instance 'a-subclass))
 215
 216 (defvar *an-instance-of-a-structure* (make-a-structure))
 217 (defvar *an-instance-of-a-substructure* (make-a-substructure))
 218
 219 (defmethod a-gf-1 ((x a-class)))
 220 (defmethod a-gf-1 ((x a-structure)))
 221
 222 (defmethod a-gf-2 ((x (eql *an-instance-of-a-class*))))
 223 (defmethod a-gf-2 ((x (eql *an-instance-of-a-structure*))))
 224
 225 (defmethod a-gf-3 ((x (eql *an-instance-of-a-subclass*))))
 226 (defmethod a-gf-3 ((x (eql *an-instance-of-a-substructure*))))