summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/ChangeLog33
-rw-r--r--libguile/backtrace.c35
-rw-r--r--libguile/init.c2
-rw-r--r--libguile/options.c3
-rw-r--r--libguile/root.c1
-rw-r--r--libguile/root.h5
-rw-r--r--libguile/symbols.c23
-rw-r--r--libguile/symbols.h1
8 files changed, 91 insertions, 12 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index b4734fee5..9e37fcd5d 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,36 @@
+Mon Feb 10 00:08:08 1997 Mikael Djurfeldt <mdj@kenneth>
+
+ * symbols.c (scm_sysintern0): New function. Contains the core of
+ old scm_sysintern but doesn't take a second value argument.
+ (scm_sysintern): Now uses scm_sysintern0.
+ (scm_sysintern_no_module_lookup): Renamed to
+ scm_sysintern0_no_module_lookup and doesn't take a second value
+ argument any longer.
+
+ * symbols.h (scm_sysintern0: Added declaration.
+
+ * options.c (scm_init_opts): Use scm_sysintern0 instead of
+ scm_sysintern when interning option keys. Otherwise we risk
+ destroying the values of already interned variables.
+
+ * symbols.c (scm_sym2vcell): Bugfix: Treat definedp as
+ scheme-level boolean (use SCM_NFALSEP).
+
+ * backtrace.c (scm_init_backtrace): Make Scheme-level variable
+ `the-last-stack'.
+ (scm_backtrace): New function. (C version of old function from
+ boot-9.scm) Motivation: Make it possible to display backtraces
+ without depending on boot-9.scm. (I'm uncertain if this
+ motivation is good enough...)
+
+ * root.h (scm_root_state): Add member the_last_stack_var.
+ (scm_the_stack_var): Defined to scm_root->the_last_stack_var.
+
+ * root.c (mark_root): Mark scm_the_last_stack_var.
+
+ * init.c (scm_start_stack): Initialize scm_the_last_stack_var to
+ SCM_BOOL_F.
+
Sun Feb 9 18:04:41 1997 Mikael Djurfeldt <mdj@kenneth>
* throw.c (mark_lazy_catch, free_lazy_catch): Removed.
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 365b6ca58..aec7c1622 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -427,10 +427,45 @@ scm_display_backtrace (stack, port, first, depth)
return SCM_UNSPECIFIED;
}
+SCM_GLOBAL (scm_has_shown_backtrace_hint_p_var, "has-shown-backtrace-hint?");
+
+SCM_PROC(s_backtrace, "backtrace", 0, 0, 0, scm_backtrace);
+SCM
+scm_backtrace ()
+{
+ if (SCM_NFALSEP (SCM_CDR (scm_the_last_stack_var)))
+ {
+ scm_newline (scm_cur_outp);
+ scm_display_backtrace (SCM_CDR (scm_the_last_stack_var),
+ scm_cur_outp,
+ SCM_UNDEFINED,
+ SCM_UNDEFINED);
+ scm_newline (scm_cur_outp);
+ if (SCM_FALSEP (SCM_CDR (scm_has_shown_backtrace_hint_p_var))
+ && !SCM_BACKTRACE_P)
+ {
+ scm_gen_puts (scm_regular_string,
+ "Type \"(debug-enable 'backtrace)\" if you would like a backtrace
+automatically if an error occurs in the future.\n",
+ scm_cur_outp);
+ SCM_SETCDR (scm_has_shown_backtrace_hint_p_var, SCM_BOOL_T);
+ }
+ }
+ else
+ {
+ scm_gen_puts (scm_regular_string,
+ "No backtrace available.\n",
+ scm_cur_outp);
+ }
+ return SCM_UNSPECIFIED;
+}
+
void
scm_init_backtrace ()
{
+ scm_the_last_stack_var = scm_sysintern ("the-last-stack", SCM_BOOL_F);
+
#include "backtrace.x"
}
diff --git a/libguile/init.c b/libguile/init.c
index 9929c2e06..edb480a26 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -138,6 +138,8 @@ scm_start_stack (base)
scm_top_level_lookup_closure_var = SCM_BOOL_F;
scm_system_transformer = SCM_BOOL_F;
+ scm_the_last_stack_var = SCM_BOOL_F;
+
/* Create an object to hold the root continuation.
*/
SCM_NEWCELL (scm_rootcont);
diff --git a/libguile/options.c b/libguile/options.c
index ade12e2ee..d0aba0a17 100644
--- a/libguile/options.c
+++ b/libguile/options.c
@@ -211,8 +211,7 @@ scm_init_opts (func, options, n)
for (i = 0; i < n; ++i)
{
- options[i].name = (char *) SCM_CAR (scm_sysintern (options[i].name,
- SCM_UNDEFINED));
+ options[i].name = (char *) SCM_CAR (scm_sysintern0 (options[i].name));
options[i].doc = (char *) scm_permanent_object (scm_take0str
(options[i].doc));
}
diff --git a/libguile/root.c b/libguile/root.c
index 7546ecbd5..f90750802 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -85,6 +85,7 @@ mark_root (root)
scm_gc_mark (s->def_errp);
scm_gc_mark (s->top_level_lookup_closure_var);
scm_gc_mark (s->system_transformer);
+ scm_gc_mark (s->the_last_stack_var);
return SCM_ROOT_STATE (root) -> parent;
}
diff --git a/libguile/root.h b/libguile/root.h
index 6d6ab2b25..2602467ee 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -112,6 +112,8 @@ typedef struct scm_root_state
SCM system_transformer;
SCM top_level_lookup_closure_var;
+ SCM the_last_stack_var;
+
SCM handle; /* The root object for this root state */
SCM parent; /* The parent root object */
} scm_root_state;
@@ -138,7 +140,8 @@ typedef struct scm_root_state
#define scm_top_level_lookup_closure_var \
(scm_root->top_level_lookup_closure_var)
#define scm_system_transformer (scm_root->system_transformer)
-
+#define scm_the_last_stack_var (scm_root->the_last_stack_var)
+
#ifdef USE_THREADS
#define scm_root ((scm_root_state *) SCM_THREAD_LOCAL_DATA)
#define scm_set_root(new_root) SCM_SET_THREAD_LOCAL_DATA (new_root)
diff --git a/libguile/symbols.c b/libguile/symbols.c
index fd1f11a6a..1bd957f7d 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -144,7 +144,7 @@ scm_sym2vcell (sym, thunk, definep)
z = SCM_CAR (lsym);
if (SCM_CAR (z) == sym)
{
- if (definep)
+ if (SCM_NFALSEP (definep))
{
/* Move handle from scm_weak_symhash to scm_symhash. */
*lsymp = SCM_CDR (lsym);
@@ -356,19 +356,16 @@ scm_intern0 (name)
}
-/* Intern the symbol named NAME in scm_symhash, and give it the value VAL.
- NAME is null-terminated. */
+/* Intern the symbol named NAME in scm_symhash, NAME is null-terminated. */
SCM
-scm_sysintern_no_module_lookup (name, val)
+scm_sysintern0_no_module_lookup (name)
char *name;
- SCM val;
{
SCM easy_answer;
SCM_DEFER_INTS;
easy_answer = scm_intern_obarray_soft (name, strlen (name), scm_symhash, 1);
if (SCM_NIMP (easy_answer))
{
- SCM_SETCDR (easy_answer, val);
SCM_ALLOW_INTS;
return easy_answer;
}
@@ -381,7 +378,7 @@ scm_sysintern_no_module_lookup (name, val)
SCM_NEWCELL (lsym);
SCM_SETLENGTH (lsym, (long) len, scm_tc7_ssymbol);
SCM_SETCHARS (lsym, name);
- lsym = scm_cons (lsym, val);
+ lsym = scm_cons (lsym, SCM_UNDEFINED);
SCM_VELTS (scm_symhash)[scm_hash] = scm_cons (lsym, SCM_VELTS (scm_symhash)[scm_hash]);
SCM_ALLOW_INTS;
return lsym;
@@ -402,6 +399,15 @@ scm_sysintern (name, val)
char *name;
SCM val;
{
+ SCM vcell = scm_sysintern0 (name);
+ SCM_SETCDR (vcell, val);
+ return vcell;
+}
+
+SCM
+scm_sysintern0 (name)
+ char *name;
+{
SCM lookup_proc;
if (scm_can_use_top_level_lookup_closure_var &&
SCM_NIMP (lookup_proc = SCM_CDR (scm_top_level_lookup_closure_var)))
@@ -410,11 +416,10 @@ scm_sysintern (name, val)
SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T);
if (vcell == SCM_BOOL_F)
scm_misc_error ("sysintern", "can't define variable", sym);
- SCM_SETCDR (vcell, val);
return vcell;
}
else
- return scm_sysintern_no_module_lookup (name, val);
+ return scm_sysintern0_no_module_lookup (name);
}
SCM_PROC(s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
diff --git a/libguile/symbols.h b/libguile/symbols.h
index 93ac5bf2f..44f154286 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -112,6 +112,7 @@ extern SCM scm_intern_obarray SCM_P ((char *name, scm_sizet len, SCM obarray));
extern SCM scm_intern SCM_P ((char *name, scm_sizet len));
extern SCM scm_intern0 SCM_P ((char * name));
extern SCM scm_sysintern SCM_P ((char *name, SCM val));
+extern SCM scm_sysintern0 SCM_P ((char *name));
extern SCM scm_symbol_p SCM_P ((SCM x));
extern SCM scm_symbol_to_string SCM_P ((SCM s));
extern SCM scm_string_to_symbol SCM_P ((SCM s));