stacks.c 21 KB

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