Commit | Line | Data |
---|---|---|
782d171c | 1 | /* Representation of stack frame debug information |
7dc6e754 | 2 | * Copyright (C) 1996,1997 Free Software Foundation |
782d171c MD |
3 | * |
4 | * This program is free software; you can redistribute it and/or modify | |
5 | * it under the terms of the GNU General Public License as published by | |
6 | * the Free Software Foundation; either version 2, or (at your option) | |
7 | * any later version. | |
8 | * | |
9 | * This program is distributed in the hope that it will be useful, | |
10 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
12 | * GNU General Public License for more details. | |
13 | * | |
14 | * You should have received a copy of the GNU General Public License | |
15 | * along with this software; see the file COPYING. If not, write to | |
82892bed JB |
16 | * the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
17 | * Boston, MA 02111-1307 USA | |
782d171c MD |
18 | * |
19 | * As a special exception, the Free Software Foundation gives permission | |
20 | * for additional uses of the text contained in its release of GUILE. | |
21 | * | |
22 | * The exception is that, if you link the GUILE library with other files | |
23 | * to produce an executable, this does not by itself cause the | |
24 | * resulting executable to be covered by the GNU General Public License. | |
25 | * Your use of that executable is in no way restricted on account of | |
26 | * linking the GUILE library code into it. | |
27 | * | |
28 | * This exception does not however invalidate any other reasons why | |
29 | * the executable file might be covered by the GNU General Public License. | |
30 | * | |
31 | * This exception applies only to the code released by the | |
32 | * Free Software Foundation under the name GUILE. If you copy | |
33 | * code from other Free Software Foundation releases into a copy of | |
34 | * GUILE, as the General Public License permits, the exception does | |
35 | * not apply to the code that you add in this way. To avoid misleading | |
36 | * anyone as to the status of such modified files, you must delete | |
37 | * this exception notice from them. | |
38 | * | |
39 | * If you write modifications of your own for GUILE, it is your choice | |
40 | * whether to permit this exception to apply to your modifications. | |
41 | * If you do not wish that, delete this exception notice. | |
42 | * | |
43 | * The author can be reached at djurfeldt@nada.kth.se | |
82892bed | 44 | * Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */ |
782d171c MD |
45 | \f |
46 | ||
47 | #include <stdio.h> | |
48 | #include "_scm.h" | |
c3a6c6f9 | 49 | #include "eval.h" |
782d171c MD |
50 | #include "debug.h" |
51 | #include "continuations.h" | |
66f45472 | 52 | #include "struct.h" |
7c939801 | 53 | #include "macros.h" |
c3a6c6f9 | 54 | #include "procprop.h" |
650de6d7 | 55 | #include "modules.h" |
782d171c MD |
56 | |
57 | #include "stacks.h" | |
58 | ||
59 | \f | |
60 | /* {Frames and stacks} | |
61 | * | |
62 | * The debugging evaluator creates debug frames on the stack. These | |
63 | * are linked from the innermost frame and outwards. The last frame | |
64 | * created can always be accessed as SCM_LAST_DEBUG_FRAME. | |
65 | * Continuations contain a pointer to the innermost debug frame on the | |
66 | * continuation stack. | |
67 | * | |
68 | * Each debug frame contains a set of flags and information about one | |
69 | * or more stack frames. The case of multiple frames occurs due to | |
70 | * tail recursion. The maximal number of stack frames which can be | |
71 | * recorded in one debug frame can be set dynamically with the debug | |
72 | * option FRAMES. | |
73 | * | |
74 | * Stack frame information is of two types: eval information (the | |
75 | * expression being evaluated and its environment) and apply | |
76 | * information (the procedure being applied and its arguments). A | |
77 | * stack frame normally corresponds to an eval/apply pair, but macros | |
78 | * and special forms (which are implemented as macros in Guile) only | |
79 | * have eval information and apply calls leads to apply only frames. | |
80 | * | |
81 | * Since we want to record the total stack information and later | |
82 | * manipulate this data at the scheme level in the debugger, we need | |
83 | * to transform it into a new representation. In the following code | |
84 | * section you'll find the functions implementing this data type. | |
85 | * | |
86 | * Representation: | |
87 | * | |
7115d1e4 MD |
88 | * The stack is represented as a struct with an id slot and a tail |
89 | * array of scm_info_frame structs. | |
782d171c MD |
90 | * |
91 | * A frame is represented as a pair where the car contains a stack and | |
92 | * the cdr an inum. The inum is an index to the first SCM value of | |
93 | * the scm_info_frame struct. | |
94 | * | |
95 | * Stacks | |
96 | * Constructor | |
97 | * make-stack | |
7115d1e4 MD |
98 | * Selectors |
99 | * stack-id | |
782d171c MD |
100 | * stack-ref |
101 | * Inspector | |
102 | * stack-length | |
103 | * | |
104 | * Frames | |
105 | * Constructor | |
106 | * last-stack-frame | |
107 | * Selectors | |
108 | * frame-number | |
109 | * frame-source | |
110 | * frame-procedure | |
111 | * frame-arguments | |
112 | * frame-previous | |
113 | * frame-next | |
114 | * Predicates | |
115 | * frame-real? | |
116 | * frame-procedure? | |
117 | * frame-evaluating-args? | |
7115d1e4 | 118 | * frame-overflow? */ |
782d171c MD |
119 | |
120 | \f | |
121 | ||
122 | /* Some auxiliary functions for reading debug frames off the stack. | |
123 | */ | |
124 | ||
c0ab1b8d JB |
125 | /* Stacks often contain pointers to other items on the stack; for |
126 | example, each scm_debug_frame structure contains a pointer to the | |
127 | next frame out. When we capture a continuation, we copy the stack | |
128 | into the heap, and just leave all the pointers unchanged. This | |
129 | makes it simple to restore the continuation --- just copy the stack | |
130 | back! However, if we retrieve a pointer from the heap copy to | |
131 | another item that was originally on the stack, we have to add an | |
132 | offset to the pointer to discover the new referent. | |
133 | ||
134 | If PTR is a pointer retrieved from a continuation, whose original | |
135 | target was on the stack, and OFFSET is the appropriate offset from | |
136 | the original stack to the continuation, then RELOC_MUMBLE (PTR, | |
137 | OFFSET) is a pointer to the copy in the continuation of the | |
138 | original referent, cast to an scm_debug_MUMBLE *. */ | |
139 | #define RELOC_INFO(ptr, offset) \ | |
140 | ((scm_debug_info *) ((SCM_STACKITEM *) (ptr) + (offset))) | |
141 | #define RELOC_FRAME(ptr, offset) \ | |
142 | ((scm_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) | |
143 | ||
144 | ||
782d171c MD |
145 | /* Count number of debug info frames on a stack, beginning with |
146 | * DFRAME. OFFSET is used for relocation of pointers when the stack | |
147 | * is read from a continuation. | |
148 | */ | |
66f45472 | 149 | static int stack_depth SCM_P ((scm_debug_frame *dframe, long offset, SCM *id, int *maxp)); |
782d171c | 150 | static int |
66f45472 | 151 | stack_depth (dframe, offset, id, maxp) |
782d171c MD |
152 | scm_debug_frame *dframe; |
153 | long offset; | |
66f45472 | 154 | SCM *id; |
782d171c MD |
155 | int *maxp; |
156 | { | |
157 | int n, size; | |
158 | int max_depth = SCM_BACKTRACE_MAXDEPTH; | |
159 | scm_debug_info *info; | |
160 | for (n = 0; | |
66f45472 | 161 | dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth; |
c0ab1b8d | 162 | dframe = RELOC_FRAME (dframe->prev, offset)) |
782d171c MD |
163 | { |
164 | if (SCM_EVALFRAMEP (*dframe)) | |
165 | { | |
166 | size = dframe->status & SCM_MAX_FRAME_SIZE; | |
c0ab1b8d | 167 | info = RELOC_INFO (dframe->info, offset); |
782d171c MD |
168 | n += (info - dframe->vect) / 2 + 1; |
169 | /* Data in the apply part of an eval info frame comes from previous | |
170 | stack frame if the scm_debug_info vector is overflowed. */ | |
171 | if ((((info - dframe->vect) & 1) == 0) | |
172 | && SCM_OVERFLOWP (*dframe) | |
173 | && !SCM_UNBNDP (info[1].a.proc)) | |
174 | ++n; | |
175 | } | |
176 | else | |
177 | ++n; | |
178 | } | |
66f45472 MD |
179 | if (dframe && SCM_VOIDFRAMEP (*dframe)) |
180 | *id = dframe->vect[0].id; | |
181 | else if (dframe) | |
782d171c MD |
182 | *maxp = 1; |
183 | return n; | |
184 | } | |
185 | ||
186 | /* Read debug info from DFRAME into IFRAME. | |
187 | */ | |
188 | static void read_frame SCM_P ((scm_debug_frame *dframe, long offset, scm_info_frame *iframe)); | |
189 | static void | |
190 | read_frame (dframe, offset, iframe) | |
191 | scm_debug_frame *dframe; | |
192 | long offset; | |
193 | scm_info_frame *iframe; | |
194 | { | |
195 | SCM flags = SCM_INUM0; | |
196 | int size; | |
197 | scm_debug_info *info; | |
198 | if (SCM_EVALFRAMEP (*dframe)) | |
199 | { | |
200 | size = dframe->status & SCM_MAX_FRAME_SIZE; | |
c0ab1b8d | 201 | info = RELOC_INFO (dframe->info, offset); |
782d171c MD |
202 | if ((info - dframe->vect) & 1) |
203 | { | |
204 | /* Debug.vect ends with apply info. */ | |
205 | --info; | |
206 | if (info[1].a.proc != SCM_UNDEFINED) | |
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 | { | |
219 | flags |= SCM_FRAMEF_PROC; | |
220 | iframe->proc = dframe->vect[0].a.proc; | |
221 | iframe->args = dframe->vect[0].a.args; | |
222 | } | |
223 | iframe->flags = flags; | |
224 | } | |
225 | ||
7a13c3ae MD |
226 | SCM_SYMBOL (scm_sym_apply, "apply"); |
227 | ||
228 | /* Look up the first body form of the apply closure. We'll use this | |
229 | below to prevent it from being displayed. | |
230 | */ | |
231 | static SCM | |
232 | get_applybody () | |
233 | { | |
234 | SCM proc = SCM_CDR (scm_sym2vcell (scm_sym_apply, SCM_BOOL_F, SCM_BOOL_F)); | |
235 | if (SCM_NIMP (proc) && SCM_CLOSUREP (proc)) | |
236 | return SCM_CADR (SCM_CODE (proc)); | |
237 | else | |
238 | return SCM_UNDEFINED; | |
239 | } | |
7115d1e4 MD |
240 | |
241 | #define NEXT_FRAME(iframe, n, quit) \ | |
242 | { \ | |
7a13c3ae MD |
243 | if (SCM_NIMP (iframe->source) \ |
244 | && SCM_MEMOIZED_EXP (iframe->source) == applybody) \ | |
245 | { \ | |
246 | iframe->source = SCM_BOOL_F; \ | |
247 | if (SCM_FALSEP (iframe->proc)) \ | |
248 | { \ | |
249 | --iframe; \ | |
250 | ++n; \ | |
251 | } \ | |
252 | } \ | |
7115d1e4 MD |
253 | ++iframe; \ |
254 | if (--n == 0) \ | |
255 | goto quit; \ | |
256 | } \ | |
257 | ||
258 | ||
7a13c3ae MD |
259 | /* Fill the scm_info_frame vector IFRAME with data from N stack frames |
260 | * starting with the first stack frame represented by debug frame | |
261 | * DFRAME. | |
262 | */ | |
263 | ||
7c939801 MD |
264 | static int read_frames SCM_P ((scm_debug_frame *dframe, long offset, int nframes, scm_info_frame *iframes)); |
265 | static int | |
7115d1e4 | 266 | read_frames (dframe, offset, n, iframes) |
782d171c MD |
267 | scm_debug_frame *dframe; |
268 | long offset; | |
782d171c MD |
269 | int n; |
270 | scm_info_frame *iframes; | |
271 | { | |
272 | int size; | |
273 | scm_info_frame *iframe = iframes; | |
274 | scm_debug_info *info; | |
7a13c3ae | 275 | static SCM applybody = SCM_UNDEFINED; |
782d171c | 276 | |
7a13c3ae MD |
277 | /* The value of applybody has to be setup after r4rs.scm has executed. */ |
278 | if (SCM_UNBNDP (applybody)) | |
279 | applybody = get_applybody (); | |
782d171c | 280 | for (; |
66f45472 | 281 | dframe && !SCM_VOIDFRAMEP (*dframe) && n > 0; |
c0ab1b8d | 282 | dframe = RELOC_FRAME (dframe->prev, offset)) |
782d171c MD |
283 | { |
284 | read_frame (dframe, offset, iframe); | |
285 | if (SCM_EVALFRAMEP (*dframe)) | |
286 | { | |
6629eb1c MD |
287 | /* If current frame is a macro during expansion, we should |
288 | skip the previously recorded macro transformer | |
289 | application frame. */ | |
290 | if (SCM_MACROEXPP (*dframe) && iframe > iframes) | |
7c939801 MD |
291 | { |
292 | *(iframe - 1) = *iframe; | |
293 | --iframe; | |
294 | } | |
782d171c | 295 | size = dframe->status & SCM_MAX_FRAME_SIZE; |
c0ab1b8d | 296 | info = RELOC_INFO (dframe->info, offset); |
782d171c MD |
297 | if ((info - dframe->vect) & 1) |
298 | --info; | |
299 | /* Data in the apply part of an eval info frame comes from | |
300 | previous stack frame if the scm_debug_info vector is overflowed. */ | |
301 | else if (SCM_OVERFLOWP (*dframe) | |
302 | && !SCM_UNBNDP (info[1].a.proc)) | |
303 | { | |
7115d1e4 | 304 | NEXT_FRAME (iframe, n, quit); |
782d171c MD |
305 | iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC; |
306 | iframe->proc = info[1].a.proc; | |
307 | iframe->args = info[1].a.args; | |
308 | } | |
309 | if (SCM_OVERFLOWP (*dframe)) | |
310 | iframe->flags |= SCM_FRAMEF_OVERFLOW; | |
311 | info -= 2; | |
7115d1e4 | 312 | NEXT_FRAME (iframe, n, quit); |
782d171c MD |
313 | while (info >= dframe->vect) |
314 | { | |
315 | if (!SCM_UNBNDP (info[1].a.proc)) | |
316 | { | |
317 | iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC; | |
318 | iframe->proc = info[1].a.proc; | |
319 | iframe->args = info[1].a.args; | |
320 | } | |
321 | else | |
322 | iframe->flags = SCM_INUM0; | |
323 | iframe->source = scm_make_memoized (info[0].e.exp, | |
324 | info[0].e.env); | |
325 | info -= 2; | |
7115d1e4 | 326 | NEXT_FRAME (iframe, n, quit); |
782d171c MD |
327 | } |
328 | } | |
7c939801 MD |
329 | else if (iframe->proc == scm_f_gsubr_apply) |
330 | /* Skip gsubr apply frames. */ | |
331 | continue; | |
782d171c MD |
332 | else |
333 | { | |
7115d1e4 | 334 | NEXT_FRAME (iframe, n, quit); |
782d171c MD |
335 | } |
336 | quit: | |
337 | if (iframe > iframes) | |
338 | (iframe - 1) -> flags |= SCM_FRAMEF_REAL; | |
339 | } | |
7c939801 | 340 | return iframe - iframes; /* Number of frames actually read */ |
782d171c MD |
341 | } |
342 | ||
7115d1e4 MD |
343 | static void narrow_stack SCM_P ((SCM stack, int inner, SCM inner_key, int outer, SCM outer_key)); |
344 | ||
c3a6c6f9 MD |
345 | /* Narrow STACK by cutting away stackframes (mutatingly). |
346 | * | |
347 | * Inner frames (most recent) are cut by advancing the frames pointer. | |
348 | * Outer frames are cut by decreasing the recorded length. | |
349 | * | |
350 | * Cut maximally INNER inner frames and OUTER outer frames using | |
351 | * the keys INNER_KEY and OUTER_KEY. | |
352 | * | |
353 | * Frames are cut away starting at the end points and moving towards | |
354 | * the center of the stack. The key is normally compared to the | |
355 | * operator in application frames. Frames up to and including the key | |
356 | * are cut. | |
357 | * | |
358 | * If INNER_KEY is #t a different scheme is used for inner frames: | |
359 | * | |
360 | * Frames up to but excluding the first source frame originating from | |
361 | * a user module are cut, except for possible application frames | |
362 | * between the user frame and the last system frame previously | |
363 | * encountered. | |
364 | */ | |
365 | ||
7115d1e4 MD |
366 | static void |
367 | narrow_stack (stack, inner, inner_key, outer, outer_key) | |
368 | SCM stack; | |
369 | int inner; | |
370 | SCM inner_key; | |
371 | int outer; | |
372 | SCM outer_key; | |
373 | { | |
374 | scm_stack *s = SCM_STACK (stack); | |
375 | int i; | |
376 | int n = s->length; | |
377 | ||
378 | /* Cut inner part. */ | |
c3a6c6f9 MD |
379 | if (inner_key == SCM_BOOL_T) |
380 | /* Cut all frames up to user module code */ | |
381 | { | |
382 | for (i = 0; inner; ++i, --inner) | |
383 | { | |
384 | SCM m = s->frames[i].source; | |
385 | if (SCM_NIMP (m) | |
386 | && SCM_MEMOIZEDP (m) | |
387 | && SCM_NIMP (SCM_MEMOIZED_ENV (m)) | |
388 | && SCM_FALSEP (scm_system_module_env_p (SCM_MEMOIZED_ENV (m)))) | |
389 | { | |
390 | /* Back up in order to include any non-source frames */ | |
391 | while (i > 0 | |
392 | && !((SCM_NIMP (m = s->frames[i - 1].source) | |
393 | && SCM_MEMOIZEDP (m)) | |
394 | || (SCM_NIMP (m = s->frames[i - 1].proc) | |
395 | && SCM_NFALSEP (scm_procedure_p (m)) | |
396 | && SCM_NFALSEP (scm_procedure_property | |
397 | (m, scm_sym_system_procedure))))) | |
398 | { | |
399 | --i; | |
400 | ++inner; | |
401 | } | |
402 | break; | |
403 | } | |
404 | } | |
405 | } | |
406 | else | |
407 | /* Use standard cutting procedure. */ | |
408 | { | |
409 | for (i = 0; inner; --inner) | |
410 | if (s->frames[i++].proc == inner_key) | |
411 | break; | |
412 | } | |
7115d1e4 MD |
413 | s->frames = &s->frames[i]; |
414 | n -= i; | |
415 | ||
416 | /* Cut outer part. */ | |
417 | for (; n && outer; --outer) | |
418 | if (s->frames[--n].proc == outer_key) | |
419 | break; | |
420 | ||
421 | s->length = n; | |
422 | } | |
423 | ||
782d171c MD |
424 | \f |
425 | ||
426 | /* Stacks | |
427 | */ | |
428 | ||
66f45472 MD |
429 | SCM scm_stack_type; |
430 | ||
431 | SCM_PROC (s_stack_p, "stack?", 1, 0, 0, scm_stack_p); | |
432 | SCM | |
433 | scm_stack_p (obj) | |
434 | SCM obj; | |
435 | { | |
436 | return SCM_NIMP (obj) && SCM_STACKP (obj) ? SCM_BOOL_T : SCM_BOOL_F; | |
437 | } | |
438 | ||
f6f88e0d | 439 | SCM_PROC (s_make_stack, "make-stack", 0, 0, 1, scm_make_stack); |
782d171c | 440 | SCM |
f6f88e0d MD |
441 | scm_make_stack (args) |
442 | SCM args; | |
782d171c | 443 | { |
7115d1e4 | 444 | int n, maxp, size; |
782d171c MD |
445 | scm_debug_frame *dframe; |
446 | scm_info_frame *iframe; | |
447 | long offset = 0; | |
66f45472 | 448 | SCM stack, id; |
f6f88e0d | 449 | SCM obj, inner_cut, outer_cut; |
782d171c | 450 | |
0824b524 MD |
451 | SCM_ASSERT (SCM_NIMP (args) && SCM_CONSP (args), |
452 | scm_makfrom0str (s_make_stack), | |
453 | SCM_WNA, | |
454 | NULL); | |
f6f88e0d MD |
455 | obj = SCM_CAR (args); |
456 | args = SCM_CDR (args); | |
457 | ||
458 | /* Extract a pointer to the innermost frame of whatever object | |
459 | scm_make_stack was given. */ | |
7115d1e4 | 460 | if (obj == SCM_BOOL_T) |
782d171c MD |
461 | dframe = scm_last_debug_frame; |
462 | else | |
463 | { | |
464 | SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_make_stack); | |
465 | if (SCM_DEBUGOBJP (obj)) | |
466 | dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); | |
467 | else if (scm_tc7_contin == SCM_TYP7 (obj)) | |
468 | { | |
469 | offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) | |
470 | - SCM_BASE (obj)); | |
471 | #ifndef STACK_GROWS_UP | |
472 | offset += SCM_LENGTH (obj); | |
473 | #endif | |
c0ab1b8d | 474 | dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); |
782d171c | 475 | } |
3323ad08 JB |
476 | else |
477 | { | |
478 | scm_wta (obj, (char *) SCM_ARG1, s_make_stack); | |
479 | abort (); | |
480 | } | |
782d171c MD |
481 | } |
482 | ||
f6f88e0d MD |
483 | /* Count number of frames. Also get stack id tag and check whether |
484 | there are more stackframes than we want to record | |
485 | (SCM_BACKTRACE_MAXDEPTH). */ | |
66f45472 MD |
486 | id = SCM_BOOL_F; |
487 | maxp = 0; | |
7115d1e4 | 488 | n = stack_depth (dframe, offset, &id, &maxp); |
782d171c MD |
489 | size = n * SCM_FRAME_N_SLOTS; |
490 | ||
f6f88e0d | 491 | /* Make the stack object. */ |
66f45472 MD |
492 | stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (size), SCM_EOL); |
493 | SCM_STACK (stack) -> id = id; | |
7115d1e4 MD |
494 | iframe = &SCM_STACK (stack) -> tail[0]; |
495 | SCM_STACK (stack) -> frames = iframe; | |
7115d1e4 | 496 | |
f6f88e0d | 497 | /* Translate the current chain of stack frames into debugging information. */ |
7c939801 MD |
498 | n = read_frames (RELOC_FRAME (dframe, offset), offset, n, iframe); |
499 | SCM_STACK (stack) -> length = n; | |
7115d1e4 | 500 | |
f6f88e0d MD |
501 | /* Narrow the stack according to the arguments given to scm_make_stack. */ |
502 | while (n > 0 && SCM_NIMP (args) && SCM_CONSP (args)) | |
503 | { | |
504 | inner_cut = SCM_CAR (args); | |
505 | args = SCM_CDR (args); | |
506 | if (SCM_NIMP (args) && SCM_CONSP (args)) | |
507 | { | |
508 | outer_cut = SCM_CAR (args); | |
509 | args = SCM_CDR (args); | |
510 | } | |
511 | else | |
512 | outer_cut = SCM_INUM0; | |
513 | ||
514 | narrow_stack (stack, | |
515 | SCM_INUMP (inner_cut) ? SCM_INUM (inner_cut) : n, | |
516 | SCM_INUMP (inner_cut) ? 0 : inner_cut, | |
517 | SCM_INUMP (outer_cut) ? SCM_INUM (outer_cut) : n, | |
518 | SCM_INUMP (outer_cut) ? 0 : outer_cut); | |
519 | ||
520 | n = SCM_STACK (stack) -> length; | |
521 | } | |
522 | ||
7115d1e4 | 523 | if (n > 0) |
f6f88e0d MD |
524 | { |
525 | if (maxp) | |
526 | iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; | |
527 | return stack; | |
528 | } | |
7115d1e4 MD |
529 | else |
530 | return SCM_BOOL_F; | |
782d171c MD |
531 | } |
532 | ||
66f45472 MD |
533 | SCM_PROC (s_stack_id, "stack-id", 1, 0, 0, scm_stack_id); |
534 | SCM | |
535 | scm_stack_id (stack) | |
536 | SCM stack; | |
537 | { | |
7115d1e4 MD |
538 | scm_debug_frame *dframe; |
539 | long offset = 0; | |
540 | if (stack == SCM_BOOL_T) | |
541 | dframe = scm_last_debug_frame; | |
542 | else | |
543 | { | |
544 | SCM_ASSERT (SCM_NIMP (stack), stack, SCM_ARG1, s_make_stack); | |
545 | if (SCM_DEBUGOBJP (stack)) | |
546 | dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (stack); | |
547 | else if (scm_tc7_contin == SCM_TYP7 (stack)) | |
548 | { | |
549 | offset = ((SCM_STACKITEM *) (SCM_CHARS (stack) + sizeof (scm_contregs)) | |
550 | - SCM_BASE (stack)); | |
551 | #ifndef STACK_GROWS_UP | |
552 | offset += SCM_LENGTH (stack); | |
553 | #endif | |
c0ab1b8d | 554 | dframe = RELOC_FRAME (SCM_DFRAME (stack), offset); |
7115d1e4 MD |
555 | } |
556 | else if (SCM_STACKP (stack)) | |
557 | return SCM_STACK (stack) -> id; | |
c3a6c6f9 MD |
558 | else |
559 | scm_wrong_type_arg (s_stack_id, SCM_ARG1, stack); | |
7115d1e4 MD |
560 | } |
561 | while (dframe && !SCM_VOIDFRAMEP (*dframe)) | |
c0ab1b8d | 562 | dframe = RELOC_FRAME (dframe->prev, offset); |
7115d1e4 MD |
563 | if (dframe && SCM_VOIDFRAMEP (*dframe)) |
564 | return dframe->vect[0].id; | |
565 | return SCM_BOOL_F; | |
66f45472 MD |
566 | } |
567 | ||
568 | SCM_PROC (s_stack_ref, "stack-ref", 2, 0, 0, scm_stack_ref); | |
782d171c MD |
569 | SCM |
570 | scm_stack_ref (stack, i) | |
571 | SCM stack; | |
572 | SCM i; | |
573 | { | |
574 | SCM_ASSERT (SCM_NIMP (stack) | |
575 | && SCM_STACKP (stack), | |
576 | stack, | |
577 | SCM_ARG1, | |
578 | s_stack_ref); | |
579 | SCM_ASSERT (SCM_INUMP (i), i, SCM_ARG2, s_stack_ref); | |
580 | SCM_ASSERT (SCM_INUM (i) >= 0 | |
581 | && SCM_INUM (i) < SCM_STACK_LENGTH (stack), | |
582 | i, | |
583 | SCM_OUTOFRANGE, | |
584 | s_stack_ref); | |
585 | return scm_cons (stack, i); | |
586 | } | |
587 | ||
588 | SCM_PROC(s_stack_length, "stack-length", 1, 0, 0, scm_stack_length); | |
589 | SCM | |
590 | scm_stack_length (stack) | |
591 | SCM stack; | |
592 | { | |
593 | SCM_ASSERT (SCM_NIMP (stack) | |
594 | && SCM_STACKP (stack), | |
595 | stack, | |
596 | SCM_ARG1, | |
597 | s_stack_length); | |
598 | return SCM_MAKINUM (SCM_STACK_LENGTH (stack)); | |
599 | } | |
600 | ||
601 | /* Frames | |
602 | */ | |
603 | ||
66f45472 MD |
604 | SCM_PROC (s_frame_p, "frame?", 1, 0, 0, scm_frame_p); |
605 | SCM | |
606 | scm_frame_p (obj) | |
607 | SCM obj; | |
608 | { | |
609 | return SCM_NIMP (obj) && SCM_FRAMEP (obj); | |
610 | } | |
611 | ||
782d171c MD |
612 | SCM_PROC(s_last_stack_frame, "last-stack-frame", 1, 0, 0, scm_last_stack_frame); |
613 | SCM | |
614 | scm_last_stack_frame (obj) | |
615 | SCM obj; | |
616 | { | |
617 | scm_debug_frame *dframe; | |
618 | long offset = 0; | |
7115d1e4 | 619 | SCM stack; |
782d171c MD |
620 | |
621 | SCM_ASSERT (SCM_NIMP (obj), obj, SCM_ARG1, s_last_stack_frame); | |
622 | if (SCM_DEBUGOBJP (obj)) | |
623 | dframe = (scm_debug_frame *) SCM_DEBUGOBJ_FRAME (obj); | |
624 | else if (scm_tc7_contin == SCM_TYP7 (obj)) | |
625 | { | |
626 | offset = ((SCM_STACKITEM *) (SCM_CHARS (obj) + sizeof (scm_contregs)) | |
627 | - SCM_BASE (obj)); | |
628 | #ifndef STACK_GROWS_UP | |
629 | offset += SCM_LENGTH (obj); | |
630 | #endif | |
c0ab1b8d | 631 | dframe = RELOC_FRAME (SCM_DFRAME (obj), offset); |
782d171c | 632 | } |
3323ad08 JB |
633 | else |
634 | { | |
635 | scm_wta (obj, (char *) SCM_ARG1, s_last_stack_frame); | |
636 | abort (); | |
637 | } | |
782d171c | 638 | |
66f45472 | 639 | if (!dframe || SCM_VOIDFRAMEP (*dframe)) |
782d171c MD |
640 | return SCM_BOOL_F; |
641 | ||
c0ab1b8d JB |
642 | stack = scm_make_struct (scm_stack_type, SCM_MAKINUM (SCM_FRAME_N_SLOTS), |
643 | SCM_EOL); | |
7115d1e4 MD |
644 | SCM_STACK (stack) -> length = 1; |
645 | SCM_STACK (stack) -> frames = &SCM_STACK (stack) -> tail[0]; | |
c0ab1b8d JB |
646 | read_frame (dframe, offset, |
647 | (scm_info_frame *) &SCM_STACK (stack) -> frames[0]); | |
782d171c | 648 | |
7115d1e4 | 649 | return scm_cons (stack, SCM_INUM0);; |
782d171c MD |
650 | } |
651 | ||
652 | SCM_PROC(s_frame_number, "frame-number", 1, 0, 0, scm_frame_number); | |
653 | SCM | |
654 | scm_frame_number (frame) | |
655 | SCM frame; | |
656 | { | |
657 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
658 | frame, | |
659 | SCM_ARG1, | |
660 | s_frame_number); | |
661 | return SCM_MAKINUM (SCM_FRAME_NUMBER (frame)); | |
662 | } | |
663 | ||
664 | SCM_PROC(s_frame_source, "frame-source", 1, 0, 0, scm_frame_source); | |
665 | SCM | |
666 | scm_frame_source (frame) | |
667 | SCM frame; | |
668 | { | |
669 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
670 | frame, | |
671 | SCM_ARG1, | |
672 | s_frame_source); | |
673 | return SCM_FRAME_SOURCE (frame); | |
674 | } | |
675 | ||
676 | SCM_PROC(s_frame_procedure, "frame-procedure", 1, 0, 0, scm_frame_procedure); | |
677 | SCM | |
678 | scm_frame_procedure (frame) | |
679 | SCM frame; | |
680 | { | |
681 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
682 | frame, | |
683 | SCM_ARG1, | |
684 | s_frame_procedure); | |
685 | return (SCM_FRAME_PROC_P (frame) | |
afa92d19 TP |
686 | ? SCM_FRAME_PROC (frame) |
687 | : SCM_BOOL_F); | |
782d171c MD |
688 | } |
689 | ||
690 | SCM_PROC(s_frame_arguments, "frame-arguments", 1, 0, 0, scm_frame_arguments); | |
691 | SCM | |
692 | scm_frame_arguments (frame) | |
693 | SCM frame; | |
694 | { | |
695 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
696 | frame, | |
697 | SCM_ARG1, | |
698 | s_frame_arguments); | |
699 | return SCM_FRAME_ARGS (frame); | |
700 | } | |
701 | ||
702 | SCM_PROC(s_frame_previous, "frame-previous", 1, 0, 0, scm_frame_previous); | |
703 | SCM | |
704 | scm_frame_previous (frame) | |
705 | SCM frame; | |
706 | { | |
707 | int n; | |
708 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
709 | frame, | |
710 | SCM_ARG1, | |
711 | s_frame_previous); | |
712 | n = SCM_INUM (SCM_CDR (frame)) + 1; | |
713 | if (n >= SCM_STACK_LENGTH (SCM_CAR (frame))) | |
714 | return SCM_BOOL_F; | |
715 | else | |
716 | return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); | |
717 | } | |
718 | ||
719 | SCM_PROC(s_frame_next, "frame-next", 1, 0, 0, scm_frame_next); | |
720 | SCM | |
721 | scm_frame_next (frame) | |
722 | SCM frame; | |
723 | { | |
724 | int n; | |
725 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
726 | frame, | |
727 | SCM_ARG1, | |
728 | s_frame_next); | |
729 | n = SCM_INUM (SCM_CDR (frame)) - 1; | |
730 | if (n < 0) | |
731 | return SCM_BOOL_F; | |
732 | else | |
733 | return scm_cons (SCM_CAR (frame), SCM_MAKINUM (n)); | |
734 | } | |
735 | ||
736 | SCM_PROC(s_frame_real_p, "frame-real?", 1, 0, 0, scm_frame_real_p); | |
737 | SCM | |
738 | scm_frame_real_p (frame) | |
739 | SCM frame; | |
740 | { | |
741 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
742 | frame, | |
743 | SCM_ARG1, | |
744 | s_frame_real_p); | |
745 | return SCM_FRAME_REAL_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; | |
746 | } | |
747 | ||
748 | SCM_PROC(s_frame_procedure_p, "frame-procedure?", 1, 0, 0, scm_frame_procedure_p); | |
749 | SCM | |
750 | scm_frame_procedure_p (frame) | |
751 | SCM frame; | |
752 | { | |
753 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
754 | frame, | |
755 | SCM_ARG1, | |
756 | s_frame_procedure_p); | |
757 | return SCM_FRAME_PROC_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; | |
758 | } | |
759 | ||
760 | SCM_PROC(s_frame_evaluating_args_p, "frame-evaluating-args?", 1, 0, 0, scm_frame_evaluating_args_p); | |
761 | SCM | |
762 | scm_frame_evaluating_args_p (frame) | |
763 | SCM frame; | |
764 | { | |
765 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
766 | frame, | |
767 | SCM_ARG1, | |
768 | s_frame_evaluating_args_p); | |
769 | return SCM_FRAME_EVAL_ARGS_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; | |
770 | } | |
771 | ||
772 | SCM_PROC(s_frame_overflow_p, "frame-overflow?", 1, 0, 0, scm_frame_overflow_p); | |
773 | SCM | |
774 | scm_frame_overflow_p (frame) | |
775 | SCM frame; | |
776 | { | |
777 | SCM_ASSERT (SCM_NIMP (frame) && SCM_FRAMEP (frame), | |
778 | frame, | |
779 | SCM_ARG1, | |
780 | s_frame_overflow_p); | |
781 | return SCM_FRAME_OVERFLOW_P (frame) ? SCM_BOOL_T : SCM_BOOL_F; | |
782 | } | |
783 | ||
784 | \f | |
785 | ||
786 | void | |
787 | scm_init_stacks () | |
788 | { | |
66f45472 MD |
789 | SCM vtable; |
790 | SCM vtable_layout = scm_make_struct_layout (scm_nullstr); | |
c0ab1b8d JB |
791 | SCM stack_layout |
792 | = scm_make_struct_layout (scm_makfrom0str (SCM_STACK_LAYOUT)); | |
66f45472 | 793 | vtable = scm_make_vtable_vtable (vtable_layout, SCM_INUM0, SCM_EOL); |
c0ab1b8d JB |
794 | scm_stack_type |
795 | = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, | |
796 | scm_cons (stack_layout, | |
797 | SCM_EOL))); | |
782d171c MD |
798 | #include "stacks.x" |
799 | } |