Mercurial > hg > xemacs-beta

comparison src/debug.c @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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