Commit | Line | Data |
---|---|---|
aa3f6951 | 1 | /* A stack holds a frame chain |
361d0de2 | 2 | * Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation |
782d171c | 3 | * |
73be1d9e | 4 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
5 | * modify it under the terms of the GNU Lesser General Public License |
6 | * as published by the Free Software Foundation; either version 3 of | |
7 | * the License, or (at your option) any later version. | |
782d171c | 8 | * |
53befeb7 NJ |
9 | * This library is distributed in the hope that it will be useful, but |
10 | * 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 | |
53befeb7 NJ |
16 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
17 | * 02110-1301 USA | |
73be1d9e | 18 | */ |
1bbd0b84 | 19 | |
1bbd0b84 | 20 | |
782d171c | 21 | \f |
dbb605f5 LC |
22 | #ifdef HAVE_CONFIG_H |
23 | # include <config.h> | |
24 | #endif | |
782d171c | 25 | |
a0599745 | 26 | #include "libguile/_scm.h" |
06dcb9df | 27 | #include "libguile/control.h" |
a0599745 MD |
28 | #include "libguile/eval.h" |
29 | #include "libguile/debug.h" | |
30 | #include "libguile/continuations.h" | |
31 | #include "libguile/struct.h" | |
32 | #include "libguile/macros.h" | |
33 | #include "libguile/procprop.h" | |
34 | #include "libguile/modules.h" | |
35 | #include "libguile/root.h" | |
36 | #include "libguile/strings.h" | |
b1b942b7 AW |
37 | #include "libguile/vm.h" /* to capture vm stacks */ |
38 | #include "libguile/frames.h" /* vm frames */ | |
a0599745 MD |
39 | |
40 | #include "libguile/validate.h" | |
41 | #include "libguile/stacks.h" | |
22fc179a HWN |
42 | #include "libguile/private-options.h" |
43 | ||
782d171c | 44 | |
06dcb9df AW |
45 | static SCM scm_sys_stacks; |
46 | ||
782d171c | 47 | \f |
aa3f6951 | 48 | /* {Stacks} |
782d171c | 49 | * |
aa3f6951 AW |
50 | * The stack is represented as a struct that holds a frame. The frame itself is |
51 | * linked to the next frame, or #f. | |
782d171c MD |
52 | * |
53 | * Stacks | |
54 | * Constructor | |
55 | * make-stack | |
7115d1e4 MD |
56 | * Selectors |
57 | * stack-id | |
782d171c MD |
58 | * stack-ref |
59 | * Inspector | |
60 | * stack-length | |
aa3f6951 | 61 | */ |
782d171c MD |
62 | |
63 | \f | |
64 | ||
aa3f6951 | 65 | /* Count number of debug info frames on a stack, beginning with FRAME. |
782d171c | 66 | */ |
b1b942b7 | 67 | static long |
06dcb9df | 68 | stack_depth (SCM frame) |
782d171c | 69 | { |
fdcb2b82 | 70 | long n = 0; |
aa3f6951 | 71 | /* count frames, skipping boot frames */ |
06dcb9df | 72 | for (; scm_is_true (frame); frame = scm_frame_previous (frame)) |
93dbc31b | 73 | ++n; |
782d171c MD |
74 | return n; |
75 | } | |
76 | ||
c3a6c6f9 MD |
77 | /* Narrow STACK by cutting away stackframes (mutatingly). |
78 | * | |
79 | * Inner frames (most recent) are cut by advancing the frames pointer. | |
80 | * Outer frames are cut by decreasing the recorded length. | |
81 | * | |
82 | * Cut maximally INNER inner frames and OUTER outer frames using | |
83 | * the keys INNER_KEY and OUTER_KEY. | |
84 | * | |
85 | * Frames are cut away starting at the end points and moving towards | |
86 | * the center of the stack. The key is normally compared to the | |
87 | * operator in application frames. Frames up to and including the key | |
88 | * are cut. | |
89 | * | |
90 | * If INNER_KEY is #t a different scheme is used for inner frames: | |
91 | * | |
92 | * Frames up to but excluding the first source frame originating from | |
93 | * a user module are cut, except for possible application frames | |
94 | * between the user frame and the last system frame previously | |
95 | * encountered. | |
96 | */ | |
97 | ||
9ede013f | 98 | static SCM* |
06dcb9df AW |
99 | find_prompt (SCM key) |
100 | { | |
9d381ba4 | 101 | SCM *fp; |
9ede013f AW |
102 | |
103 | if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key, | |
9d381ba4 | 104 | NULL, &fp, NULL, NULL, NULL)) |
9ede013f AW |
105 | scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack", |
106 | scm_list_1 (key)); | |
107 | ||
9d381ba4 | 108 | return fp; |
06dcb9df AW |
109 | } |
110 | ||
7115d1e4 | 111 | static void |
99d7688b | 112 | narrow_stack (SCM stack, SCM inner_cut, SCM outer_cut) |
7115d1e4 | 113 | { |
aa3f6951 AW |
114 | unsigned long int len; |
115 | SCM frame; | |
7115d1e4 | 116 | |
aa3f6951 AW |
117 | len = SCM_STACK_LENGTH (stack); |
118 | frame = SCM_STACK_FRAME (stack); | |
119 | ||
7115d1e4 | 120 | /* Cut inner part. */ |
99d7688b | 121 | if (scm_is_true (scm_procedure_p (inner_cut))) |
c3a6c6f9 | 122 | { |
06dcb9df | 123 | /* Cut until the given procedure is seen. */ |
99d7688b | 124 | for (; len ;) |
aa3f6951 | 125 | { |
06dcb9df | 126 | SCM proc = scm_frame_procedure (frame); |
aa3f6951 | 127 | len--; |
93dbc31b | 128 | frame = scm_frame_previous (frame); |
99d7688b | 129 | if (scm_is_eq (proc, inner_cut)) |
06dcb9df | 130 | break; |
aa3f6951 | 131 | } |
c3a6c6f9 | 132 | } |
99d7688b | 133 | else if (scm_is_integer (inner_cut)) |
c3a6c6f9 | 134 | { |
06dcb9df | 135 | /* Cut specified number of frames. */ |
99d7688b NL |
136 | long inner = scm_to_int (inner_cut); |
137 | ||
06dcb9df | 138 | for (; inner && len; --inner) |
aa3f6951 | 139 | { |
aa3f6951 | 140 | len--; |
93dbc31b | 141 | frame = scm_frame_previous (frame); |
aa3f6951 | 142 | } |
c3a6c6f9 | 143 | } |
99d7688b NL |
144 | else |
145 | { | |
146 | /* Cut until the given prompt tag is seen. */ | |
147 | SCM *fp = find_prompt (inner_cut); | |
148 | for (; len; len--, frame = scm_frame_previous (frame)) | |
149 | if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame)) | |
150 | break; | |
151 | } | |
aa3f6951 AW |
152 | |
153 | SCM_SET_STACK_LENGTH (stack, len); | |
154 | SCM_SET_STACK_FRAME (stack, frame); | |
7115d1e4 MD |
155 | |
156 | /* Cut outer part. */ | |
99d7688b | 157 | if (scm_is_true (scm_procedure_p (outer_cut))) |
aa3f6951 | 158 | { |
06dcb9df | 159 | /* Cut until the given procedure is seen. */ |
99d7688b | 160 | for (; len ;) |
06dcb9df AW |
161 | { |
162 | frame = scm_stack_ref (stack, scm_from_long (len - 1)); | |
163 | len--; | |
99d7688b | 164 | if (scm_is_eq (scm_frame_procedure (frame), outer_cut)) |
06dcb9df AW |
165 | break; |
166 | } | |
167 | } | |
99d7688b NL |
168 | else if (scm_is_integer (outer_cut)) |
169 | { | |
170 | /* Cut specified number of frames. */ | |
171 | long outer = scm_to_int (outer_cut); | |
172 | ||
173 | if (outer < len) | |
174 | len -= outer; | |
175 | else | |
176 | len = 0; | |
177 | } | |
178 | else | |
06dcb9df | 179 | { |
99d7688b NL |
180 | /* Cut until the given prompt tag is seen. */ |
181 | SCM *fp = find_prompt (outer_cut); | |
06dcb9df AW |
182 | while (len) |
183 | { | |
184 | frame = scm_stack_ref (stack, scm_from_long (len - 1)); | |
185 | len--; | |
9ede013f | 186 | if (fp == SCM_VM_FRAME_FP (frame) - SCM_VM_FRAME_OFFSET (frame)) |
06dcb9df AW |
187 | break; |
188 | } | |
189 | } | |
7115d1e4 | 190 | |
aa3f6951 | 191 | SCM_SET_STACK_LENGTH (stack, len); |
7115d1e4 MD |
192 | } |
193 | ||
782d171c MD |
194 | \f |
195 | ||
196 | /* Stacks | |
197 | */ | |
198 | ||
762e289a | 199 | SCM scm_stack_type; |
66f45472 | 200 | |
a1ec6916 | 201 | SCM_DEFINE (scm_stack_p, "stack?", 1, 0, 0, |
1bbd0b84 | 202 | (SCM obj), |
b380b885 | 203 | "Return @code{#t} if @var{obj} is a calling stack.") |
1bbd0b84 | 204 | #define FUNC_NAME s_scm_stack_p |
66f45472 | 205 | { |
7888309b | 206 | return scm_from_bool(SCM_STACKP (obj)); |
66f45472 | 207 | } |
1bbd0b84 | 208 | #undef FUNC_NAME |
66f45472 | 209 | |
af45e3b0 DH |
210 | SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, |
211 | (SCM obj, SCM args), | |
67941e3c MG |
212 | "Create a new stack. If @var{obj} is @code{#t}, the current\n" |
213 | "evaluation stack is used for creating the stack frames,\n" | |
214 | "otherwise the frames are taken from @var{obj} (which must be\n" | |
06dcb9df AW |
215 | "a continuation or a frame object).\n" |
216 | "\n" | |
baffb19f | 217 | "@var{args} should be a list containing any combination of\n" |
06dcb9df AW |
218 | "integer, procedure, prompt tag and @code{#t} values.\n" |
219 | "\n" | |
baffb19f NJ |
220 | "These values specify various ways of cutting away uninteresting\n" |
221 | "stack frames from the top and bottom of the stack that\n" | |
222 | "@code{make-stack} returns. They come in pairs like this:\n" | |
223 | "@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2}\n" | |
06dcb9df AW |
224 | "@var{outer_cut_2} @dots{})}.\n" |
225 | "\n" | |
b7e64f8b | 226 | "Each @var{inner_cut_i} can be @code{#t}, an integer, a prompt\n" |
06dcb9df AW |
227 | "tag, or a procedure. @code{#t} means to cut away all frames up\n" |
228 | "to but excluding the first user module frame. An integer means\n" | |
229 | "to cut away exactly that number of frames. A prompt tag means\n" | |
230 | "to cut away all frames that are inside a prompt with the given\n" | |
231 | "tag. A procedure means to cut away all frames up to but\n" | |
232 | "excluding the application frame whose procedure matches the\n" | |
233 | "specified one.\n" | |
234 | "\n" | |
b7e64f8b | 235 | "Each @var{outer_cut_i} can be an integer, a prompt tag, or a\n" |
06dcb9df AW |
236 | "procedure. An integer means to cut away that number of frames.\n" |
237 | "A prompt tag means to cut away all frames that are outside a\n" | |
238 | "prompt with the given tag. A procedure means to cut away\n" | |
239 | "frames down to but excluding the application frame whose\n" | |
240 | "procedure matches the specified one.\n" | |
241 | "\n" | |
b7e64f8b | 242 | "If the @var{outer_cut_i} of the last pair is missing, it is\n" |
baffb19f | 243 | "taken as 0.") |
1bbd0b84 | 244 | #define FUNC_NAME s_scm_make_stack |
782d171c | 245 | { |
aa3f6951 | 246 | long n; |
aa3f6951 | 247 | SCM frame; |
14aa25e4 | 248 | SCM stack; |
af45e3b0 | 249 | SCM inner_cut, outer_cut; |
f6f88e0d MD |
250 | |
251 | /* Extract a pointer to the innermost frame of whatever object | |
252 | scm_make_stack was given. */ | |
bc36d050 | 253 | if (scm_is_eq (obj, SCM_BOOL_T)) |
782d171c | 254 | { |
aa3f6951 AW |
255 | SCM cont; |
256 | struct scm_vm_cont *c; | |
257 | ||
9ede013f | 258 | cont = scm_i_capture_current_stack (); |
aa3f6951 AW |
259 | c = SCM_VM_CONT_DATA (cont); |
260 | ||
89b235af AW |
261 | frame = scm_c_make_frame (cont, |
262 | (c->fp + c->reloc) - c->stack_base, | |
263 | (c->sp + c->reloc) - c->stack_base, | |
264 | c->ra); | |
13dcb666 | 265 | } |
b1b942b7 | 266 | else if (SCM_VM_FRAME_P (obj)) |
aa3f6951 | 267 | frame = obj; |
13dcb666 | 268 | else if (SCM_CONTINUATIONP (obj)) |
06dcb9df AW |
269 | /* FIXME: Narrowing to prompt tags should narrow with respect to the prompts |
270 | that were in place when the continuation was captured. */ | |
1d1cae0e | 271 | frame = scm_i_continuation_to_frame (obj); |
13dcb666 DH |
272 | else |
273 | { | |
274 | SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); | |
275 | /* not reached */ | |
782d171c MD |
276 | } |
277 | ||
93dbc31b AW |
278 | /* FIXME: is this even possible? */ |
279 | if (scm_is_true (frame) | |
d798a895 | 280 | && SCM_PROGRAM_P (scm_frame_procedure (frame)) |
93dbc31b AW |
281 | && SCM_PROGRAM_IS_BOOT (scm_frame_procedure (frame))) |
282 | frame = scm_frame_previous (frame); | |
283 | ||
aa3f6951 | 284 | if (scm_is_false (frame)) |
14aa25e4 AW |
285 | return SCM_BOOL_F; |
286 | ||
f6f88e0d MD |
287 | /* Count number of frames. Also get stack id tag and check whether |
288 | there are more stackframes than we want to record | |
289 | (SCM_BACKTRACE_MAXDEPTH). */ | |
06dcb9df | 290 | n = stack_depth (frame); |
782d171c | 291 | |
f6f88e0d | 292 | /* Make the stack object. */ |
aa3f6951 AW |
293 | stack = scm_make_struct (scm_stack_type, SCM_INUM0, SCM_EOL); |
294 | SCM_SET_STACK_LENGTH (stack, n); | |
06dcb9df | 295 | SCM_SET_STACK_ID (stack, scm_stack_id (obj)); |
aa3f6951 AW |
296 | SCM_SET_STACK_FRAME (stack, frame); |
297 | ||
f6f88e0d | 298 | /* Narrow the stack according to the arguments given to scm_make_stack. */ |
af45e3b0 | 299 | SCM_VALIDATE_REST_ARGUMENT (args); |
d2e53ed6 | 300 | while (n > 0 && !scm_is_null (args)) |
f6f88e0d MD |
301 | { |
302 | inner_cut = SCM_CAR (args); | |
303 | args = SCM_CDR (args); | |
d2e53ed6 | 304 | if (scm_is_null (args)) |
af45e3b0 | 305 | { |
13dcb666 | 306 | outer_cut = SCM_INUM0; |
af45e3b0 DH |
307 | } |
308 | else | |
f6f88e0d MD |
309 | { |
310 | outer_cut = SCM_CAR (args); | |
311 | args = SCM_CDR (args); | |
312 | } | |
f6f88e0d MD |
313 | |
314 | narrow_stack (stack, | |
99d7688b NL |
315 | inner_cut, |
316 | outer_cut); | |
f6f88e0d | 317 | |
aa3f6951 | 318 | n = SCM_STACK_LENGTH (stack); |
f6f88e0d MD |
319 | } |
320 | ||
7115d1e4 | 321 | if (n > 0) |
b1b942b7 | 322 | return stack; |
7115d1e4 MD |
323 | else |
324 | return SCM_BOOL_F; | |
782d171c | 325 | } |
1bbd0b84 | 326 | #undef FUNC_NAME |
782d171c | 327 | |
a1ec6916 | 328 | SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, |
1bbd0b84 | 329 | (SCM stack), |
b380b885 | 330 | "Return the identifier given to @var{stack} by @code{start-stack}.") |
1bbd0b84 | 331 | #define FUNC_NAME s_scm_stack_id |
66f45472 | 332 | { |
06dcb9df AW |
333 | if (scm_is_eq (stack, SCM_BOOL_T) |
334 | /* FIXME: frame case assumes frame still live on the stack, and no | |
335 | intervening start-stack. Hmm... */ | |
336 | || SCM_VM_FRAME_P (stack)) | |
7115d1e4 | 337 | { |
06dcb9df AW |
338 | /* Fetch most recent start-stack tag. */ |
339 | SCM stacks = scm_fluid_ref (scm_sys_stacks); | |
340 | return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F; | |
13dcb666 DH |
341 | } |
342 | else if (SCM_CONTINUATIONP (stack)) | |
06dcb9df AW |
343 | /* FIXME: implement me */ |
344 | return SCM_BOOL_F; | |
13dcb666 DH |
345 | else |
346 | { | |
14aa25e4 AW |
347 | SCM_WRONG_TYPE_ARG (SCM_ARG1, stack); |
348 | /* not reached */ | |
13dcb666 | 349 | } |
66f45472 | 350 | } |
1bbd0b84 | 351 | #undef FUNC_NAME |
66f45472 | 352 | |
a1ec6916 | 353 | SCM_DEFINE (scm_stack_ref, "stack-ref", 2, 0, 0, |
13dcb666 DH |
354 | (SCM stack, SCM index), |
355 | "Return the @var{index}'th frame from @var{stack}.") | |
1bbd0b84 | 356 | #define FUNC_NAME s_scm_stack_ref |
782d171c | 357 | { |
13dcb666 | 358 | unsigned long int c_index; |
aa3f6951 | 359 | SCM frame; |
13dcb666 DH |
360 | |
361 | SCM_VALIDATE_STACK (1, stack); | |
a55c2b68 | 362 | c_index = scm_to_unsigned_integer (index, 0, SCM_STACK_LENGTH(stack)-1); |
aa3f6951 AW |
363 | frame = SCM_STACK_FRAME (stack); |
364 | while (c_index--) | |
93dbc31b | 365 | frame = scm_frame_previous (frame); |
aa3f6951 | 366 | return frame; |
782d171c | 367 | } |
1bbd0b84 | 368 | #undef FUNC_NAME |
782d171c | 369 | |
3b3b36dd | 370 | SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, |
67941e3c MG |
371 | (SCM stack), |
372 | "Return the length of @var{stack}.") | |
1bbd0b84 | 373 | #define FUNC_NAME s_scm_stack_length |
782d171c | 374 | { |
34d19ef6 | 375 | SCM_VALIDATE_STACK (1, stack); |
aa3f6951 | 376 | return scm_from_long (SCM_STACK_LENGTH (stack)); |
782d171c | 377 | } |
1bbd0b84 | 378 | #undef FUNC_NAME |
782d171c MD |
379 | |
380 | \f | |
381 | ||
382 | void | |
383 | scm_init_stacks () | |
384 | { | |
06dcb9df AW |
385 | scm_sys_stacks = scm_make_fluid (); |
386 | scm_c_define ("%stacks", scm_sys_stacks); | |
387 | ||
f39448c5 AW |
388 | scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT), |
389 | SCM_UNDEFINED); | |
cc95e00a | 390 | scm_set_struct_vtable_name_x (scm_stack_type, |
4a655e50 | 391 | scm_from_latin1_symbol ("stack")); |
a0599745 | 392 | #include "libguile/stacks.x" |
782d171c | 393 | } |
89e00824 ML |
394 | |
395 | /* | |
396 | Local Variables: | |
397 | c-file-style: "gnu" | |
398 | End: | |
399 | */ |