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:
1318
+ − 34 * 1. Add a symbol definition for it here or in general-slots.h, if one
+ − 35 * doesn't exist elsewhere. If you add it here, make sure to add a
+ − 36 * defsymbol line for it in syms_of_debug.
428
+ − 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 struct debug_classes active_debug_classes;
+ − 43
+ − 44 enum debug_loop
+ − 45 {
436
+ − 46 X_ADD,
+ − 47 X_DELETE,
+ − 48 X_LIST,
+ − 49 X_ACTIVE,
+ − 50 X_INIT,
+ − 51 X_VALIDATE,
+ − 52 X_TYPE,
+ − 53 X_SETTYPE
428
+ − 54 };
+ − 55
+ − 56 static Lisp_Object
1204
+ − 57 xemacs_debug_loop (enum debug_loop op, Lisp_Object class_, Lisp_Object type)
428
+ − 58 {
436
+ − 59 int flag = (op == X_ADD) ? 1 : 0;
428
+ − 60 Lisp_Object retval = Qnil;
+ − 61
1318
+ − 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; \
428
+ − 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 */
1204
+ − 95 (class_))
428
+ − 96 {
1204
+ − 97 if (NILP (xemacs_debug_loop (X_VALIDATE, class_, Qnil)))
563
+ − 98 invalid_argument ("No such debug class exists", Qunbound);
428
+ − 99 else
1204
+ − 100 xemacs_debug_loop (X_ADD, class_, Qnil);
428
+ − 101
436
+ − 102 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 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 */
1204
+ − 108 (class_))
428
+ − 109 {
1204
+ − 110 if (NILP (xemacs_debug_loop (X_VALIDATE, class_, Qnil)))
563
+ − 111 invalid_argument ("No such debug class exists", Qunbound);
428
+ − 112 else
1204
+ − 113 xemacs_debug_loop (X_DELETE, class_, Qnil);
428
+ − 114
436
+ − 115 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 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 {
436
+ − 123 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 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 {
436
+ − 131 return (xemacs_debug_loop (X_LIST, Qnil, Qnil));
428
+ − 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. */
1204
+ − 146 LIST_LOOP (rest, classes)
428
+ − 147 {
436
+ − 148 if (NILP (xemacs_debug_loop (X_VALIDATE, XCAR (rest), Qnil)))
563
+ − 149 sferror ("Invalid object in class list", Qunbound);
428
+ − 150 }
+ − 151
+ − 152 LIST_LOOP (rest, classes)
+ − 153 Fadd_debug_class_to_check (XCAR (rest));
+ − 154
436
+ − 155 return (xemacs_debug_loop (X_ACTIVE, Qnil, Qnil));
428
+ − 156 }
+ − 157
+ − 158 DEFUN ("set-debug-class-types-to-check", Fset_debug_class_types_to_check, 2, 2, 0, /*
+ − 159 For the given debug CLASS, set which TYPES are actually interesting.
+ − 160 TYPES should be an integer representing the or'd value of all desired types.
+ − 161 Lists of defined types and their values are located in the source code.
+ − 162 */
1204
+ − 163 (class_, type))
428
+ − 164 {
+ − 165 CHECK_INT (type);
1204
+ − 166 if (NILP (xemacs_debug_loop (X_VALIDATE, class_, Qnil)))
563
+ − 167 invalid_argument ("Invalid debug class", Qunbound);
428
+ − 168
1204
+ − 169 xemacs_debug_loop (X_SETTYPE, class_, type);
428
+ − 170
1204
+ − 171 return (xemacs_debug_loop (X_TYPE, class_, Qnil));
428
+ − 172 }
+ − 173
+ − 174 DEFUN ("debug-types-being-checked", Fdebug_types_being_checked, 1, 1, 0, /*
+ − 175 For the given CLASS, return the associated type value.
+ − 176 */
1204
+ − 177 (class_))
428
+ − 178 {
1204
+ − 179 if (NILP (xemacs_debug_loop (X_VALIDATE, class_, Qnil)))
563
+ − 180 invalid_argument ("Invalid debug class", Qunbound);
428
+ − 181
1204
+ − 182 return (xemacs_debug_loop (X_TYPE, class_, Qnil));
428
+ − 183 }
+ − 184
+ − 185 void
+ − 186 syms_of_debug (void)
+ − 187 {
+ − 188 DEFSUBR (Fadd_debug_class_to_check);
+ − 189 DEFSUBR (Fdelete_debug_class_to_check);
+ − 190 DEFSUBR (Fdebug_classes_being_checked);
+ − 191 DEFSUBR (Fdebug_classes_list);
+ − 192 DEFSUBR (Fset_debug_classes_to_check);
+ − 193 DEFSUBR (Fset_debug_class_types_to_check);
+ − 194 DEFSUBR (Fdebug_types_being_checked);
+ − 195 }
+ − 196
+ − 197 void
+ − 198 reinit_vars_of_debug (void)
+ − 199 {
+ − 200 /* If you need to have any classes active early on in startup, then
+ − 201 the flags should be set here.
+ − 202 All functions called by this function are "allowed" according
+ − 203 to emacs.c. */
436
+ − 204 xemacs_debug_loop (X_INIT, Qnil, Qnil);
428
+ − 205 }
+ − 206
+ − 207 void
+ − 208 vars_of_debug (void)
+ − 209 {
+ − 210 }