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) \ |
54778cd3 | 205 | && SCM_EQ_P (SCM_MEMOIZED_EXP (iframe->source), applybody)) \ |
7a13c3ae MD |
206 | { \ |
207 | iframe->source = SCM_BOOL_F; \ | |
208 | if (SCM_FALSEP (iframe->proc)) \ | |
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 | } | |
54778cd3 | 284 | else if (SCM_EQ_P (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. */ | |
9a09deb1 | 327 | if (SCM_EQ_P (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)) | |
9bba1435 | 335 | && SCM_FALSEP (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; | |
345 | if (!SCM_FALSEP (scm_procedure_p (m)) | |
346 | && !SCM_FALSEP (scm_procedure_property | |
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) | |
fee7ef83 | 361 | if (SCM_EQ_P (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) | |
fee7ef83 | 369 | if (SCM_EQ_P (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 | { |
0c95b57d | 387 | return SCM_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. */ | |
13dcb666 | 428 | if (SCM_EQ_P (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. */ |
762e289a | 460 | stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (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, | |
486 | SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n, | |
487 | SCM_INUMP (inner_cut) ? 0 : inner_cut, | |
488 | SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n, | |
489 | SCM_INUMP (outer_cut) ? 0 : outer_cut); | |
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; |
9a09deb1 | 512 | if (SCM_EQ_P (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); | |
554 | SCM_VALIDATE_INUM (2, index); | |
555 | SCM_ASSERT_RANGE (1, index, SCM_INUM (index) >= 0); | |
556 | c_index = SCM_INUM (index); | |
557 | SCM_ASSERT_RANGE (1, index, c_index < SCM_STACK_LENGTH (stack)); | |
558 | return scm_cons (stack, index); | |
782d171c | 559 | } |
1bbd0b84 | 560 | #undef FUNC_NAME |
782d171c | 561 | |
3b3b36dd | 562 | SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, |
67941e3c MG |
563 | (SCM stack), |
564 | "Return the length of @var{stack}.") | |
1bbd0b84 | 565 | #define FUNC_NAME s_scm_stack_length |
782d171c | 566 | { |
34d19ef6 | 567 | SCM_VALIDATE_STACK (1, stack); |
782d171c MD |
568 | return SCM_MAKINUM (SCM_STACK_LENGTH (stack)); |
569 | } | |
1bbd0b84 | 570 | #undef FUNC_NAME |
782d171c MD |
571 | |
572 | /* Frames | |
573 | */ | |
574 | ||
a1ec6916 | 575 | SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, |
1bbd0b84 | 576 | (SCM obj), |
67941e3c | 577 | "Return @code{#t} if @var{obj} is a stack frame.") |
1bbd0b84 | 578 | #define FUNC_NAME s_scm_frame_p |
66f45472 | 579 | { |
0c95b57d | 580 | return SCM_BOOL(SCM_FRAMEP (obj)); |
66f45472 | 581 | } |
1bbd0b84 | 582 | #undef FUNC_NAME |
66f45472 | 583 | |
3b3b36dd | 584 | SCM_DEFINE (scm_last_stack_frame, "last-stack-frame", 1, 0, 0, |
67941e3c MG |
585 | (SCM obj), |
586 | "Return a stack which consists of a single frame, which is the\n" | |
587 | "last stack frame for @var{obj}. @var{obj} must be either a\n" | |
588 | "debug object or a continuation.") | |
1bbd0b84 | 589 | #define FUNC_NAME s_scm_last_stack_frame |
782d171c | 590 | { |
92c2555f | 591 | scm_t_debug_frame *dframe; |
c014a02e | 592 | long offset = 0; |
7115d1e4 | 593 | SCM stack; |
782d171c | 594 | |
782d171c | 595 | if (SCM_DEBUGOBJP (obj)) |
13dcb666 DH |
596 | { |
597 | dframe = SCM_DEBUGOBJ_FRAME (obj); | |
598 | } | |
5f144b10 | 599 | else if (SCM_CONTINUATIONP (obj)) |
782d171c | 600 | { |
92c2555f | 601 | offset = ((SCM_STACKITEM *) ((char *) SCM_CONTREGS (obj) + sizeof (scm_t_contregs)) |
782d171c | 602 | - SCM_BASE (obj)); |
a1fa649f | 603 | #if SCM_STACK_GROWS_UP |
bfa974f0 | 604 | offset += SCM_CONTINUATION_LENGTH (obj); |
782d171c | 605 | #endif |
c0ab1b8d | 606 | dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); |
782d171c | 607 | } |
3323ad08 JB |
608 | else |
609 | { | |
276dd677 DH |
610 | SCM_WRONG_TYPE_ARG (1, obj); |
611 | /* not reached */ | |
3323ad08 | 612 | } |
782d171c | 613 | |
66f45472 | 614 | if (!dframe || SCM_VOIDFRAMEP (*dframe)) |
782d171c MD |
615 | return SCM_BOOL_F; |
616 | ||
762e289a | 617 | stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS), |
c0ab1b8d | 618 | SCM_EOL); |
7115d1e4 MD |
619 | SCM_STACK (stack) -> length = 1; |
620 | SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; | |
c0ab1b8d | 621 | read_frame (dframe, offset, |
92c2555f | 622 | (scm_t_info_frame *) &SCM_STACK (stack) -> frames[0]); |
782d171c | 623 | |
13dcb666 | 624 | return scm_cons (stack, SCM_INUM0); |
782d171c | 625 | } |
1bbd0b84 | 626 | #undef FUNC_NAME |
782d171c | 627 | |
3b3b36dd | 628 | SCM_DEFINE (scm_frame_number, "frame-number", 1, 0, 0, |
67941e3c MG |
629 | (SCM frame), |
630 | "Return the frame number of @var{frame}.") | |
1bbd0b84 | 631 | #define FUNC_NAME s_scm_frame_number |
782d171c | 632 | { |
34d19ef6 | 633 | SCM_VALIDATE_FRAME (1, frame); |
782d171c MD |
634 | return SCM_MAKINUM (SCM_FRAME_NUMBER (frame)); |
635 | } | |
1bbd0b84 | 636 | #undef FUNC_NAME |
782d171c | 637 | |
3b3b36dd | 638 | SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, |
67941e3c MG |
639 | (SCM frame), |
640 | "Return the source of @var{frame}.") | |
1bbd0b84 | 641 | #define FUNC_NAME s_scm_frame_source |
782d171c | 642 | { |
34d19ef6 | 643 | SCM_VALIDATE_FRAME (1, frame); |
782d171c MD |
644 | return SCM_FRAME_SOURCE (frame); |
645 | } | |
1bbd0b84 | 646 | #undef FUNC_NAME |
782d171c | 647 | |
3b3b36dd | 648 | SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, |
67941e3c MG |
649 | (SCM frame), |
650 | "Return the procedure for @var{frame}, or @code{#f} if no\n" | |
651 | "procedure is associated with @var{frame}.") | |
1bbd0b84 | 652 | #define FUNC_NAME s_scm_frame_procedure |
782d171c | 653 | { |
34d19ef6 | 654 | SCM_VALIDATE_FRAME (1, frame); |
782d171c | 655 | return (SCM_FRAME_PROC_P (frame) |
afa92d19 TP |
656 | ? SCM_FRAME_PROC (frame) |
657 | : SCM_BOOL_F); | |
782d171c | 658 | } |
1bbd0b84 | 659 | #undef FUNC_NAME |
782d171c | 660 | |
3b3b36dd | 661 | SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0, |
67941e3c MG |
662 | (SCM frame), |
663 | "Return the arguments of @var{frame}.") | |
1bbd0b84 | 664 | #define FUNC_NAME s_scm_frame_arguments |
782d171c | 665 | { |
34d19ef6 | 666 | SCM_VALIDATE_FRAME (1, frame); |
782d171c MD |
667 | return SCM_FRAME_ARGS (frame); |
668 | } | |
1bbd0b84 | 669 | #undef FUNC_NAME |
782d171c | 670 | |
3b3b36dd | 671 | SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, |
67941e3c MG |
672 | (SCM frame), |
673 | "Return the previous frame of @var{frame}, or @code{#f} if\n" | |
674 | "@var{frame} is the first frame in its stack.") | |
1bbd0b84 | 675 | #define FUNC_NAME s_scm_frame_previous |
782d171c | 676 | { |
13dcb666 DH |
677 | unsigned long int n; |
678 | SCM_VALIDATE_FRAME (1, frame); | |
782d171c MD |
679 | n = SCM_INUM (SCM_CDR (frame)) + 1; |
680 | if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) | |
681 | return SCM_BOOL_F; | |
682 | else | |
683 | return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); | |
684 | } | |
1bbd0b84 | 685 | #undef FUNC_NAME |
782d171c | 686 | |
3b3b36dd | 687 | SCM_DEFINE (scm_frame_next, "frame-next", 1, 0, 0, |
1bbd0b84 | 688 | (SCM frame), |
67941e3c MG |
689 | "Return the next frame of @var{frame}, or @code{#f} if\n" |
690 | "@var{frame} is the last frame in its stack.") | |
1bbd0b84 | 691 | #define FUNC_NAME s_scm_frame_next |
782d171c | 692 | { |
13dcb666 DH |
693 | unsigned long int n; |
694 | SCM_VALIDATE_FRAME (1, frame); | |
695 | n = SCM_INUM (SCM_CDR (frame)); | |
696 | if (n == 0) | |
782d171c MD |
697 | return SCM_BOOL_F; |
698 | else | |
13dcb666 | 699 | return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n - 1)); |
782d171c | 700 | } |
1bbd0b84 | 701 | #undef FUNC_NAME |
782d171c | 702 | |
3b3b36dd | 703 | SCM_DEFINE (scm_frame_real_p, "frame-real?", 1, 0, 0, |
67941e3c MG |
704 | (SCM frame), |
705 | "Return @code{#t} if @var{frame} is a real frame.") | |
1bbd0b84 | 706 | #define FUNC_NAME s_scm_frame_real_p |
782d171c | 707 | { |
34d19ef6 | 708 | SCM_VALIDATE_FRAME (1, frame); |
1bbd0b84 | 709 | return SCM_BOOL(SCM_FRAME_REAL_P (frame)); |
782d171c | 710 | } |
1bbd0b84 | 711 | #undef FUNC_NAME |
782d171c | 712 | |
3b3b36dd | 713 | SCM_DEFINE (scm_frame_procedure_p, "frame-procedure?", 1, 0, 0, |
67941e3c MG |
714 | (SCM frame), |
715 | "Return @code{#t} if a procedure is associated with @var{frame}.") | |
1bbd0b84 | 716 | #define FUNC_NAME s_scm_frame_procedure_p |
782d171c | 717 | { |
34d19ef6 | 718 | SCM_VALIDATE_FRAME (1, frame); |
1bbd0b84 | 719 | return SCM_BOOL(SCM_FRAME_PROC_P (frame)); |
782d171c | 720 | } |
1bbd0b84 | 721 | #undef FUNC_NAME |
782d171c | 722 | |
3b3b36dd | 723 | SCM_DEFINE (scm_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, |
67941e3c MG |
724 | (SCM frame), |
725 | "Return @code{#t} if @var{frame} contains evaluated arguments.") | |
1bbd0b84 | 726 | #define FUNC_NAME s_scm_frame_evaluating_args_p |
782d171c | 727 | { |
34d19ef6 | 728 | SCM_VALIDATE_FRAME (1, frame); |
1bbd0b84 | 729 | return SCM_BOOL(SCM_FRAME_EVAL_ARGS_P (frame)); |
782d171c | 730 | } |
1bbd0b84 | 731 | #undef FUNC_NAME |
782d171c | 732 | |
3b3b36dd | 733 | SCM_DEFINE (scm_frame_overflow_p, "frame-overflow?", 1, 0, 0, |
67941e3c MG |
734 | (SCM frame), |
735 | "Return @code{#t} if @var{frame} is an overflow frame.") | |
1bbd0b84 | 736 | #define FUNC_NAME s_scm_frame_overflow_p |
782d171c | 737 | { |
34d19ef6 | 738 | SCM_VALIDATE_FRAME (1, frame); |
156dcb09 | 739 | return SCM_BOOL(SCM_FRAME_OVERFLOW_P (frame)); |
782d171c | 740 | } |
1bbd0b84 | 741 | #undef FUNC_NAME |
782d171c MD |
742 | |
743 | \f | |
744 | ||
745 | void | |
746 | scm_init_stacks () | |
747 | { | |
66f45472 | 748 | SCM vtable; |
c0ab1b8d JB |
749 | SCM stack_layout |
750 | = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT)); | |
b299f5cd | 751 | vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); |
762e289a | 752 | scm_stack_type |
c0ab1b8d JB |
753 | = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, |
754 | scm_cons (stack_layout, | |
755 | SCM_EOL))); | |
762e289a | 756 | scm_set_struct_vtable_name_x (scm_stack_type, scm_str2symbol ("stack")); |
a0599745 | 757 | #include "libguile/stacks.x" |
782d171c | 758 | } |
89e00824 ML |
759 | |
760 | /* | |
761 | Local Variables: | |
762 | c-file-style: "gnu" | |
763 | End: | |
764 | */ |