home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / debug.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-04  |  6.4 KB  |  226 lines
  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 the Free
  18. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* Synched up with: Not in FSF. */
  21.  
  22. /* This file has been Mule-ized. */
  23.  
  24. /* Written by Chuck Thompson */
  25.  
  26. #include <config.h>
  27. #include "lisp.h"
  28. #include "debug.h"
  29. #include "bytecode.h"
  30.  
  31. /*
  32.  * To add a new debug class:
  33.  * 1.  Add a symbol definition for it here, if one doesn't exist
  34.  *     elsewhere.  If you add it here, make sure to add a defsymbol
  35.  *     line for it in syms_of_debug.
  36.  * 2.  Add an extern definition for the symbol to debug.h.
  37.  * 3.  Add entries for the class to struct debug_classes in debug.h.
  38.  * 4.  Add a FROB line for it in xemacs_debug_loop.
  39.  */
  40.  
  41. Lisp_Object Qredisplay, Qbuffers, Qextents, Qfaces;
  42. Lisp_Object Qwindows, Qframes, Qdevices;
  43.  
  44. /* Lisp_Object Qbytecode; in bytecode.c */
  45.  
  46. struct debug_classes active_debug_classes;
  47.  
  48. enum debug_loop
  49. {
  50.   ADD,
  51.   DELETE,
  52.   LIST,
  53.   ACTIVE,
  54.   INIT,
  55.   VALIDATE,
  56.   TYPE,
  57.   SETTYPE
  58. };
  59.  
  60. static Lisp_Object
  61. xemacs_debug_loop (enum debug_loop op, Lisp_Object class, Lisp_Object type)
  62. {
  63.   int flag = ((op == ADD) ? 1 : 0);
  64.   Lisp_Object retval = Qnil;
  65.  
  66. #define FROB(item)\
  67.   if (op == LIST || op == ACTIVE || op == INIT || EQ (class, Q##item))    \
  68.     {                                    \
  69.       if (op == ADD || op == DELETE || op == INIT)            \
  70.     active_debug_classes.item = flag;                \
  71.       else if (op == LIST                        \
  72.            || (op == ACTIVE && active_debug_classes.item))        \
  73.     retval = Fcons (Q##item, retval);                \
  74.       else if (op == VALIDATE)                        \
  75.     return Qt;                            \
  76.       else if (op == SETTYPE)                        \
  77.         active_debug_classes.types_of_##item = XINT (type);        \
  78.       else if (op == TYPE)                        \
  79.         retval = make_number (active_debug_classes.types_of_##item), Qnil; \
  80.       if (op == INIT) active_debug_classes.types_of_##item = VALBITS;    \
  81.     }
  82.  
  83.   FROB (redisplay);
  84.   FROB (buffers);
  85.   FROB (extents);
  86.   FROB (faces);
  87.   FROB (windows);
  88.   FROB (frames);
  89.   FROB (devices);
  90.   FROB (bytecode);
  91.     
  92.   return retval;
  93. #undef FROB
  94. }
  95.  
  96. DEFUN ("add-debug-class-to-check", Fadd_debug_class_to_check,
  97.        Sadd_debug_class_to_check, 1, 1, 0,
  98.        "Add a debug class to the list of active classes.")
  99.      (class)
  100.      Lisp_Object class;
  101. {
  102.   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
  103.     error ("No such debug class exists");
  104.   else
  105.     xemacs_debug_loop (ADD, class, Qnil);
  106.  
  107.   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
  108. }
  109.  
  110. DEFUN ("delete-debug-class-to-check", Fdelete_debug_class_to_check,
  111.        Sdelete_debug_class_to_check, 1, 1, 0,
  112.        "Delete a debug class from the list of active classes.")
  113.      (class)
  114.      Lisp_Object class;
  115. {
  116.   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
  117.     error ("No such debug class exists");
  118.   else
  119.     xemacs_debug_loop (DELETE, class, Qnil);
  120.  
  121.   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
  122. }
  123.  
  124. DEFUN ("debug-classes-being-checked", Fdebug_classes_being_checked,
  125.        Sdebug_classes_being_checked, 0, 0, 0,
  126.        "Return a list of active debug classes.")
  127.      ()
  128. {
  129.   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
  130. }
  131.  
  132. DEFUN ("debug-classes-list", Fdebug_classes_list, Sdebug_classes_list, 0, 0, 0,
  133.        "Return a list of all defined debug classes.")
  134.      ()
  135. {
  136.   return (xemacs_debug_loop (LIST, Qnil, Qnil));
  137. }
  138.  
  139. DEFUN ("set-debug-classes-to-check", Fset_debug_classes_to_check,
  140.        Sset_debug_classes_to_check, 1, 1, 0,
  141.        "Set which classes of debug statements should be active.\n\
  142. CLASSES should be a list of debug classes.")
  143.      (classes)
  144.      Lisp_Object classes;
  145. {
  146.   Lisp_Object rest;
  147.  
  148.   CHECK_LIST (classes, 0);
  149.  
  150.   /* Make sure all objects in the list are valid.  If anyone is not
  151.      valid, reject the entire list without doing anything. */
  152.   LIST_LOOP (rest, classes )
  153.     {
  154.       if (NILP (xemacs_debug_loop (VALIDATE, XCAR (rest), Qnil)))
  155.     error ("Invalid object in class list");
  156.     }
  157.  
  158.   LIST_LOOP (rest, classes)
  159.     Fadd_debug_class_to_check (XCAR (rest));
  160.  
  161.   return (xemacs_debug_loop (ACTIVE, Qnil, Qnil));
  162. }
  163.  
  164. DEFUN ("set-debug-class-types-to-check", Fset_debug_class_types_to_check,
  165.        Sset_debug_class_types_to_check, 2, 2, 0,
  166.        "For the given debug CLASS, set which TYPES are actually interesting.\n\
  167. TYPES should be an integer representing the or'd value of all desired types.\n\
  168. Lists of defined types and their values are located in the source code.")
  169.      (class, type)
  170.      Lisp_Object class, type;
  171. {
  172.   CHECK_INT (type, 0);
  173.   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
  174.     error ("Invalid debug class");
  175.  
  176.   xemacs_debug_loop (SETTYPE, class, type);
  177.  
  178.   return (xemacs_debug_loop (TYPE, class, Qnil));
  179. }
  180.  
  181. DEFUN ("debug-types-being-checked", Fdebug_types_being_checked,
  182.        Sdebug_types_being_checked, 1, 1, 0,
  183.        "For the given CLASS, return the associated type value.")
  184.      (class)
  185.      Lisp_Object class;
  186. {
  187.   if (NILP (xemacs_debug_loop (VALIDATE, class, Qnil)))
  188.     error ("Invalid debug class");
  189.  
  190.   return (xemacs_debug_loop (TYPE, class, Qnil));
  191. }
  192.  
  193. void
  194. syms_of_debug (void)
  195. {
  196.   defsymbol (&Qredisplay, "redisplay");
  197.   defsymbol (&Qbuffers, "buffers");
  198.   defsymbol (&Qextents, "extents");
  199.   defsymbol (&Qfaces, "faces");
  200.   defsymbol (&Qwindows, "windows");
  201.   defsymbol (&Qframes, "frames");
  202.   defsymbol (&Qdevices, "devices");
  203.   /* defsymbol (&Qbytecode, "bytecode"); in bytecode.c */
  204.  
  205.   defsubr (&Sadd_debug_class_to_check);
  206.   defsubr (&Sdelete_debug_class_to_check);
  207.   defsubr (&Sdebug_classes_being_checked);
  208.   defsubr (&Sdebug_classes_list);
  209.   defsubr (&Sset_debug_classes_to_check);
  210.   defsubr (&Sset_debug_class_types_to_check);
  211.   defsubr (&Sdebug_types_being_checked);
  212. }
  213.  
  214. void
  215. vars_of_debug (void)
  216. {
  217.   Fprovide (intern ("debug"));
  218.  
  219.   /* If you need to have any classes active early on in startup, then
  220.      the flags should be set here.
  221.      All functions called by this function are "allowed" according
  222.      to emacs.c. */
  223.   xemacs_debug_loop (INIT, Qnil, Qnil);
  224. }
  225.  
  226.