tests/debug.impure.lisp

   1 ;;;; This file is for testing debugging functionality, using
   2 ;;;; test machinery which might have side effects (e.g.
   3 ;;;; executing DEFUN).
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; While most of SBCL is derived from the CMU CL system, the test
   9 ;;;; files (like this one) were written from scratch after the fork
  10 ;;;; from CMU CL.
  11 ;;;;
  12 ;;;; This software is in the public domain and is provided with
  13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  14 ;;;; more information.
  15
  16 (cl:in-package :cl-user)
  17 \f
  18 ;;;; Check that we get debug arglists right.
  19
  20 ;;; Return the debug arglist of the function object FUN as a list, or
  21 ;;; punt with :UNKNOWN.
  22 (defun get-arglist (fun)
  23   (declare (type function fun))
  24   ;; The Lisp-level type FUNCTION can conceal a multitude of sins..
  25   (case (sb-kernel:widetag-of fun)
  26     (#.sb-vm:simple-fun-header-widetag
  27       (sb-kernel:%simple-fun-arglist fun))
  28     (#.sb-vm:closure-header-widetag (get-arglist
  29                                      (sb-kernel:%closure-fun fun)))
  30     ;; In code/describe.lisp, ll. 227 (%describe-fun), we use a scheme
  31     ;; like above, and it seems to work. -- MNA 2001-06-12
  32     ;;
  33     ;; (There might be other cases with arglist info also.
  34     ;; SIMPLE-FUN-HEADER-WIDETAG and CLOSURE-HEADER-WIDETAG just
  35     ;; happen to be the two case that I had my nose rubbed in when
  36     ;; debugging a GC problem caused by applying %SIMPLE-FUN-ARGLIST to
  37     ;; a closure. -- WHN 2001-06-05)
  38     (t :unknown)))
  39
  40 (defun zoop (zeep &key beep)
  41   blurp)
  42 (assert (equal (get-arglist #'zoop) '(zeep &key beep)))
  43
  44 ;;; Check some predefined functions too.
  45 ;;;
  46 ;;; (We don't know exactly what the arguments are, e.g. the first
  47 ;;; argument of PRINT might be SB-IMPL::OBJECT or SB-KERNEL::OBJ or
  48 ;;; whatever. But we do know the general structure that a correct
  49 ;;; answer should have, so we can safely do a lot of checks.)
  50 (destructuring-bind (object-sym &optional-sym stream-sym) (get-arglist #'print)
  51   (assert (symbolp object-sym))
  52   (assert (eql &optional-sym '&optional))
  53   (assert (symbolp stream-sym)))
  54 (destructuring-bind (dest-sym control-sym &rest-sym format-args-sym)
  55     (get-arglist #'format)
  56   (assert (symbolp dest-sym))
  57   (assert (symbolp control-sym))
  58   (assert (eql &rest-sym '&rest))
  59   (assert (symbolp format-args-sym)))
  60
  61 ;;; success
  62 (quit :unix-status 104)