428
+ − 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 {
436
+ − 48 X_ADD,
+ − 49 X_DELETE,
+ − 50 X_LIST,
+ − 51 X_ACTIVE,
+ − 52 X_INIT,
+ − 53 X_VALIDATE,
+ − 54 X_TYPE,
+ − 55 X_SETTYPE
428
+ − 56 };
+ − 57
+ − 58 static Lisp_Object
+ − 59 xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type)
+ − 60 {
436
+ − 61 int flag = (op == X_ADD) ? 1 : 0;
428
+ − 62 Lisp_Object retval = Qnil;
+ − 63
+ − 64 #define FROB(item) \
436
+ − 65 if (op == X_LIST || op == X_ACTIVE || op == X_INIT || EQ (class, Q##item)) \
428
+ − 66 { \
436
+ − 67 if (op == X_ADD || op == X_DELETE || op == X_INIT) \
428
+ − 68 active_debug_classes.item = flag; \
436
+ − 69 else if (op == X_LIST \
+ − 70 || (op == X_ACTIVE && active_debug_classes.item)) \
428
+ − 71 retval = Fcons (Q##item, retval); \
436
+ − 72 else if (op == X_VALIDATE) \
428
+ − 73 return Qt; \
436
+ − 74 else if (op == X_SETTYPE) \
428
+ − 75 active_debug_classes.types_of_##item = XINT (type); \
436
+ − 76 else if (op == X_TYPE) \
428
+ − 77 retval = make_int (active_debug_classes.types_of_##item); \
436
+ − 78 if (op == X_INIT) active_debug_classes.types_of_##item = VALBITS; \
428
+ − 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 {
436
+ − 99 if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
563
+ − 100 invalid_argument ("No such debug class exists", Qunbound);
428
+ − 101 else
436
+ − 102 xemacs_debug_loop (X_ADD, class, Qnil);
428
+ − 103
436
+ − 104 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 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 {
436
+ − 112 if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
563
+ − 113 invalid_argument ("No such debug class exists", Qunbound);
428
+ − 114 else
436
+ − 115 xemacs_debug_loop (X_DELETE, class, Qnil);
428
+ − 116
436
+ − 117 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 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 {
436
+ − 125 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 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 {
436
+ − 133 return (xemacs_debug_loop (X_LIST, Qnil, Qnil));
428
+ − 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 {
436
+ − 150 if (NILP (xemacs_debug_loop (X_VALIDATE, XCAR (rest), Qnil)))
563
+ − 151 sferror ("Invalid object in class list", Qunbound);
428
+ − 152 }
+ − 153
+ − 154 LIST_LOOP (rest, classes)
+ − 155 Fadd_debug_class_to_check (XCAR (rest));
+ − 156
436
+ − 157 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 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);
436
+ − 168 if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
563
+ − 169 invalid_argument ("Invalid debug class", Qunbound);
428
+ − 170
436
+ − 171 xemacs_debug_loop (X_SETTYPE, class, type);
428
+ − 172
436
+ − 173 return (xemacs_debug_loop (X_TYPE, class, Qnil));
428
+ − 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 {
436
+ − 181 if (NILP (xemacs_debug_loop (X_VALIDATE, class, Qnil)))
563
+ − 182 invalid_argument ("Invalid debug class", Qunbound);
428
+ − 183
436
+ − 184 return (xemacs_debug_loop (X_TYPE, class, Qnil));
428
+ − 185 }
+ − 186
+ − 187 void
+ − 188 syms_of_debug (void)
+ − 189 {
563
+ − 190 DEFSYMBOL (Qredisplay);
+ − 191 DEFSYMBOL (Qbuffers);
+ − 192 DEFSYMBOL (Qfaces);
+ − 193 DEFSYMBOL (Qwindows);
+ − 194 DEFSYMBOL (Qframes);
+ − 195 DEFSYMBOL (Qdevices);
428
+ − 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. */
436
+ − 213 xemacs_debug_loop (X_INIT, Qnil, Qnil);
428
+ − 214 }
+ − 215
+ − 216 void
+ − 217 vars_of_debug (void)
+ − 218 {
+ − 219 reinit_vars_of_debug ();
+ − 220 }
