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