XEmacs 21.2.20 "Yoko".
[chise/xemacs-chise.git.1] / src / debug.c
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 }