Commit | Line | Data |
---|---|---|
782d171c | 1 | /* Representation of stack frame debug information |
dbb605f5 | 2 | * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008 Free Software Foundation |
782d171c | 3 | * |
73be1d9e MV |
4 | * This library is free software; you can redistribute it and/or |
5 | * modify it under the terms of the GNU Lesser General Public | |
6 | * License as published by the Free Software Foundation; either | |
7 | * version 2.1 of the License, or (at your option) any later version. | |
782d171c | 8 | * |
73be1d9e | 9 | * This library is distributed in the hope that it will be useful, |
782d171c | 10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
12 | * Lesser General Public License for more details. | |
782d171c | 13 | * |
73be1d9e MV |
14 | * You should have received a copy of the GNU Lesser General Public |
15 | * License along with this library; if not, write to the Free Software | |
92205699 | 16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 17 | */ |
1bbd0b84 | 18 | |
1bbd0b84 | 19 | |
782d171c | 20 | \f |
dbb605f5 LC |
21 | #ifdef HAVE_CONFIG_H |
22 | # include <config.h> | |
23 | #endif | |
782d171c | 24 | |
a0599745 MD |
25 | #include "libguile/_scm.h" |
26 | #include "libguile/eval.h" | |
27 | #include "libguile/debug.h" | |
28 | #include "libguile/continuations.h" | |
29 | #include "libguile/struct.h" | |
30 | #include "libguile/macros.h" | |
31 | #include "libguile/procprop.h" | |
32 | #include "libguile/modules.h" | |
33 | #include "libguile/root.h" | |
34 | #include "libguile/strings.h" | |
b1b942b7 AW |
35 | #include "libguile/vm.h" /* to capture vm stacks */ |
36 | #include "libguile/frames.h" /* vm frames */ | |
37 | #include "libguile/instructions.h" /* scm_op_halt */ | |
a0599745 MD |
38 | |
39 | #include "libguile/validate.h" | |
40 | #include "libguile/stacks.h" | |
22fc179a HWN |
41 | #include "libguile/private-options.h" |
42 | ||
782d171c MD |
43 | |
44 | \f | |
45 | /* {Frames and stacks} | |
46 | * | |
47 | * The debugging evaluator creates debug frames on the stack. These | |
48 | * are linked from the innermost frame and outwards. The last frame | |
49 | * created can always be accessed as SCM_LAST_DEBUG_FRAME. | |
50 | * Continuations contain a pointer to the innermost debug frame on the | |
51 | * continuation stack. | |
52 | * | |
53 | * Each debug frame contains a set of flags and information about one | |
54 | * or more stack frames. The case of multiple frames occurs due to | |
55 | * tail recursion. The maximal number of stack frames which can be | |
56 | * recorded in one debug frame can be set dynamically with the debug | |
57 | * option FRAMES. | |
58 | * | |
59 | * Stack frame information is of two types: eval information (the | |
60 | * expression being evaluated and its environment) and apply | |
61 | * information (the procedure being applied and its arguments). A | |
62 | * stack frame normally corresponds to an eval/apply pair, but macros | |
63 | * and special forms (which are implemented as macros in Guile) only | |
64 | * have eval information and apply calls leads to apply only frames. | |
65 | * | |
66 | * Since we want to record the total stack information and later | |
67 | * manipulate this data at the scheme level in the debugger, we need | |
68 | * to transform it into a new representation. In the following code | |
69 | * section you'll find the functions implementing this data type. | |
70 | * | |
71 | * Representation: | |
72 | * | |
7115d1e4 | 73 | * The stack is represented as a struct with an id slot and a tail |
92c2555f | 74 | * array of scm_t_info_frame structs. |
782d171c MD |
75 | * |
76 | * A frame is represented as a pair where the car contains a stack and | |
77 | * the cdr an inum. The inum is an index to the first SCM value of | |
92c2555f | 78 | * the scm_t_info_frame struct. |
782d171c MD |
79 | * |
80 | * Stacks | |
81 | * Constructor | |
82 | * make-stack | |
7115d1e4 MD |
83 | * Selectors |
84 | * stack-id | |
782d171c MD |
85 | * stack-ref |
86 | * Inspector | |
87 | * stack-length | |
88 | * | |
89 | * Frames | |
90 | * Constructor | |
91 | * last-stack-frame | |
92 | * Selectors | |
93 | * frame-number | |
94 | * frame-source | |
95 | * frame-procedure | |
96 | * frame-arguments | |
97 | * frame-previous | |
98 | * frame-next | |
99 | * Predicates | |
100 | * frame-real? | |
101 | * frame-procedure? | |
102 | * frame-evaluating-args? | |
7115d1e4 | 103 | * frame-overflow? */ |
782d171c MD |
104 | |
105 | \f | |
106 | ||
107 | /* Some auxiliary functions for reading debug frames off the stack. | |
108 | */ | |
109 | ||
c0ab1b8d | 110 | /* Stacks often contain pointers to other items on the stack; for |
92c2555f | 111 | example, each scm_t_debug_frame structure contains a pointer to the |
c0ab1b8d JB |
112 | next frame out. When we capture a continuation, we copy the stack |
113 | into the heap, and just leave all the pointers unchanged. This | |
114 | makes it simple to restore the continuation --- just copy the stack | |
115 | back! However, if we retrieve a pointer from the heap copy to | |
116 | another item that was originally on the stack, we have to add an | |
117 | offset to the pointer to discover the new referent. | |
118 | ||
119 | If PTR is a pointer retrieved from a continuation, whose original | |
120 | target was on the stack, and OFFSET is the appropriate offset from | |
121 | the original stack to the continuation, then RELOC_MUMBLE (PTR, | |
122 | OFFSET) is a pointer to the copy in the continuation of the | |
123 | original referent, cast to an scm_debug_MUMBLE *. */ | |
124 | #define RELOC_INFO(ptr, offset) \ | |
92c2555f | 125 | ((scm_t_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset))) |
c0ab1b8d | 126 | #define RELOC_FRAME(ptr, offset) \ |
92c2555f | 127 | ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) |
c0ab1b8d | 128 | |
782d171c MD |
129 | /* Count number of debug info frames on a stack, beginning with |
130 | * DFRAME. OFFSET is used for relocation of pointers when the stack | |
131 | * is read from a continuation. | |
132 | */ | |
b1b942b7 AW |
133 | static long |
134 | stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe, | |
135 | SCM *id) | |
782d171c | 136 | { |
c014a02e | 137 | long n; |
782d171c | 138 | for (n = 0; |
b1b942b7 | 139 | dframe && !SCM_VOIDFRAMEP (*dframe); |
c0ab1b8d | 140 | dframe = RELOC_FRAME (dframe->prev, offset)) |
782d171c MD |
141 | { |
142 | if (SCM_EVALFRAMEP (*dframe)) | |
143 | { | |
7f12a943 MV |
144 | scm_t_debug_info *info = RELOC_INFO (dframe->info, offset); |
145 | scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); | |
146 | n += (info - vect) / 2 + 1; | |
782d171c | 147 | /* Data in the apply part of an eval info frame comes from previous |
92c2555f | 148 | stack frame if the scm_t_debug_info vector is overflowed. */ |
7f12a943 | 149 | if ((((info - vect) & 1) == 0) |
782d171c MD |
150 | && SCM_OVERFLOWP (*dframe) |
151 | && !SCM_UNBNDP (info[1].a.proc)) | |
b1b942b7 | 152 | ++n; |
782d171c | 153 | } |
b1b942b7 AW |
154 | else if (SCM_APPLYFRAMEP (*dframe)) |
155 | { | |
156 | scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); | |
157 | if (SCM_PROGRAM_P (vect[0].a.proc)) | |
158 | { | |
2f9769b6 AW |
159 | if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc)) |
160 | /* Programs can end up in the debug stack via deval; but we just | |
161 | ignore those, because we know that the debugging VM engine | |
162 | pushes one dframe per invocation, with the boot program as | |
163 | the proc, so we only count those. */ | |
164 | continue; | |
3b9e095b | 165 | /* count vmframe back to previous boot frame */ |
b1b942b7 AW |
166 | for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe)) |
167 | { | |
2f9769b6 AW |
168 | if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) |
169 | ++n; | |
170 | else | |
3b9e095b | 171 | { /* skip boot frame, cut out of the vm backtrace */ |
b1b942b7 AW |
172 | vmframe = scm_c_vm_frame_prev (vmframe); |
173 | break; | |
174 | } | |
b1b942b7 AW |
175 | } |
176 | } | |
3b9e095b AW |
177 | else if (scm_is_eq (vect[0].a.proc, scm_f_gsubr_apply)) |
178 | /* Skip gsubr apply frames. */ | |
179 | continue; | |
180 | else | |
181 | ++n; /* increment for non-program apply frame */ | |
b1b942b7 | 182 | } |
782d171c MD |
183 | else |
184 | ++n; | |
185 | } | |
66f45472 | 186 | if (dframe && SCM_VOIDFRAMEP (*dframe)) |
7f12a943 | 187 | *id = RELOC_INFO(dframe->vect, offset)[0].id; |
782d171c MD |
188 | return n; |
189 | } | |
190 | ||
191 | /* Read debug info from DFRAME into IFRAME. | |
192 | */ | |
782d171c | 193 | static void |
7f12a943 MV |
194 | read_frame (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, |
195 | scm_t_info_frame *iframe) | |
782d171c | 196 | { |
92c2555f | 197 | scm_t_bits flags = SCM_UNPACK (SCM_INUM0); /* UGh. */ |
782d171c MD |
198 | if (SCM_EVALFRAMEP (*dframe)) |
199 | { | |
7f12a943 MV |
200 | scm_t_debug_info *info = RELOC_INFO (dframe->info, offset); |
201 | scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); | |
202 | if ((info - vect) & 1) | |
782d171c MD |
203 | { |
204 | /* Debug.vect ends with apply info. */ | |
205 | --info; | |
54778cd3 | 206 | if (!SCM_UNBNDP (info[1].a.proc)) |
782d171c MD |
207 | { |
208 | flags |= SCM_FRAMEF_PROC; | |
209 | iframe->proc = info[1].a.proc; | |
210 | iframe->args = info[1].a.args; | |
211 | if (!SCM_ARGS_READY_P (*dframe)) | |
212 | flags |= SCM_FRAMEF_EVAL_ARGS; | |
213 | } | |
214 | } | |
6629eb1c | 215 | iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env); |
782d171c MD |
216 | } |
217 | else | |
218 | { | |
7f12a943 | 219 | scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); |
782d171c | 220 | flags |= SCM_FRAMEF_PROC; |
7f12a943 MV |
221 | iframe->proc = vect[0].a.proc; |
222 | iframe->args = vect[0].a.args; | |
782d171c MD |
223 | } |
224 | iframe->flags = flags; | |
225 | } | |
226 | ||
7a13c3ae MD |
227 | /* Look up the first body form of the apply closure. We'll use this |
228 | below to prevent it from being displayed. | |
229 | */ | |
230 | static SCM | |
231 | get_applybody () | |
232 | { | |
86d31dfe MV |
233 | SCM var = scm_sym2var (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F); |
234 | if (SCM_VARIABLEP (var) && SCM_CLOSUREP (SCM_VARIABLE_REF (var))) | |
f9450cdb | 235 | return SCM_CAR (SCM_CLOSURE_BODY (SCM_VARIABLE_REF (var))); |
7a13c3ae MD |
236 | else |
237 | return SCM_UNDEFINED; | |
238 | } | |
7115d1e4 MD |
239 | |
240 | #define NEXT_FRAME(iframe, n, quit) \ | |
d3a6bc94 | 241 | do { \ |
13dcb666 | 242 | if (SCM_MEMOIZEDP (iframe->source) \ |
bc36d050 | 243 | && scm_is_eq (SCM_MEMOIZED_EXP (iframe->source), applybody)) \ |
7a13c3ae MD |
244 | { \ |
245 | iframe->source = SCM_BOOL_F; \ | |
7888309b | 246 | if (scm_is_false (iframe->proc)) \ |
7a13c3ae MD |
247 | { \ |
248 | --iframe; \ | |
249 | ++n; \ | |
250 | } \ | |
251 | } \ | |
7115d1e4 MD |
252 | ++iframe; \ |
253 | if (--n == 0) \ | |
254 | goto quit; \ | |
d3a6bc94 | 255 | } while (0) |
7115d1e4 MD |
256 | |
257 | ||
92c2555f | 258 | /* Fill the scm_t_info_frame vector IFRAME with data from N stack frames |
7a13c3ae MD |
259 | * starting with the first stack frame represented by debug frame |
260 | * DFRAME. | |
261 | */ | |
262 | ||
92c2555f | 263 | static scm_t_bits |
7f12a943 | 264 | read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, |
b1b942b7 | 265 | SCM vmframe, long n, scm_t_info_frame *iframes) |
782d171c | 266 | { |
92c2555f | 267 | scm_t_info_frame *iframe = iframes; |
7f12a943 | 268 | scm_t_debug_info *info, *vect; |
7a13c3ae | 269 | static SCM applybody = SCM_UNDEFINED; |
782d171c | 270 | |
7a13c3ae MD |
271 | /* The value of applybody has to be setup after r4rs.scm has executed. */ |
272 | if (SCM_UNBNDP (applybody)) | |
273 | applybody = get_applybody (); | |
782d171c | 274 | for (; |
66f45472 | 275 | dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0; |
c0ab1b8d | 276 | dframe = RELOC_FRAME (dframe->prev, offset)) |
782d171c MD |
277 | { |
278 | read_frame (dframe, offset, iframe); | |
279 | if (SCM_EVALFRAMEP (*dframe)) | |
280 | { | |
6629eb1c MD |
281 | /* If current frame is a macro during expansion, we should |
282 | skip the previously recorded macro transformer | |
283 | application frame. */ | |
284 | if (SCM_MACROEXPP (*dframe) && iframe > iframes) | |
7c939801 MD |
285 | { |
286 | *(iframe - 1) = *iframe; | |
287 | --iframe; | |
288 | } | |
c0ab1b8d | 289 | info = RELOC_INFO (dframe->info, offset); |
7f12a943 MV |
290 | vect = RELOC_INFO (dframe->vect, offset); |
291 | if ((info - vect) & 1) | |
782d171c MD |
292 | --info; |
293 | /* Data in the apply part of an eval info frame comes from | |
13dcb666 DH |
294 | previous stack frame if the scm_t_debug_info vector is |
295 | overflowed. */ | |
782d171c MD |
296 | else if (SCM_OVERFLOWP (*dframe) |
297 | && !SCM_UNBNDP (info[1].a.proc)) | |
298 | { | |
7115d1e4 | 299 | NEXT_FRAME (iframe, n, quit); |
f1267706 | 300 | iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC; |
782d171c MD |
301 | iframe->proc = info[1].a.proc; |
302 | iframe->args = info[1].a.args; | |
303 | } | |
304 | if (SCM_OVERFLOWP (*dframe)) | |
305 | iframe->flags |= SCM_FRAMEF_OVERFLOW; | |
306 | info -= 2; | |
7115d1e4 | 307 | NEXT_FRAME (iframe, n, quit); |
7f12a943 | 308 | while (info >= vect) |
782d171c MD |
309 | { |
310 | if (!SCM_UNBNDP (info[1].a.proc)) | |
311 | { | |
f1267706 | 312 | iframe->flags = SCM_UNPACK(SCM_INUM0) | SCM_FRAMEF_PROC; |
782d171c MD |
313 | iframe->proc = info[1].a.proc; |
314 | iframe->args = info[1].a.args; | |
315 | } | |
316 | else | |
f1267706 | 317 | iframe->flags = SCM_UNPACK (SCM_INUM0); |
782d171c MD |
318 | iframe->source = scm_make_memoized (info[0].e.exp, |
319 | info[0].e.env); | |
320 | info -= 2; | |
7115d1e4 | 321 | NEXT_FRAME (iframe, n, quit); |
782d171c MD |
322 | } |
323 | } | |
bc36d050 | 324 | else if (scm_is_eq (iframe->proc, scm_f_gsubr_apply)) |
7c939801 MD |
325 | /* Skip gsubr apply frames. */ |
326 | continue; | |
3b9e095b AW |
327 | else if (SCM_PROGRAM_P (iframe->proc)) |
328 | { | |
2f9769b6 AW |
329 | if (!SCM_PROGRAM_IS_BOOT (iframe->proc)) |
330 | /* Programs can end up in the debug stack via deval; but we just | |
331 | ignore those, because we know that the debugging VM engine | |
332 | pushes one dframe per invocation, with the boot program as | |
333 | the proc, so we only count those. */ | |
334 | continue; | |
3b9e095b AW |
335 | for (; scm_is_true (vmframe); |
336 | vmframe = scm_c_vm_frame_prev (vmframe)) | |
b1b942b7 | 337 | { |
3b9e095b AW |
338 | if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) |
339 | { /* skip boot frame, back to interpreted frames */ | |
340 | vmframe = scm_c_vm_frame_prev (vmframe); | |
341 | break; | |
342 | } | |
343 | else | |
b1b942b7 | 344 | { |
3b9e095b AW |
345 | /* Oh dear, oh dear, oh dear. */ |
346 | iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC; | |
347 | iframe->source = scm_vm_frame_source (vmframe); | |
348 | iframe->proc = scm_vm_frame_program (vmframe); | |
349 | iframe->args = scm_vm_frame_arguments (vmframe); | |
350 | ++iframe; | |
351 | if (--n == 0) | |
352 | goto quit; | |
b1b942b7 | 353 | } |
3b9e095b | 354 | } |
3b9e095b AW |
355 | } |
356 | else | |
357 | { | |
358 | NEXT_FRAME (iframe, n, quit); | |
359 | } | |
782d171c MD |
360 | quit: |
361 | if (iframe > iframes) | |
362 | (iframe - 1) -> flags |= SCM_FRAMEF_REAL; | |
363 | } | |
7c939801 | 364 | return iframe - iframes; /* Number of frames actually read */ |
782d171c MD |
365 | } |
366 | ||
c3a6c6f9 MD |
367 | /* Narrow STACK by cutting away stackframes (mutatingly). |
368 | * | |
369 | * Inner frames (most recent) are cut by advancing the frames pointer. | |
370 | * Outer frames are cut by decreasing the recorded length. | |
371 | * | |
372 | * Cut maximally INNER inner frames and OUTER outer frames using | |
373 | * the keys INNER_KEY and OUTER_KEY. | |
374 | * | |
375 | * Frames are cut away starting at the end points and moving towards | |
376 | * the center of the stack. The key is normally compared to the | |
377 | * operator in application frames. Frames up to and including the key | |
378 | * are cut. | |
379 | * | |
380 | * If INNER_KEY is #t a different scheme is used for inner frames: | |
381 | * | |
382 | * Frames up to but excluding the first source frame originating from | |
383 | * a user module are cut, except for possible application frames | |
384 | * between the user frame and the last system frame previously | |
385 | * encountered. | |
386 | */ | |
387 | ||
7115d1e4 | 388 | static void |
34d19ef6 | 389 | narrow_stack (SCM stack, long inner, SCM inner_key, long outer, SCM outer_key) |
7115d1e4 | 390 | { |
92c2555f | 391 | scm_t_stack *s = SCM_STACK (stack); |
13dcb666 | 392 | unsigned long int i; |
c014a02e | 393 | long n = s->length; |
7115d1e4 MD |
394 | |
395 | /* Cut inner part. */ | |
bc36d050 | 396 | if (scm_is_eq (inner_key, SCM_BOOL_T)) |
c3a6c6f9 | 397 | { |
13dcb666 | 398 | /* Cut all frames up to user module code */ |
c3a6c6f9 MD |
399 | for (i = 0; inner; ++i, --inner) |
400 | { | |
401 | SCM m = s->frames[i].source; | |
13dcb666 DH |
402 | if (SCM_MEMOIZEDP (m) |
403 | && !SCM_IMP (SCM_MEMOIZED_ENV (m)) | |
7888309b | 404 | && scm_is_false (scm_system_module_env_p (SCM_MEMOIZED_ENV (m)))) |
c3a6c6f9 MD |
405 | { |
406 | /* Back up in order to include any non-source frames */ | |
13dcb666 | 407 | while (i > 0) |
c3a6c6f9 | 408 | { |
13dcb666 DH |
409 | m = s->frames[i - 1].source; |
410 | if (SCM_MEMOIZEDP (m)) | |
411 | break; | |
412 | ||
413 | m = s->frames[i - 1].proc; | |
7888309b MV |
414 | if (scm_is_true (scm_procedure_p (m)) |
415 | && scm_is_true (scm_procedure_property | |
13dcb666 DH |
416 | (m, scm_sym_system_procedure))) |
417 | break; | |
418 | ||
c3a6c6f9 MD |
419 | --i; |
420 | ++inner; | |
421 | } | |
422 | break; | |
423 | } | |
424 | } | |
425 | } | |
426 | else | |
427 | /* Use standard cutting procedure. */ | |
428 | { | |
429 | for (i = 0; inner; --inner) | |
bc36d050 | 430 | if (scm_is_eq (s->frames[i++].proc, inner_key)) |
c3a6c6f9 MD |
431 | break; |
432 | } | |
7115d1e4 MD |
433 | s->frames = &s->frames[i]; |
434 | n -= i; | |
435 | ||
436 | /* Cut outer part. */ | |
437 | for (; n && outer; --outer) | |
bc36d050 | 438 | if (scm_is_eq (s->frames[--n].proc, outer_key)) |
7115d1e4 MD |
439 | break; |
440 | ||
441 | s->length = n; | |
442 | } | |
443 | ||
782d171c MD |
444 | \f |
445 | ||
446 | /* Stacks | |
447 | */ | |
448 | ||
762e289a | 449 | SCM scm_stack_type; |
66f45472 | 450 | |
a1ec6916 | 451 | SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0, |
1bbd0b84 | 452 | (SCM obj), |
b380b885 | 453 | "Return @code{#t} if @var{obj} is a calling stack.") |
1bbd0b84 | 454 | #define FUNC_NAME s_scm_stack_p |
66f45472 | 455 | { |
7888309b | 456 | return scm_from_bool(SCM_STACKP (obj)); |
66f45472 | 457 | } |
1bbd0b84 | 458 | #undef FUNC_NAME |
66f45472 | 459 | |
af45e3b0 DH |
460 | SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, |
461 | (SCM obj, SCM args), | |
67941e3c MG |
462 | "Create a new stack. If @var{obj} is @code{#t}, the current\n" |
463 | "evaluation stack is used for creating the stack frames,\n" | |
464 | "otherwise the frames are taken from @var{obj} (which must be\n" | |
baffb19f NJ |
465 | "either a debug object or a continuation).\n\n" |
466 | "@var{args} should be a list containing any combination of\n" | |
467 | "integer, procedure and @code{#t} values.\n\n" | |
468 | "These values specify various ways of cutting away uninteresting\n" | |
469 | "stack frames from the top and bottom of the stack that\n" | |
470 | "@code{make-stack} returns. They come in pairs like this:\n" | |
471 | "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n" | |
472 | "@var{outer_cut_2} @dots{})}.\n\n" | |
473 | "Each @var{inner_cut_N} can be @code{#t}, an integer, or a\n" | |
474 | "procedure. @code{#t} means to cut away all frames up to but\n" | |
475 | "excluding the first user module frame. An integer means to cut\n" | |
476 | "away exactly that number of frames. A procedure means to cut\n" | |
477 | "away all frames up to but excluding the application frame whose\n" | |
478 | "procedure matches the specified one.\n\n" | |
479 | "Each @var{outer_cut_N} can be an integer or a procedure. An\n" | |
480 | "integer means to cut away that number of frames. A procedure\n" | |
481 | "means to cut away frames down to but excluding the application\n" | |
482 | "frame whose procedure matches the specified one.\n\n" | |
483 | "If the @var{outer_cut_N} of the last pair is missing, it is\n" | |
484 | "taken as 0.") | |
1bbd0b84 | 485 | #define FUNC_NAME s_scm_make_stack |
782d171c | 486 | { |
c014a02e | 487 | long n, size; |
1be6b49c | 488 | int maxp; |
13dcb666 | 489 | scm_t_debug_frame *dframe; |
92c2555f | 490 | scm_t_info_frame *iframe; |
b1b942b7 | 491 | SCM vmframe; |
c014a02e | 492 | long offset = 0; |
66f45472 | 493 | SCM stack, id; |
af45e3b0 | 494 | SCM inner_cut, outer_cut; |
f6f88e0d MD |
495 | |
496 | /* Extract a pointer to the innermost frame of whatever object | |
497 | scm_make_stack was given. */ | |
bc36d050 | 498 | if (scm_is_eq (obj, SCM_BOOL_T)) |
782d171c | 499 | { |
b1b942b7 | 500 | struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); |
9de87eea | 501 | dframe = scm_i_last_debug_frame (); |
b1b942b7 | 502 | vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); |
13dcb666 DH |
503 | } |
504 | else if (SCM_DEBUGOBJP (obj)) | |
505 | { | |
506 | dframe = SCM_DEBUGOBJ_FRAME (obj); | |
b1b942b7 AW |
507 | vmframe = SCM_BOOL_F; |
508 | } | |
509 | else if (SCM_VM_FRAME_P (obj)) | |
510 | { | |
511 | dframe = NULL; | |
512 | vmframe = obj; | |
13dcb666 DH |
513 | } |
514 | else if (SCM_CONTINUATIONP (obj)) | |
515 | { | |
7f12a943 MV |
516 | scm_t_contregs *cont = SCM_CONTREGS (obj); |
517 | offset = cont->offset; | |
518 | dframe = RELOC_FRAME (cont->dframe, offset); | |
b1b942b7 AW |
519 | if (!scm_is_null (cont->vm_conts)) |
520 | { SCM vm_cont; | |
521 | struct scm_vm_cont *data; | |
522 | vm_cont = scm_cdr (scm_car (cont->vm_conts)); | |
523 | data = SCM_VM_CONT_DATA (vm_cont); | |
524 | vmframe = scm_c_make_vm_frame (vm_cont, | |
7aa6f86b AW |
525 | data->fp + data->reloc, |
526 | data->sp + data->reloc, | |
b1b942b7 AW |
527 | data->ip, |
528 | data->reloc); | |
529 | } else | |
530 | vmframe = SCM_BOOL_F; | |
13dcb666 DH |
531 | } |
532 | else | |
533 | { | |
534 | SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); | |
535 | /* not reached */ | |
782d171c MD |
536 | } |
537 | ||
f6f88e0d MD |
538 | /* Count number of frames. Also get stack id tag and check whether |
539 | there are more stackframes than we want to record | |
540 | (SCM_BACKTRACE_MAXDEPTH). */ | |
66f45472 MD |
541 | id = SCM_BOOL_F; |
542 | maxp = 0; | |
b1b942b7 AW |
543 | n = stack_depth (dframe, offset, vmframe, &id); |
544 | /* FIXME: redo maxp? */ | |
782d171c MD |
545 | size = n * SCM_FRAME_N_SLOTS; |
546 | ||
f6f88e0d | 547 | /* Make the stack object. */ |
e11e83f3 | 548 | stack = scm_make_struct (scm_stack_type, scm_from_long (size), SCM_EOL); |
66f45472 | 549 | SCM_STACK (stack) -> id = id; |
7115d1e4 MD |
550 | iframe = &SCM_STACK (stack) -> tail[0]; |
551 | SCM_STACK (stack) -> frames = iframe; | |
3b9e095b | 552 | SCM_STACK (stack) -> length = n; |
7115d1e4 | 553 | |
f6f88e0d | 554 | /* Translate the current chain of stack frames into debugging information. */ |
98922879 AW |
555 | n = read_frames (dframe, offset, vmframe, n, iframe); |
556 | if (n != SCM_STACK (stack)->length) | |
557 | { | |
558 | scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ()); | |
559 | SCM_STACK (stack)->length = n; | |
560 | } | |
7115d1e4 | 561 | |
f6f88e0d | 562 | /* Narrow the stack according to the arguments given to scm_make_stack. */ |
af45e3b0 | 563 | SCM_VALIDATE_REST_ARGUMENT (args); |
d2e53ed6 | 564 | while (n > 0 && !scm_is_null (args)) |
f6f88e0d MD |
565 | { |
566 | inner_cut = SCM_CAR (args); | |
567 | args = SCM_CDR (args); | |
d2e53ed6 | 568 | if (scm_is_null (args)) |
af45e3b0 | 569 | { |
13dcb666 | 570 | outer_cut = SCM_INUM0; |
af45e3b0 DH |
571 | } |
572 | else | |
f6f88e0d MD |
573 | { |
574 | outer_cut = SCM_CAR (args); | |
575 | args = SCM_CDR (args); | |
576 | } | |
f6f88e0d MD |
577 | |
578 | narrow_stack (stack, | |
e11e83f3 MV |
579 | scm_is_integer (inner_cut) ? scm_to_int (inner_cut) : n, |
580 | scm_is_integer (inner_cut) ? 0 : inner_cut, | |
581 | scm_is_integer (outer_cut) ? scm_to_int (outer_cut) : n, | |
582 | scm_is_integer (outer_cut) ? 0 : outer_cut); | |
f6f88e0d MD |
583 | |
584 | n = SCM_STACK (stack) -> length; | |
585 | } | |
586 | ||
b1b942b7 AW |
587 | if (n > 0 && maxp) |
588 | iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; | |
589 | ||
7115d1e4 | 590 | if (n > 0) |
b1b942b7 | 591 | return stack; |
7115d1e4 MD |
592 | else |
593 | return SCM_BOOL_F; | |
782d171c | 594 | } |
1bbd0b84 | 595 | #undef FUNC_NAME |
782d171c | 596 | |
a1ec6916 | 597 | SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, |
1bbd0b84 | 598 | (SCM stack), |
b380b885 | 599 | "Return the identifier given to @var{stack} by @code{start-stack}.") |
1bbd0b84 | 600 | #define FUNC_NAME s_scm_stack_id |
66f45472 | 601 | { |
92c2555f | 602 | scm_t_debug_frame *dframe; |
c014a02e | 603 | long offset = 0; |
bc36d050 | 604 | if (scm_is_eq (stack, SCM_BOOL_T)) |
7115d1e4 | 605 | { |
9de87eea | 606 | dframe = scm_i_last_debug_frame (); |
13dcb666 DH |
607 | } |
608 | else if (SCM_DEBUGOBJP (stack)) | |
609 | { | |
610 | dframe = SCM_DEBUGOBJ_FRAME (stack); | |
611 | } | |
612 | else if (SCM_CONTINUATIONP (stack)) | |
613 | { | |
7f12a943 MV |
614 | scm_t_contregs *cont = SCM_CONTREGS (stack); |
615 | offset = cont->offset; | |
616 | dframe = RELOC_FRAME (cont->dframe, offset); | |
13dcb666 DH |
617 | } |
618 | else if (SCM_STACKP (stack)) | |
619 | { | |
620 | return SCM_STACK (stack) -> id; | |
7115d1e4 | 621 | } |
13dcb666 DH |
622 | else |
623 | { | |
624 | SCM_WRONG_TYPE_ARG (1, stack); | |
625 | } | |
626 | ||
7115d1e4 | 627 | while (dframe && !SCM_VOIDFRAMEP (*dframe)) |
c0ab1b8d | 628 | dframe = RELOC_FRAME (dframe->prev, offset); |
7115d1e4 | 629 | if (dframe && SCM_VOIDFRAMEP (*dframe)) |
7f12a943 | 630 | return RELOC_INFO (dframe->vect, offset)[0].id; |
7115d1e4 | 631 | return SCM_BOOL_F; |
66f45472 | 632 | } |
1bbd0b84 | 633 | #undef FUNC_NAME |
66f45472 | 634 | |
a1ec6916 | 635 | SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, |
13dcb666 DH |
636 | (SCM stack, SCM index), |
637 | "Return the @var{index}'th frame from @var{stack}.") | |
1bbd0b84 | 638 | #define FUNC_NAME s_scm_stack_ref |
782d171c | 639 | { |
13dcb666 DH |
640 | unsigned long int c_index; |
641 | ||
642 | SCM_VALIDATE_STACK (1, stack); | |
a55c2b68 | 643 | c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1); |
13dcb666 | 644 | return scm_cons (stack, index); |
782d171c | 645 | } |
1bbd0b84 | 646 | #undef FUNC_NAME |
782d171c | 647 | |
3b3b36dd | 648 | SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, |
67941e3c MG |
649 | (SCM stack), |
650 | "Return the length of @var{stack}.") | |
1bbd0b84 | 651 | #define FUNC_NAME s_scm_stack_length |
782d171c | 652 | { |
34d19ef6 | 653 | SCM_VALIDATE_STACK (1, stack); |
e11e83f3 | 654 | return scm_from_int (SCM_STACK_LENGTH (stack)); |
782d171c | 655 | } |
1bbd0b84 | 656 | #undef FUNC_NAME |
782d171c MD |
657 | |
658 | /* Frames | |
659 | */ | |
660 | ||
a1ec6916 | 661 | SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, |
1bbd0b84 | 662 | (SCM obj), |
67941e3c | 663 | "Return @code{#t} if @var{obj} is a stack frame.") |
1bbd0b84 | 664 | #define FUNC_NAME s_scm_frame_p |
66f45472 | 665 | { |
7888309b | 666 | return scm_from_bool(SCM_FRAMEP (obj)); |
66f45472 | 667 | } |
1bbd0b84 | 668 | #undef FUNC_NAME |
66f45472 | 669 | |
3b3b36dd | 670 | SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, |
67941e3c | 671 | (SCM obj), |
b0b0deff NJ |
672 | "Return the last (innermost) frame of @var{obj}, which must be\n" |
673 | "either a debug object or a continuation.") | |
1bbd0b84 | 674 | #define FUNC_NAME s_scm_last_stack_frame |
782d171c | 675 | { |
92c2555f | 676 | scm_t_debug_frame *dframe; |
c014a02e | 677 | long offset = 0; |
7115d1e4 | 678 | SCM stack; |
782d171c | 679 | |
782d171c | 680 | if (SCM_DEBUGOBJP (obj)) |
13dcb666 DH |
681 | { |
682 | dframe = SCM_DEBUGOBJ_FRAME (obj); | |
683 | } | |
5f144b10 | 684 | else if (SCM_CONTINUATIONP (obj)) |
782d171c | 685 | { |
7f12a943 MV |
686 | scm_t_contregs *cont = SCM_CONTREGS (obj); |
687 | offset = cont->offset; | |
688 | dframe = RELOC_FRAME (cont->dframe, offset); | |
782d171c | 689 | } |
3323ad08 JB |
690 | else |
691 | { | |
276dd677 DH |
692 | SCM_WRONG_TYPE_ARG (1, obj); |
693 | /* not reached */ | |
3323ad08 | 694 | } |
782d171c | 695 | |
66f45472 | 696 | if (!dframe || SCM_VOIDFRAMEP (*dframe)) |
782d171c MD |
697 | return SCM_BOOL_F; |
698 | ||
e11e83f3 | 699 | stack = scm_make_struct (scm_stack_type, scm_from_int (SCM_FRAME_N_SLOTS), |
c0ab1b8d | 700 | SCM_EOL); |
7115d1e4 MD |
701 | SCM_STACK (stack) -> length = 1; |
702 | SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; | |
c0ab1b8d | 703 | read_frame (dframe, offset, |
92c2555f | 704 | (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]); |
782d171c | 705 | |
13dcb666 | 706 | return scm_cons (stack, SCM_INUM0); |
782d171c | 707 | } |
1bbd0b84 | 708 | #undef FUNC_NAME |
782d171c | 709 | |
3b3b36dd | 710 | SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, |
67941e3c MG |
711 | (SCM frame), |
712 | "Return the frame number of @var{frame}.") | |
1bbd0b84 | 713 | #define FUNC_NAME s_scm_frame_number |
782d171c | 714 | { |
34d19ef6 | 715 | SCM_VALIDATE_FRAME (1, frame); |
e11e83f3 | 716 | return scm_from_int (SCM_FRAME_NUMBER (frame)); |
782d171c | 717 | } |
1bbd0b84 | 718 | #undef FUNC_NAME |
782d171c | 719 | |
3b3b36dd | 720 | SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, |
67941e3c MG |
721 | (SCM frame), |
722 | "Return the source of @var{frame}.") | |
1bbd0b84 | 723 | #define FUNC_NAME s_scm_frame_source |
782d171c | 724 | { |
34d19ef6 | 725 | SCM_VALIDATE_FRAME (1, frame); |
782d171c MD |
726 | return SCM_FRAME_SOURCE (frame); |
727 | } | |
1bbd0b84 | 728 | #undef FUNC_NAME |
782d171c | 729 | |
3b3b36dd | 730 | SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, |
67941e3c MG |
731 | (SCM frame), |
732 | "Return the procedure for @var{frame}, or @code{#f} if no\n" | |
733 | "procedure is associated with @var{frame}.") | |
1bbd0b84 | 734 | #define FUNC_NAME s_scm_frame_procedure |
782d171c | 735 | { |
34d19ef6 | 736 | SCM_VALIDATE_FRAME (1, frame); |
782d171c | 737 | return (SCM_FRAME_PROC_P (frame) |
afa92d19 TP |
738 | ? SCM_FRAME_PROC (frame) |
739 | : SCM_BOOL_F); | |
782d171c | 740 | } |
1bbd0b84 | 741 | #undef FUNC_NAME |
782d171c | 742 | |
3b3b36dd | 743 | SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, |
67941e3c MG |
744 | (SCM frame), |
745 | "Return the arguments of @var{frame}.") | |
1bbd0b84 | 746 | #define FUNC_NAME s_scm_frame_arguments |
782d171c | 747 | { |
34d19ef6 | 748 | SCM_VALIDATE_FRAME (1, frame); |
782d171c MD |
749 | return SCM_FRAME_ARGS (frame); |
750 | } | |
1bbd0b84 | 751 | #undef FUNC_NAME |
782d171c | 752 | |
3b3b36dd | 753 | SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, |
67941e3c MG |
754 | (SCM frame), |
755 | "Return the previous frame of @var{frame}, or @code{#f} if\n" | |
756 | "@var{frame} is the first frame in its stack.") | |
1bbd0b84 | 757 | #define FUNC_NAME s_scm_frame_previous |
782d171c | 758 | { |
13dcb666 DH |
759 | unsigned long int n; |
760 | SCM_VALIDATE_FRAME (1, frame); | |
e11e83f3 | 761 | n = scm_to_ulong (SCM_CDR (frame)) + 1; |
782d171c MD |
762 | if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) |
763 | return SCM_BOOL_F; | |
764 | else | |
e11e83f3 | 765 | return scm_cons (SCM_CAR (frame), scm_from_ulong (n)); |
782d171c | 766 | } |
1bbd0b84 | 767 | #undef FUNC_NAME |
782d171c | 768 | |
3b3b36dd | 769 | SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, |
1bbd0b84 | 770 | (SCM frame), |
67941e3c MG |
771 | "Return the next frame of @var{frame}, or @code{#f} if\n" |
772 | "@var{frame} is the last frame in its stack.") | |
1bbd0b84 | 773 | #define FUNC_NAME s_scm_frame_next |
782d171c | 774 | { |
13dcb666 DH |
775 | unsigned long int n; |
776 | SCM_VALIDATE_FRAME (1, frame); | |
e11e83f3 | 777 | n = scm_to_ulong (SCM_CDR (frame)); |
13dcb666 | 778 | if (n == 0) |
782d171c MD |
779 | return SCM_BOOL_F; |
780 | else | |
e11e83f3 | 781 | return scm_cons (SCM_CAR (frame), scm_from_ulong (n - 1)); |
782d171c | 782 | } |
1bbd0b84 | 783 | #undef FUNC_NAME |
782d171c | 784 | |
3b3b36dd | 785 | SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0, |
67941e3c MG |
786 | (SCM frame), |
787 | "Return @code{#t} if @var{frame} is a real frame.") | |
1bbd0b84 | 788 | #define FUNC_NAME s_scm_frame_real_p |
782d171c | 789 | { |
34d19ef6 | 790 | SCM_VALIDATE_FRAME (1, frame); |
7888309b | 791 | return scm_from_bool(SCM_FRAME_REAL_P (frame)); |
782d171c | 792 | } |
1bbd0b84 | 793 | #undef FUNC_NAME |
782d171c | 794 | |
3b3b36dd | 795 | SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0, |
67941e3c MG |
796 | (SCM frame), |
797 | "Return @code{#t} if a procedure is associated with @var{frame}.") | |
1bbd0b84 | 798 | #define FUNC_NAME s_scm_frame_procedure_p |
782d171c | 799 | { |
34d19ef6 | 800 | SCM_VALIDATE_FRAME (1, frame); |
7888309b | 801 | return scm_from_bool(SCM_FRAME_PROC_P (frame)); |
782d171c | 802 | } |
1bbd0b84 | 803 | #undef FUNC_NAME |
782d171c | 804 | |
3b3b36dd | 805 | SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, |
67941e3c MG |
806 | (SCM frame), |
807 | "Return @code{#t} if @var{frame} contains evaluated arguments.") | |
1bbd0b84 | 808 | #define FUNC_NAME s_scm_frame_evaluating_args_p |
782d171c | 809 | { |
34d19ef6 | 810 | SCM_VALIDATE_FRAME (1, frame); |
7888309b | 811 | return scm_from_bool(SCM_FRAME_EVAL_ARGS_P (frame)); |
782d171c | 812 | } |
1bbd0b84 | 813 | #undef FUNC_NAME |
782d171c | 814 | |
3b3b36dd | 815 | SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, |
67941e3c MG |
816 | (SCM frame), |
817 | "Return @code{#t} if @var{frame} is an overflow frame.") | |
1bbd0b84 | 818 | #define FUNC_NAME s_scm_frame_overflow_p |
782d171c | 819 | { |
34d19ef6 | 820 | SCM_VALIDATE_FRAME (1, frame); |
7888309b | 821 | return scm_from_bool(SCM_FRAME_OVERFLOW_P (frame)); |
782d171c | 822 | } |
1bbd0b84 | 823 | #undef FUNC_NAME |
782d171c MD |
824 | |
825 | \f | |
826 | ||
827 | void | |
828 | scm_init_stacks () | |
829 | { | |
b3aa4626 KR |
830 | scm_stack_type = |
831 | scm_permanent_object | |
832 | (scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT), | |
833 | SCM_UNDEFINED)); | |
cc95e00a MV |
834 | scm_set_struct_vtable_name_x (scm_stack_type, |
835 | scm_from_locale_symbol ("stack")); | |
a0599745 | 836 | #include "libguile/stacks.x" |
782d171c | 837 | } |
89e00824 ML |
838 | |
839 | /* | |
840 | Local Variables: | |
841 | c-file-style: "gnu" | |
842 | End: | |
843 | */ |