cgit.sxemacs.org Git - sxemacs/blob - src/debug.c

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