1% Copyright (C) 2012-2017,2018 John E. Davis
2%
3% This file is part of the S-Lang Library and may be distributed under the
4% terms of the GNU General Public License.  See the file COPYING for
5% more information.
6%---------------------------------------------------------------------------
7% This file adds BOS/EOS hooks to the interpreter to help debug stack problems.
8% To use it, put the following at the top of a problematic file:
9%
10%   require ("stkcheck");
11%   enable_stack_check ();
12%
13% To check only portions of a file, surround the suspect functions by:
14%
15%   enable_stack_check ();
16%      .
17%      .
18%   disable_stack_check ();
19%
20_boseos_info = 0;
21private variable Stack = Struct_Type[512];
22private variable Stack_Depth = 0;
23
24private variable Output_Hook = NULL;
25private variable Output_Hook_Args = NULL;
26
27define stkcheck_set_output_hook ()
28{
29   if (_NARGS == 0)
30     {
31	Output_Hook = NULL;
32	Output_Hook_Args = NULL;
33	return;
34     }
35
36   Output_Hook_Args = __pop_list (_NARGS-1);
37   Output_Hook = ();
38}
39
40private define output ()
41{
42   variable args = __pop_list (_NARGS);
43   variable str = sprintf (__push_list (args));
44
45   if (Output_Hook != NULL)
46     return (@Output_Hook)(__push_list (Output_Hook_Args), str);
47
48   () = fprintf (stderr, __push_list (args));
49}
50
51private define bos_handler (file, line)
52{
53   if (Stack_Depth >= length (Stack))
54     throw StackOverflowError, "BOS stack overflow";
55
56   variable s = struct
57     {
58	file, line, depth
59     };
60   s.file = file;
61   s.line = line;
62   s.depth = _stkdepth ();
63   Stack[Stack_Depth] = s;
64   Stack_Depth++;
65}
66
67private define eos_handler ()
68{
69   if (Stack_Depth <= 0)
70     return;
71     %throw StackUnderflowError, "BOS stack depth underflow";
72   Stack_Depth--;
73   variable s = Stack[Stack_Depth];
74   variable depth = _stkdepth ();
75   if (depth != s.depth)
76     {
77	if (depth < s.depth)
78	  ;
79	else
80	  {
81	     output ("%s:%d: %d object(s) left on the stack\n", s.file, s.line, depth-s.depth);
82	     if ((s.file == "***string***") && (Stack_Depth > 0))
83	       {
84		  s = Stack[Stack_Depth-1];
85		  output (" called from %s:%d\n", s.file, s.line);
86	       }
87	  }
88     }
89}
90
91define enable_stack_check ()
92{
93   ()=_set_bos_handler (&bos_handler);
94   ()=_set_eos_handler (&eos_handler);
95   Stack_Depth = 0;
96   _boseos_info = 1;
97}
98
99define disable_stack_check ()
100{
101   ()=_set_bos_handler (NULL);
102   ()=_set_eos_handler (NULL);
103   Stack_Depth = 0;
104   _boseos_info = 0;
105}
106
107#ifexists _jed_version
108private define output_to_buffer (buf, str)
109{
110   variable cbuf = whatbuf ();
111   setbuf (buf);
112   insert (str);
113   setbuf (cbuf);
114}
115if (BATCH == 0) stkcheck_set_output_hook (&output_to_buffer, "*traceback*");
116#endif
117
118provide ("stkcheck");
119