git.chise.org Git - chise/xemacs-chise.git.1/blob - 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 Lisp_Object Qredisplay, Qbuffers, Qfaces;
  43 Lisp_Object Qwindows, Qframes, Qdevices;
  44
  45 struct debug_classes active_debug_classes;
  46
  47 enum debug_loop
  48 {
  49   ADD,
  50   DELETE,
  51   LIST,
  52   ACTIVE,
  53   INIT,
  54   VALIDATE,
  55   TYPE,
  56   SETTYPE
  57 };
  58
  59 static Lisp_Object
  60 xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type)
  61 {
  62   int flag = (op == ADD) ? 1 : 0;
  63   Lisp_Object retval = Qnil;
  64
  65 #define FROB(item)                                                      \
  66   if (op == LIST || op == ACTIVE || op == INIT || EQ (class, Q##item))  \
  67     {                                                                   \
  68       if (op == ADD || op == DELETE || op == INIT)                      \
  69         active_debug_classes.item = flag;                               \
  70       else if (op == LIST                                               \
  71                || (op == ACTIVE && active_debug_classes.item))          \
  72         retval = Fcons (Q##item, retval);                               \
  73       else if (op == VALIDATE)                                          \
  74         return Qt;                                                      \
  75       else if (op == SETTYPE)                                           \
  76         active_debug_classes.types_of_##item = XINT (type);             \
  77       else if (op == TYPE)                                              \
  78         retval = make_int (active_debug_classes.types_of_##item);       \
  79       if (op == INIT) active_debug_classes.types_of_##item = VALBITS;   \
  80     }
  81
  82   FROB (redisplay);
  83   FROB (buffers);
  84   FROB (extents);
  85   FROB (faces);
  86   FROB (windows);
  87   FROB (frames);
  88   FROB (devices);
  89   FROB (byte_code);
  90
  91   return retval;
  92 #undef FROB
  93 }
  94
  95 DEFUN ("add-debug-class-to-check", Fadd_debug_class_to_check, 1, 1, 0, /*
  96 Add a debug class to the list of active classes.
  97 */
  98        (class))
  99 {
 100   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
 101     error ("No such debug class exists");
 102   else
 103     xemacs_debug_loop (ADD, class, Qnil);
 104
 105   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
 106 }
 107
 108 DEFUN ("delete-debug-class-to-check", Fdelete_debug_class_to_check, 1, 1, 0, /*
 109 Delete a debug class from the list of active classes.
 110 */
 111        (class))
 112 {
 113   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
 114     error ("No such debug class exists");
 115   else
 116     xemacs_debug_loop (DELETE, class, Qnil);
 117
 118   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
 119 }
 120
 121 DEFUN ("debug-classes-being-checked", Fdebug_classes_being_checked, 0, 0, 0, /*
 122 Return a list of active debug classes.
 123 */
 124        ())
 125 {
 126   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
 127 }
 128
 129 DEFUN ("debug-classes-list", Fdebug_classes_list, 0, 0, 0, /*
 130 Return a list of all defined debug classes.
 131 */
 132        ())
 133 {
 134   return (xemacs_debug_loop (LIST, Qnil, Qnil));
 135 }
 136
 137 DEFUN ("set-debug-classes-to-check", Fset_debug_classes_to_check, 1, 1, 0, /*
 138 Set which classes of debug statements should be active.
 139 CLASSES should be a list of debug classes.
 140 */
 141        (classes))
 142 {
 143   Lisp_Object rest;
 144
 145   CHECK_LIST (classes);
 146
 147   /* Make sure all objects in the list are valid.  If anyone is not
 148      valid, reject the entire list without doing anything. */
 149   LIST_LOOP (rest, classes )
 150     {
 151       if (NILP (xemacs_debug_loop (VALIDATE, XCAR (rest), Qnil)))
 152         error ("Invalid object in class list");
 153     }
 154
 155   LIST_LOOP (rest, classes)
 156     Fadd_debug_class_to_check (XCAR (rest));
 157
 158   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
 159 }
 160
 161 DEFUN ("set-debug-class-types-to-check", Fset_debug_class_types_to_check, 2, 2, 0, /*
 162 For the given debug CLASS, set which TYPES are actually interesting.
 163 TYPES should be an integer representing the or'd value of all desired types.
 164 Lists of defined types and their values are located in the source code.
 165 */
 166        (class, type))
 167 {
 168   CHECK_INT (type);
 169   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
 170     error ("Invalid debug class");
 171
 172   xemacs_debug_loop (SETTYPE, class, type);
 173
 174   return (xemacs_debug_loop (TYPE, class, Qnil));
 175 }
 176
 177 DEFUN ("debug-types-being-checked", Fdebug_types_being_checked, 1, 1, 0, /*
 178 For the given CLASS, return the associated type value.
 179 */
 180        (class))
 181 {
 182   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
 183     error ("Invalid debug class");
 184
 185   return (xemacs_debug_loop (TYPE, class, Qnil));
 186 }
 187
 188 void
 189 syms_of_debug (void)
 190 {
 191   defsymbol (&Qredisplay, "redisplay");
 192   defsymbol (&Qbuffers, "buffers");
 193   defsymbol (&Qfaces, "faces");
 194   defsymbol (&Qwindows, "windows");
 195   defsymbol (&Qframes, "frames");
 196   defsymbol (&Qdevices, "devices");
 197   /* defsymbol (&Qbyte_code, "byte-code"); in bytecode.c */
 198
 199   DEFSUBR (Fadd_debug_class_to_check);
 200   DEFSUBR (Fdelete_debug_class_to_check);
 201   DEFSUBR (Fdebug_classes_being_checked);
 202   DEFSUBR (Fdebug_classes_list);
 203   DEFSUBR (Fset_debug_classes_to_check);
 204   DEFSUBR (Fset_debug_class_types_to_check);
 205   DEFSUBR (Fdebug_types_being_checked);
 206 }
 207
 208 void
 209 vars_of_debug (void)
 210 {
 211   /* If you need to have any classes active early on in startup, then
 212      the flags should be set here.
 213      All functions called by this function are "allowed" according
 214      to emacs.c. */
 215   xemacs_debug_loop (INIT, Qnil, Qnil);
 216 }