Mercurial > hg > xemacs-beta

comparison src/debug.c @ 428:3ecd8885ac67 r21-2-22

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 080151679be2
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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 {
48 ADD,
49 DELETE,
50 LIST,
51 ACTIVE,
52 INIT,
53 VALIDATE,
54 TYPE,
55 SETTYPE
56 };
57
58 static Lisp_Object
59 xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type)
60 {
61 int flag = (op == ADD) ? 1 : 0;
62 Lisp_Object retval = Qnil;
63
64 #define FROB(item) \
65 if (op == LIST || op == ACTIVE || op == INIT || EQ (class, Q##item)) \
66 { \
67 if (op == ADD || op == DELETE || op == INIT) \
68 active_debug_classes.item = flag; \
69 else if (op == LIST \
70 || (op == ACTIVE && active_debug_classes.item)) \
71 retval = Fcons (Q##item, retval); \
72 else if (op == VALIDATE) \
73 return Qt; \
74 else if (op == SETTYPE) \
75 active_debug_classes.types_of_##item = XINT (type); \
76 else if (op == TYPE) \
77 retval = make_int (active_debug_classes.types_of_##item); \
78 if (op == INIT) active_debug_classes.types_of_##item = VALBITS; \
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 {
99 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
100 error ("No such debug class exists");
101 else
102 xemacs_debug_loop (ADD, class, Qnil);
103
104 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
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 {
112 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
113 error ("No such debug class exists");
114 else
115 xemacs_debug_loop (DELETE, class, Qnil);
116
117 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
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 {
125 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
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 {
133 return (xemacs_debug_loop (LIST, Qnil, Qnil));
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 {
150 if (NILP (xemacs_debug_loop (VALIDATE, XCAR (rest), Qnil)))
151 error ("Invalid object in class list");
152 }
153
154 LIST_LOOP (rest, classes)
155 Fadd_debug_class_to_check (XCAR (rest));
156
157 return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
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);
168 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
169 error ("Invalid debug class");
170
171 xemacs_debug_loop (SETTYPE, class, type);
172
173 return (xemacs_debug_loop (TYPE, class, Qnil));
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 {
181 if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
182 error ("Invalid debug class");
183
184 return (xemacs_debug_loop (TYPE, class, Qnil));
185 }
186
187 void
188 syms_of_debug (void)
189 {
190 defsymbol (&Qredisplay, "redisplay");
191 defsymbol (&Qbuffers, "buffers");
192 defsymbol (&Qfaces, "faces");
193 defsymbol (&Qwindows, "windows");
194 defsymbol (&Qframes, "frames");
195 defsymbol (&Qdevices, "devices");
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. */
213 xemacs_debug_loop (INIT, Qnil, Qnil);
214 }
215
216 void
217 vars_of_debug (void)
218 {
219 reinit_vars_of_debug ();
220 }