src/debug.c

   1 /* Debugging aids -- togglable assertions.
   2    Copyright (C) 1994 Free Software Foundation, Inc.
   3
   4 This file is part of XEmacs.
   5
   6 XEmacs is free software; you can redistribute it and/or modify it
   7 under the terms of the GNU General Public License as published by the
   8 Free Software Foundation; either version 2, or (at your option) any
   9 later version.
  10
  11 XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14 for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with XEmacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  19 Boston, MA 02111-1307, USA.  */
  20
  21 /* Synched up with: Not in FSF. */
  22
  23 /* This file has been Mule-ized. */
  24
  25 /* Written by Chuck Thompson */
  26
  27 #include <config.h>
  28 #include "lisp.h"
  29 #include "debug.h"
  30 #include "bytecode.h"
  31
  32 /*
  33  * To add a new debug class:
  34  * 1.  Add a symbol definition for it here, if one doesn't exist
  35  *     elsewhere.  If you add it here, make sure to add a defsymbol
  36  *     line for it in syms_of_debug.
  37  * 2.  Add an extern definition for the symbol to debug.h.
  38  * 3.  Add entries for the class to struct debug_classes in debug.h.
  39  * 4.  Add a FROB line for it in xemacs_debug_loop.
  40  */
  41
  42 static Lisp_Object Qredisplay, Qbuffers, Qfaces, Qwindows, Qframes, Qdevices;
  43
  44 struct debug_classes active_debug_classes;
  45
  46 enum debug_loop
  47 {
  48   X_ADD,
  49   X_DELETE,
  50   X_LIST,
  51   X_ACTIVE,
  52   X_INIT,
  53   X_VALIDATE,
  54   X_TYPE,
  55   X_SETTYPE
  56 };
  57
  58 static Lisp_Object
  59 xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type)
  60 {
  61   int flag = (op == X_ADD) ? 1 : 0;
  62   Lisp_Object retval = Qnil;
  63
  64 #define FROB(item)                                                      \
  65   if (op == X_LIST || op == X_ACTIVE || op == X_INIT || EQ (class, Q##item))    \
  66     {                                                                   \
  67       if (op == X_ADD || op == X_DELETE || op == X_INIT)                        \
  68         active_debug_classes.item = flag;                               \
  69       else if (op == X_LIST                                             \
  70                || (op == X_ACTIVE && active_debug_classes.item))                \
  71         retval = Fcons (Q##item, retval);                               \
  72       else if (op == X_VALIDATE)                                                \
  73         return Qt;                                                      \
  74       else if (op == X_SETTYPE)                                         \
  75         active_debug_classes.types_of_##item = XINT (type);             \
  76       else if (op == X_TYPE)                                            \
  77         retval = make_int (active_debug_classes.types_of_##item);       \
  78       if (op == X_INIT) active_debug_classes.types_of_##item = VALBITS; \
  79     }
  80
  81   FROB (redisplay);
  82   FROB (buffers);
  83   FROB (extents);
  84   FROB (faces);
  85   FROB (windows);
  86   FROB (frames);
  87   FROB (devices);
  88   FROB (byte_code);
  89
  90   return retval;
  91 #undef FROB
  92 }
  93
  94 DEFUN ("add-debug-class-to-check", Fadd_debug_class_to_check, 1, 1, 0, /*
  95 Add a debug class to the list of active classes.
  96 */
  97        (class))
  98 {
  99   if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
 100     error ("No such debug class exists");
 101   else
 102     xemacs_debug_loop (X_ADD, class, Qnil);
 103
 104   return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
 105 }
 106
 107 DEFUN ("delete-debug-class-to-check", Fdelete_debug_class_to_check, 1, 1, 0, /*
 108 Delete a debug class from the list of active classes.
 109 */
 110        (class))
 111 {
 112   if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
 113     error ("No such debug class exists");
 114   else
 115     xemacs_debug_loop (X_DELETE, class, Qnil);
 116
 117   return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
 118 }
 119
 120 DEFUN ("debug-classes-being-checked", Fdebug_classes_being_checked, 0, 0, 0, /*
 121 Return a list of active debug classes.
 122 */
 123        ())
 124 {
 125   return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
 126 }
 127
 128 DEFUN ("debug-classes-list", Fdebug_classes_list, 0, 0, 0, /*
 129 Return a list of all defined debug classes.
 130 */
 131        ())
 132 {
 133   return (xemacs_debug_loop (X_LIST, Qnil, Qnil));
 134 }
 135
 136 DEFUN ("set-debug-classes-to-check", Fset_debug_classes_to_check, 1, 1, 0, /*
 137 Set which classes of debug statements should be active.
 138 CLASSES should be a list of debug classes.
 139 */
 140        (classes))
 141 {
 142   Lisp_Object rest;
 143
 144   CHECK_LIST (classes);
 145
 146   /* Make sure all objects in the list are valid.  If anyone is not
 147      valid, reject the entire list without doing anything. */
 148   LIST_LOOP (rest, classes )
 149     {
 150       if (NILP (xemacs_debug_loop (X_VALIDATE, XCAR (rest), Qnil)))
 151         error ("Invalid object in class list");
 152     }
 153
 154   LIST_LOOP (rest, classes)
 155     Fadd_debug_class_to_check (XCAR (rest));
 156
 157   return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
 158 }
 159
 160 DEFUN ("set-debug-class-types-to-check", Fset_debug_class_types_to_check, 2, 2, 0, /*
 161 For the given debug CLASS, set which TYPES are actually interesting.
 162 TYPES should be an integer representing the or'd value of all desired types.
 163 Lists of defined types and their values are located in the source code.
 164 */
 165        (class, type))
 166 {
 167   CHECK_INT (type);
 168   if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
 169     error ("Invalid debug class");
 170
 171   xemacs_debug_loop (X_SETTYPE, class, type);
 172
 173   return (xemacs_debug_loop (X_TYPE, class, Qnil));
 174 }
 175
 176 DEFUN ("debug-types-being-checked", Fdebug_types_being_checked, 1, 1, 0, /*
 177 For the given CLASS, return the associated type value.
 178 */
 179        (class))
 180 {
 181   if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
 182     error ("Invalid debug class");
 183
 184   return (xemacs_debug_loop (X_TYPE, class, Qnil));
 185 }
 186
 187 void
 188 syms_of_debug (void)
 189 {
 190   defsymbol (&Qredisplay, "redisplay");
 191   defsymbol (&Qbuffers, "buffers");
 192   defsymbol (&Qfaces, "faces");
 193   defsymbol (&Qwindows, "windows");
 194   defsymbol (&Qframes, "frames");
 195   defsymbol (&Qdevices, "devices");
 196
 197   DEFSUBR (Fadd_debug_class_to_check);
 198   DEFSUBR (Fdelete_debug_class_to_check);
 199   DEFSUBR (Fdebug_classes_being_checked);
 200   DEFSUBR (Fdebug_classes_list);
 201   DEFSUBR (Fset_debug_classes_to_check);
 202   DEFSUBR (Fset_debug_class_types_to_check);
 203   DEFSUBR (Fdebug_types_being_checked);
 204 }
 205
 206 void
 207 reinit_vars_of_debug (void)
 208 {
 209   /* If you need to have any classes active early on in startup, then
 210      the flags should be set here.
 211      All functions called by this function are "allowed" according
 212      to emacs.c. */
 213   xemacs_debug_loop (X_INIT, Qnil, Qnil);
 214 }
 215
 216 void
 217 vars_of_debug (void)
 218 {
 219   reinit_vars_of_debug ();
 220 }