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