This is debug.c in view mode; [Download] [Up]
/* Debugging aids -- togglable assertions.
Copyright (C) 1994 Free Software Foundation, Inc.
This file is part of XEmacs.
XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.
XEmacs is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING. If not, write to the Free
Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Synched up with: Not in FSF. */
/* This file has been Mule-ized. */
/* Written by Chuck Thompson */
#include <config.h>
#include "lisp.h"
#include "debug.h"
#include "bytecode.h"
/*
* To add a new debug class:
* 1. Add a symbol definition for it here, if one doesn't exist
* elsewhere. If you add it here, make sure to add a defsymbol
* line for it in syms_of_debug.
* 2. Add an extern definition for the symbol to debug.h.
* 3. Add entries for the class to struct debug_classes in debug.h.
* 4. Add a FROB line for it in xemacs_debug_loop.
*/
Lisp_Object Qredisplay, Qbuffers, Qextents, Qfaces;
Lisp_Object Qwindows, Qframes, Qdevices;
/* Lisp_Object Qbytecode; in bytecode.c */
struct debug_classes active_debug_classes;
enum debug_loop
{
ADD,
DELETE,
LIST,
ACTIVE,
INIT,
VALIDATE,
TYPE,
SETTYPE
};
static Lisp_Object
xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type)
{
int flag = ((op == ADD) ? 1 : 0);
Lisp_Object retval = Qnil;
#define FROB(item)\
if (op == LIST || op == ACTIVE || op == INIT || EQ (class, Q##item)) \
{ \
if (op == ADD || op == DELETE || op == INIT) \
active_debug_classes.item = flag; \
else if (op == LIST \
|| (op == ACTIVE && active_debug_classes.item)) \
retval = Fcons (Q##item, retval); \
else if (op == VALIDATE) \
return Qt; \
else if (op == SETTYPE) \
active_debug_classes.types_of_##item = XINT (type); \
else if (op == TYPE) \
retval = make_number (active_debug_classes.types_of_##item), Qnil; \
if (op == INIT) active_debug_classes.types_of_##item = VALBITS; \
}
FROB (redisplay);
FROB (buffers);
FROB (extents);
FROB (faces);
FROB (windows);
FROB (frames);
FROB (devices);
FROB (bytecode);
return retval;
#undef FROB
}
DEFUN ("add-debug-class-to-check", Fadd_debug_class_to_check,
Sadd_debug_class_to_check, 1, 1, 0,
"Add a debug class to the list of active classes.")
(class)
Lisp_Object class;
{
if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
error ("No such debug class exists");
else
xemacs_debug_loop (ADD, class, Qnil);
return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
}
DEFUN ("delete-debug-class-to-check", Fdelete_debug_class_to_check,
Sdelete_debug_class_to_check, 1, 1, 0,
"Delete a debug class from the list of active classes.")
(class)
Lisp_Object class;
{
if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
error ("No such debug class exists");
else
xemacs_debug_loop (DELETE, class, Qnil);
return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
}
DEFUN ("debug-classes-being-checked", Fdebug_classes_being_checked,
Sdebug_classes_being_checked, 0, 0, 0,
"Return a list of active debug classes.")
()
{
return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
}
DEFUN ("debug-classes-list", Fdebug_classes_list, Sdebug_classes_list, 0, 0, 0,
"Return a list of all defined debug classes.")
()
{
return (xemacs_debug_loop (LIST, Qnil, Qnil));
}
DEFUN ("set-debug-classes-to-check", Fset_debug_classes_to_check,
Sset_debug_classes_to_check, 1, 1, 0,
"Set which classes of debug statements should be active.\n\
CLASSES should be a list of debug classes.")
(classes)
Lisp_Object classes;
{
Lisp_Object rest;
CHECK_LIST (classes, 0);
/* Make sure all objects in the list are valid. If anyone is not
valid, reject the entire list without doing anything. */
LIST_LOOP (rest, classes )
{
if (NILP (xemacs_debug_loop (VALIDATE, XCAR (rest), Qnil)))
error ("Invalid object in class list");
}
LIST_LOOP (rest, classes)
Fadd_debug_class_to_check (XCAR (rest));
return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
}
DEFUN ("set-debug-class-types-to-check", Fset_debug_class_types_to_check,
Sset_debug_class_types_to_check, 2, 2, 0,
"For the given debug CLASS, set which TYPES are actually interesting.\n\
TYPES should be an integer representing the or'd value of all desired types.\n\
Lists of defined types and their values are located in the source code.")
(class, type)
Lisp_Object class, type;
{
CHECK_INT (type, 0);
if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
error ("Invalid debug class");
xemacs_debug_loop (SETTYPE, class, type);
return (xemacs_debug_loop (TYPE, class, Qnil));
}
DEFUN ("debug-types-being-checked", Fdebug_types_being_checked,
Sdebug_types_being_checked, 1, 1, 0,
"For the given CLASS, return the associated type value.")
(class)
Lisp_Object class;
{
if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
error ("Invalid debug class");
return (xemacs_debug_loop (TYPE, class, Qnil));
}
void
syms_of_debug (void)
{
defsymbol (&Qredisplay, "redisplay");
defsymbol (&Qbuffers, "buffers");
defsymbol (&Qextents, "extents");
defsymbol (&Qfaces, "faces");
defsymbol (&Qwindows, "windows");
defsymbol (&Qframes, "frames");
defsymbol (&Qdevices, "devices");
/* defsymbol (&Qbytecode, "bytecode"); in bytecode.c */
defsubr (&Sadd_debug_class_to_check);
defsubr (&Sdelete_debug_class_to_check);
defsubr (&Sdebug_classes_being_checked);
defsubr (&Sdebug_classes_list);
defsubr (&Sset_debug_classes_to_check);
defsubr (&Sset_debug_class_types_to_check);
defsubr (&Sdebug_types_being_checked);
}
void
vars_of_debug (void)
{
Fprovide (intern ("debug"));
/* If you need to have any classes active early on in startup, then
the flags should be set here.
All functions called by this function are "allowed" according
to emacs.c. */
xemacs_debug_loop (INIT, Qnil, Qnil);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.