summaryrefslogtreecommitdiffstats
path: root/debug.c
diff options
context:
space:
mode:
authorLaMont Jones <lamont@debian.org>2003-05-07 08:36:40 -0600
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commite21d47d7813159bb71e0671df9b52ec0470c358d (patch)
tree3c7770ea846123c291f599044e9f234ac17616bb /debug.c
parent8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (diff)
parentdeda2c0fd8689349fea2a900199a76ff7ecb319e (diff)
downloadscm-e21d47d7813159bb71e0671df9b52ec0470c358d.tar.gz
scm-e21d47d7813159bb71e0671df9b52ec0470c358d.zip
Import Debian changes 5d6-3.2debian/5d6-3.2
scm (5d6-3.2) unstable; urgency=low * Fix hppa compile. Closes: #144062 scm (5d6-3.1) unstable; urgency=low * NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171 scm (5d6-3) unstable; urgency=low * Add build depend on xlibs-dev (Closes: #148020) scm (5d6-2) unstable; urgency=low * Remove libregexx-dev from build-depends. * Change build to use ./scmlit rather than scmlit (should fix some build problems) (looks like alpha is mostly building) * New release (Closes: #140175) * Built with turtlegraphics last time (Closes: #58515) scm (5d6-1) unstable; urgency=low * New upstream. * Add xlib and turtlegr to requested list of features. (closes some bug) * Make clean actually clean most everything up. * Remove hacks renaming build to something else and just set build as a .PHONY target in debian/rules. * Add the turtlegr code. scm (5d5-1) unstable; urgency=low * New upstream * Has fixes for 64 bit archs. May fix alpha compile problem. Does fix (Closes: #140175) * Take out -O2 arg. scm (5d4-3) unstable; urgency=low * Don't link with regexx, but just use libc6's regular expression functions. * Define (terms) to output /usr/share/common-licenses/GPL (Closes: #119321) scm (5d4-2) unstable; urgency=low * Add texinfo to build depends (Closes: #107011) scm (5d4-1) unstable; urgency=low * New upstream release. * Move install-info --remove to prerm. scm (5d3-5) unstable; urgency=low * Move scm info files to section "The Algorithmic Language Scheme" to match up with guile. scm (5d3-4) unstable; urgency=low * Fix build depends (Closes: #76691) scm (5d3-3) unstable; urgency=low * Fix path in scm dhelp file. scm (5d3-2) unstable; urgency=low * Actually put the header files in the package. Oops. scm (5d3-1) unstable; urgency=low * New upstream. (Closes: #74761) * Make (terms) use new license location. * Make use libregexx rather than librx. * Fix build depends for above. * Using new regex lib seems to fix crash (Closes: #66787) * Consider adding scm-dev package with headers, but instead just add the headers to the scm package. (Closes: #70787) * Add doc-base support.
Diffstat (limited to 'debug.c')
-rw-r--r--debug.c751
1 files changed, 751 insertions, 0 deletions
diff --git a/debug.c b/debug.c
new file mode 100644
index 0000000..22c387b
--- /dev/null
+++ b/debug.c
@@ -0,0 +1,751 @@
+/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING. If not, write to
+ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of SCM.
+ *
+ * The exception is that, if you link the SCM library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the SCM library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name SCM. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * SCM, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for SCM, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.
+ */
+
+/* "debug.c" procedures for displaying and debugging code.
+ Authors: Radey Shouman & Aubrey Jaffer. */
+
+#include "scm.h"
+#include "setjump.h"
+
+long tc16_codeptr; /* Type code for non-executable code
+ wrappers */
+
+static SCM prinhead P((SCM x, SCM port, int writing));
+static void prinbindings P((SCM names, SCM inits, SCM init_env,
+ SCM steps, SCM step_env, SCM port, int writing));
+
+SCM scm_env_rlookup(addr, stenv, what)
+ SCM addr, stenv;
+ char *what;
+{
+ SCM env, fr;
+ int icdrp;
+ unsigned int idist, iframe;
+ if (IMP(addr)) {
+ if (!ILOCP(addr)) return BOOL_F;
+ iframe = IFRAME(addr);
+ idist = IDIST(addr);
+ icdrp = ICDRP(addr) && 1;
+ }
+ else {
+ if (!ISYMP(CAR(addr))) return BOOL_F;
+ icdrp = 0;
+ switch (ISYMNUM(CAR(addr))) {
+ default: return BOOL_F;
+ case (ISYMNUM(IM_FARLOC_CDR)):
+ icdrp = 1;
+ case (ISYMNUM(IM_FARLOC_CAR)):
+ fr = CDR(addr);
+ iframe = INUM(CAR(fr));
+ idist = INUM(CDR(fr));
+ break;
+ }
+ }
+ for (env = stenv; NIMP(env); env = CDR(env)) {
+ fr = CAR(env);
+ if (INUMP(fr)) {
+ ASSERT(NIMP(env) && CONSP(env), stenv, s_badenv, what);
+ env = CDR(env);
+ continue;
+ }
+ if (SCM_LINUMP(fr)) continue;
+ if (NIMP(fr) && CONSP(fr) && IMP(CAR(fr))) continue;
+ if (0==iframe--) {
+ while (idist--) {
+ if (IMP(fr) || NCONSP(fr)) return BOOL_F;
+ fr = CDR(fr);
+ }
+ if (!icdrp) {
+ if (NIMP(fr) && CONSP(fr))
+ fr = CAR(fr);
+ else
+ fr = BOOL_F;
+ }
+ if (NIMP(fr) && IDENTP(fr)) return fr;
+ return BOOL_F;
+ }
+ }
+ return BOOL_F;
+}
+
+SCM scm_env_addprop(prop, val, env)
+ SCM prop, val, env;
+{
+ if (UNBNDP(prop)) return env;
+ return cons2(prop, val, env);
+}
+
+SCM scm_env_getprop(prop, env)
+ SCM prop, env;
+{
+ SCM e = env;
+ if (!UNBNDP(prop)) {
+ while (NIMP(e)) {
+ if (INUMP(CAR(e))) {
+ if (CAR(e)==prop) return CDR(e);
+ e = CDR(e);
+ ASSERT(NIMP(e), env, s_badenv, "env_getprop");
+ }
+ e = CDR(e);
+ }
+ }
+ return BOOL_F;
+}
+
+static SCM prinhead(x, port, writing)
+ SCM x, port;
+ int writing;
+{
+ lputc('(', port);
+ iprin1(CAR(x), port, writing);
+ lputc(' ', port);
+ return CDR(x);
+}
+
+static void prinbindings(names, inits, init_env,
+ steps, step_env, port, writing)
+ SCM names, inits, init_env, steps, step_env, port;
+ int writing;
+{
+ lputc('(', port);
+ while (NIMP(names) && NIMP(inits)) {
+ lputc('(', port);
+ iprin1(CAR(names), port, writing);
+ lputc(' ', port);
+ scm_princode(CAR(inits), init_env, port, writing);
+ if (NIMP(steps)) {
+ lputc(' ', port);
+ scm_princode(CAR(steps), step_env, port, writing);
+ steps = CDR(steps);
+ }
+ lputc(')', port);
+ names = CDR(names);
+ inits = CDR(inits);
+ if (NIMP(names)) lputc(' ', port);
+ }
+ lputs(") ", port);
+}
+
+void scm_princode(code, env, port, writing)
+ SCM code, env, port;
+ int writing;
+{
+ SCM oenv = env, name, init, bdgs, x = code;
+ if (UNBNDP(env)) {
+ iprin1(code, port, writing);
+ return;
+ }
+ tail:
+ if (IMP(x)) {
+ if (ILOCP(x)) {
+ local:
+ name = scm_env_rlookup(x, env, "princode");
+ if (FALSEP(name)) goto gencase;
+ lputs("#@", port);
+ iprin1(name, port, writing);
+ return;
+ }
+ else
+ goto gencase;
+ }
+ if (SCM_GLOCP(x)) {
+ iprin1(x, port, writing);
+ return;
+ }
+ switch (TYP7(x)) {
+ default: gencase:
+ iprin1(x, port, writing);
+ return;
+ gencode:
+ case tcs_cons_gloc:
+ case tcs_cons_nimcar:
+ case tcs_cons_iloc:
+ case (127 & IM_OR): case (127 & IM_AND): case (127 & IM_BEGIN):
+ case (127 & IM_SET): case (127 & IM_COND): case (127 & IM_CASE):
+ case (127 & IM_IF):
+ lputc('(', port);
+ scm_princode(CAR(x), env, port, writing);
+ body:
+ x = CDR(x);
+ no_cdr:
+ for (; NNULLP(x); x = CDR(x)) {
+ if (IMP(x) || NECONSP(x)) {
+ lputs(" . ", port);
+ iprin1(x, port, writing);
+ break;
+ }
+ lputc(' ', port);
+ scm_princode(CAR(x), env, port, writing);
+ }
+ lputc(')', port);
+ return;
+ case (127 & IM_LAMBDA):
+ x = prinhead(x, port, writing);
+ env = CAR(x);
+ bdgs = SCM_ENV_FORMALS(env);
+ if (IMP(bdgs) || NECONSP(bdgs))
+ iprin1(bdgs, port, writing);
+ else {
+ lputc('(', port);
+ while (!0) {
+ if (NECONSP(bdgs)) break;
+ iprin1(CAR(bdgs), port, writing);
+ if (NIMP(bdgs = CDR(bdgs)))
+ lputc(' ', port);
+ else break;
+ }
+ if (NIMP(bdgs)) {
+ lputs(". ", port);
+ iprin1(bdgs, port, writing);
+ }
+ lputc(')', port);
+ }
+ goto body;
+ case (127 & IM_LETREC):
+ case (127 & IM_LET):
+ x = prinhead(x, port, writing);
+ env = CAR(x);
+ prinbindings(SCM_ENV_FORMALS(env),
+ CAR(CDR(x)), (TYP7(x)==(127 & IM_LET) ? oenv: env),
+ UNDEFINED, UNDEFINED, port, writing);
+ x = CDR(x);
+ goto body;
+ case (127 & IM_LETSTAR):
+ x = prinhead(x, port, writing);
+ lputc('(', port);
+ if (NIMP(bdgs = CAR(x))) {
+ oenv = CAR(bdgs);
+ bdgs = CDR(bdgs);
+ while (!0) {
+ init = CAR(bdgs);
+ bdgs = CDR(bdgs);
+ env = CAR(bdgs);
+ lputc('(', port);
+ iprin1(SCM_ENV_FORMALS(env), port, writing);
+ lputc(' ', port);
+ scm_princode(init, oenv, port, writing);
+ oenv = env;
+ lputc(')', port);
+ if (IMP(bdgs = CDR(bdgs)))
+ break;
+ lputc(' ', port);
+ }
+ }
+ lputs(") ", port);
+ goto body;
+ case (127 & IM_DO):
+ {
+ /* (#@do (env (init ...) (test ...) (body ...) step ...)) */
+ SCM test, steps;
+ x = prinhead(x, port, writing);
+ env = CAR(x);
+ x = CDR(x);
+ init = CAR(x);
+ x = CDR(x);
+ test = CAR(x);
+ x = CDR(x);
+ steps = CDR(x);
+ x = CAR(x);
+ prinbindings(SCM_ENV_FORMALS(env), init, oenv, steps, env,
+ port, writing);
+ scm_princode(test, env, port, writing);
+ lputc(' ', port);
+ goto no_cdr;
+ }
+ case (127 & IM_FUNCALL):
+ lputc('(', port);
+ x = CDR(x);
+ scm_princode(CAR(x), env, port, writing);
+ goto body;
+ case (127 & MAKISYM(0)):
+ if (!ISYMP(CAR(x))) goto gencode;
+ switch (ISYMNUM(CAR(x))) {
+ default:
+ goto gencode;
+ case ISYMNUM(IM_LINUM):
+ x = CDR(x);
+ goto tail;
+ case ISYMNUM(IM_FARLOC_CAR):
+ case ISYMNUM(IM_FARLOC_CDR):
+ goto local;
+ }
+ }
+}
+
+void scm_princlosure(proc, port, writing)
+ SCM proc, port;
+ int writing;
+{
+ SCM env, linum = UNDEFINED;
+ proc = CODE(proc);
+ lputs("#<CLOSURE ", port);
+ env = CAR(proc);
+#ifdef CAUTIOUS
+ if (NIMP(env=scm_env_getprop(SCM_ENV_PROCNAME, env))) {
+ iprin1(CAR(env), port, 1);
+ lputc(' ', port);
+ env = CDR(env);
+ if (NIMP(env) && SCM_LINUMP(CAR(env)))
+ linum = CAR(env);
+ }
+ else
+ lputs("<anon> ", port);
+ env = CAR(proc);
+ if (NIMP(env=scm_env_getprop(SCM_ENV_FILENAME, env)))
+ scm_line_msg(CAR(env), linum, port);
+#endif
+ env = CAR(proc);
+ iprin1(SCM_ENV_FORMALS(env), port, writing);
+ if (writing) {
+ for(proc = CDR(proc); NIMP(proc); proc = CDR(proc)) {
+ lputc(' ', port);
+ scm_princode(CAR(proc), env, port, writing);
+ }
+ }
+ lputc('>', port);
+}
+
+static char s_int2linum[] = "integer->line-number";
+SCM scm_int2linum(n)
+ SCM n;
+{
+ int i = INUM(n);
+ ASSERT(INUMP(n) && i >= 0, n, ARG1, s_int2linum);
+ return SCM_MAKE_LINUM(i);
+}
+
+static char s_linum2int[] = "line-number->integer";
+SCM scm_linum2int(linum)
+ SCM linum;
+{
+ ASSERT(SCM_LINUMP(linum), linum, ARG1, s_linum2int);
+ return MAKINUM(SCM_LINUM(linum));
+}
+
+SCM scm_linump(obj)
+ SCM obj;
+{
+ return SCM_LINUMP(obj) ? BOOL_T : BOOL_F;
+}
+
+static char s_remove_linums[] = "remove-line-numbers!";
+SCM scm_remove_linums(x)
+ SCM x;
+{
+ SCM ret = x;
+ SCM *px = &ret;
+ tail:
+ x = *px;
+ if (IMP(x)) return ret;
+ if (CONSP(x)) {
+ if (SCM_LINUMP(CAR(x))) {
+ *px = CDR(x);
+ px = &CDR(x);
+ goto tail;
+ }
+ if (NIMP(CAR(x)))
+ CAR(x) = scm_remove_linums(CAR(x));
+ px = &CDR(x);
+ goto tail;
+ }
+ else if (VECTORP(x)) {
+ SCM *ve = VELTS(x);
+ sizet i = LENGTH(x);
+ while (i--) {
+ if (NIMP(ve[i]))
+ ve[i] = scm_remove_linums(ve[i]);
+ }
+ return ret;
+ }
+ else
+ return ret;
+}
+
+#ifdef CAUTIOUS
+long num_frames(estk, i)
+ SCM estk;
+ int i;
+{
+ long n = 0;
+ while NIMP(estk) {
+ n += (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
+ i = INUM(SCM_ESTK_PARENT_INDEX(estk));
+ estk = SCM_ESTK_PARENT(estk);
+ }
+ return n;
+}
+
+SCM *estk_frame(estk, i, nf)
+ SCM estk;
+ int i, nf;
+{
+ int n;
+ /* Make this 1-based, because continuations have an extra frame at
+ the top of the estk. */
+ nf -= 1;
+ while NIMP(estk) {
+ n = (i - SCM_ESTK_BASE)/SCM_ESTK_FRLEN;
+ if (nf <= n) return &(VELTS(estk)[i - nf*SCM_ESTK_FRLEN]);
+ nf -= n;
+ i = INUM(SCM_ESTK_PARENT_INDEX(estk));
+ estk = SCM_ESTK_PARENT(estk);
+ }
+ return (SCM *)0;
+}
+
+SCM stacktrace1(estk, i)
+ SCM estk;
+ int i;
+{
+ SCM *frame, env, ste, lste = UNDEFINED;
+ int n, nf = num_frames(estk, i);
+ int nbrk1 = 7, nbrk2 = nf - 6;
+ if (nf <= 0) return BOOL_F;
+ lputs("\n;STACK TRACE", cur_errp);
+ for (n = 1; n <= nf; n++) {
+ if ((0 <= nbrk1--) || n >= nbrk2) {
+ if (!(frame = estk_frame(estk, i, n))) continue;
+ if (BOOL_F==(ste = frame[3])) continue;
+ env = frame[2];
+ if (ste != lste) {
+ lste = ste;
+ if (reset_safeport(sys_safep, 65, cur_errp)) {
+ /* The usual C setjmp, not SCM's setjump. */
+ if (0==setjmp(SAFEP_JMPBUF(sys_safep))) {
+ lputc('\n', cur_errp);
+ intprint((long)n, -10, sys_safep);
+ lputs("; ", sys_safep);
+ scm_princode(ste, env, sys_safep, 1);
+ }
+ }
+ }
+ else {
+ lputs("\n...", cur_errp);
+ break;
+ }
+ }
+ }
+ lputc('\n', cur_errp);
+ return BOOL_T;
+}
+
+SCM *cont_frame(contin, nf)
+ SCM contin;
+ int nf;
+{
+ CONTINUATION *cont = CONT(contin);
+ SCM estk = cont->other.estk;
+ int i = LENGTH(estk) - SCM_ESTK_FRLEN;
+ if (0 == nf) return cont->other.stkframe;
+ return estk_frame(estk, i, nf);
+}
+
+static char s_stack_trace[] = "stack-trace";
+SCM scm_stack_trace(contin)
+ SCM contin;
+{
+ SCM estk;
+ int i;
+ if (UNBNDP(contin)) {
+ estk = scm_estk;
+ i = (scm_estk_ptr - VELTS(scm_estk));
+ }
+ else {
+ CONTINUATION *cont;
+ ASSERT(NIMP(contin) && (tc7_contin==TYP7(contin)), contin, ARG1,
+ s_stack_trace);
+ cont = CONT(contin);
+ estk = cont->other.estk;
+ i = LENGTH(estk) - SCM_ESTK_FRLEN;
+ }
+ return stacktrace1(estk, i);
+}
+
+static char s_frame_trace[] = "frame-trace";
+SCM scm_frame_trace(contin, nf)
+ SCM contin, nf;
+{
+ SCM *stkframe, code, env;
+ ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+ s_frame_trace);
+ ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_trace);
+ if (!(stkframe = cont_frame(contin, INUM(nf))))
+ return BOOL_F;
+ env = stkframe[2];
+ code = stkframe[3];
+ scm_princode(code, env, cur_errp, 1);
+ scm_scope_trace(env);
+ return UNSPECIFIED;
+}
+
+static char s_frame2env[] = "frame->environment";
+SCM scm_frame2env(contin, nf)
+ SCM contin, nf;
+{
+ SCM *stkframe;
+ ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+ s_frame2env);
+ ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame2env);
+ if (!(stkframe = cont_frame(contin, INUM(nf))))
+ return BOOL_F;
+ return stkframe[2];
+}
+
+static char s_frame_eval[] = "frame-eval";
+SCM scm_frame_eval(contin, nf, expr)
+ SCM contin, nf, expr;
+{
+ SCM res, env, *stkframe;
+ ASSERT(NIMP(contin) && tc7_contin==TYP7(contin), contin, ARG1,
+ s_frame_eval);
+ ASSERT(INUMP(nf) && INUM(nf) >= 0, nf, ARG2, s_frame_eval);
+ if (!(stkframe = cont_frame(contin, INUM(nf))))
+ return BOOL_F;
+ env = stkframe[2];
+ if (IMP(expr)) return expr;
+ DEFER_INTS_EGC;
+ res = ceval(expr, env, stkframe[0]);
+ ALLOW_INTS_EGC;
+ return res;
+}
+
+#endif
+
+static char s_scope_trace[] = "scope-trace";
+SCM scm_scope_trace(env)
+ SCM env;
+{
+ SCM ef, file = UNDEFINED;
+ int fprinted = 0;
+ if (UNBNDP(env))
+ env = scm_current_env();
+ else if (NIMP(env) && CLOSUREP(env))
+ env = CAR(CODE(env));
+ if (scm_nullenv_p(env))
+ lputs("\n; in top level environment.", cur_errp);
+ else
+ lputs("\n; in scope:", cur_errp);
+#ifdef CAUTIOUS
+ if (NIMP(ef=scm_env_getprop(SCM_ENV_FILENAME, env))) {
+ file = CAR(ef);
+ }
+#endif
+ for (; NIMP(env); env = CDR(env)) {
+ if (NCONSP(env)) {
+ badenv:
+ lputs("\n; corrupted environment ", cur_errp);
+ iprin1(env, cur_errp, 1);
+ return UNSPECIFIED;
+ }
+ ef = CAR(env);
+ if (SCM_LINUMP(ef)) {
+ lputs("\n; ", cur_errp);
+ scm_line_msg(file, ef, cur_errp);
+ fprinted++;
+ }
+ else if (INUMP(ef)) {
+ ASRTGO(NIMP(env) && CONSP(env), badenv);
+ env = CDR(env);
+#ifdef CAUTIOUS
+ switch (ef) {
+ default: break;
+ case SCM_ENV_PROCNAME:
+ lputs(" procedure ", cur_errp);
+ iprin1(CAR(env), cur_errp, 1);
+ break;
+ }
+#endif
+ }
+ else if (NIMP(ef) && CONSP(ef) && NIMP(CAR(ef)) && CONSP(CAR(ef))) {
+ lputs("\n; ", cur_errp);
+ iprin1(CAR(ef), cur_errp, 1);
+ lputs(" syntax bindings", cur_errp);
+ }
+ else {
+ lputs("\n; ", cur_errp);
+ iprin1(ef, cur_errp, 1);
+ }
+ }
+#ifdef CAUTIOUS
+ if (NIMP(file) && !fprinted) {
+ lputs("\n; defined by ", cur_errp);
+ if (NIMP(file) && STRINGP(file))
+ lputs("load: ", cur_errp);
+ iprin1(file, cur_errp, 1);
+ lputc('\n', cur_errp);
+ }
+#endif
+ return UNSPECIFIED;
+}
+
+static char s_env_annotation[] = "environment-annotation";
+SCM scm_env_annotation(var, stenv)
+ SCM var, stenv;
+{
+ SCM s, frame, env = stenv;
+#ifdef MACRO
+ SCM mark = IDENT_ENV(var);
+ if (NIMP(mark)) mark = CAR(mark);
+#endif
+ for (; NIMP(env); env = CDR(env)) {
+ frame = CAR(env);
+#ifdef MACRO
+ if (frame==mark) {
+ var = IDENT_PARENT(var);
+ mark = IDENT_ENV(var);
+ if (NIMP(mark)) mark = CAR(mark);
+ }
+#endif
+ if (IMP(frame)) {
+ if (INUMP(frame)) {
+#ifndef RECKLESS
+ if (!(NIMP(env) && CONSP(env))) {
+ badenv: wta(stenv, s_badenv, s_env_annotation);
+ }
+#endif
+ env = CDR(env);
+ }
+ continue;
+ }
+#ifdef MACRO
+ if (NIMP(frame) && CONSP(frame) && BOOL_F==CAR(frame)) {
+ /* syntax binding */
+ s = assq(var, CDR(frame));
+ if (NIMP(s)) goto local_out;
+ continue;
+ }
+#endif
+ for (; NIMP(frame); frame = CDR(frame)) {
+ if (NCONSP(frame)) {
+ if (var==frame)
+ goto local_out;
+ break;
+ }
+ if (CAR(frame)==var) {
+ local_out:
+ env = CDR(env);
+ if (IMP(env)) return BOOL_T;
+ if (SCM_ENV_ANNOTATION != CAR(env)) return BOOL_T;
+ env = CDR(env);
+ ASRTGO(NIMP(env), badenv);
+ s = assq(var, CAR(env));
+ if (NIMP(s)) return s;
+ return BOOL_T;
+ }
+ ASRTGO(CONSP(frame), badenv);
+ }
+ }
+ ASRTGO(NULLP(env), badenv);
+ return BOOL_F;
+}
+
+/* This is to be used for code backpointers to go into environments,
+ allowing run-time reporting of error line numbers. */
+SCM scm_wrapcode(code, env)
+ SCM code, env;
+{
+ SCM z, x = cons(env, code);
+ NEWCELL(z);
+ CDR(z) = x;
+ CAR(z) = tc16_codeptr;
+ return z;
+}
+
+static int princodeptr(exp, port, writing)
+ SCM exp;
+ SCM port;
+ int writing;
+{
+ SCM env = CAR(CDR(exp));
+ lputs("#<code ", port);
+ exp = CDR(CDR(exp));
+ if (IMP(exp) || NCONSP(exp))
+ scm_princode(exp, env, port, writing);
+ else {
+ while (!0) {
+ if (IMP(exp) || NCONSP(exp)) break;
+ scm_princode(CAR(exp), env, port, writing);
+ lputc(' ', port);
+ exp = CDR(exp);
+ }
+ if (NNULLP(exp)) {
+ lputs(" . ", port);
+ scm_princode(exp, env, port, writing);
+ }
+ }
+ lputc('>', port);
+ return !0;
+}
+
+static smobfuns codesmob = {markcdr, free0, princodeptr};
+
+static iproc subr1os[] = {
+ {s_scope_trace, scm_scope_trace},
+#ifdef CAUTIOUS
+ {s_stack_trace, scm_stack_trace},
+#endif
+ {0, 0}};
+
+static iproc subr1s[] = {
+ {s_int2linum, scm_int2linum},
+ {"line-number?", scm_linump},
+ {s_linum2int, scm_linum2int},
+ {s_remove_linums, scm_remove_linums},
+ {0, 0}};
+
+static iproc subr2s[] = {
+ {s_env_annotation, scm_env_annotation},
+#ifdef CAUTIOUS
+ {s_frame_trace, scm_frame_trace},
+ {s_frame2env, scm_frame2env},
+#endif
+ {0, 0}};
+
+void init_debug()
+{
+ tc16_codeptr = newsmob(&codesmob);
+ init_iprocs(subr1os, tc7_subr_1o);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2s, tc7_subr_2);
+#ifdef CAUTIOUS
+ make_subr(s_frame_eval, tc7_subr_3, scm_frame_eval);
+#endif
+}