1 /* Debugging aids -- togglable assertions.
2 Copyright (C) 1994 Free Software Foundation, Inc.
4 This file is part of XEmacs.
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
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
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. */
21 /* Synched up with: Not in FSF. */
23 /* This file has been Mule-ized. */
25 /* Written by Chuck Thompson */
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.
42 Lisp_Object Qredisplay, Qbuffers, Qfaces;
43 Lisp_Object Qwindows, Qframes, Qdevices;
45 struct debug_classes active_debug_classes;
60 xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type)
62 int flag = (op == ADD) ? 1 : 0;
63 Lisp_Object retval = Qnil;
66 if (op == LIST || op == ACTIVE || op == INIT || EQ (class, Q##item)) \
68 if (op == ADD || op == DELETE || op == INIT) \
69 active_debug_classes.item = flag; \
71 || (op == ACTIVE && active_debug_classes.item)) \
72 retval = Fcons (Q##item, retval); \
73 else if (op == VALIDATE) \
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; \
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.
100 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
101 error ("No such debug class exists");
103 xemacs_debug_loop (ADD, class, Qnil);
105 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
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.
113 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
114 error ("No such debug class exists");
116 xemacs_debug_loop (DELETE, class, Qnil);
118 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
121 DEFUN ("debug-classes-being-checked", Fdebug_classes_being_checked, 0, 0, 0, /*
122 Return a list of active debug classes.
126 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
129 DEFUN ("debug-classes-list", Fdebug_classes_list, 0, 0, 0, /*
130 Return a list of all defined debug classes.
134 return (xemacs_debug_loop (LIST, Qnil, Qnil));
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.
145 CHECK_LIST (classes);
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 )
151 if (NILP (xemacs_debug_loop (VALIDATE, XCAR (rest), Qnil)))
152 error ("Invalid object in class list");
155 LIST_LOOP (rest, classes)
156 Fadd_debug_class_to_check (XCAR (rest));
158 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
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.
169 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
170 error ("Invalid debug class");
172 xemacs_debug_loop (SETTYPE, class, type);
174 return (xemacs_debug_loop (TYPE, class, Qnil));
177 DEFUN ("debug-types-being-checked", Fdebug_types_being_checked, 1, 1, 0, /*
178 For the given CLASS, return the associated type value.
182 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
183 error ("Invalid debug class");
185 return (xemacs_debug_loop (TYPE, class, Qnil));
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 */
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);
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
215 xemacs_debug_loop (INIT, Qnil, Qnil);