diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1997-02-10 01:01:54 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 1997-02-10 01:01:54 +0000 |
commit | 5aab5d961cbe871a28e733fa21a3e7558c34f078 (patch) | |
tree | 4a2f1e96ba490bddf226ceeafb6bbd08354330bd | |
parent | b6b72ebaaaecb3a2ea54dd0c6bbfbc7f8e230f27 (diff) | |
download | guile-5aab5d961cbe871a28e733fa21a3e7558c34f078.tar.gz |
* 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.
-rw-r--r-- | libguile/ChangeLog | 33 | ||||
-rw-r--r-- | libguile/backtrace.c | 35 | ||||
-rw-r--r-- | libguile/init.c | 2 | ||||
-rw-r--r-- | libguile/options.c | 3 | ||||
-rw-r--r-- | libguile/root.c | 1 | ||||
-rw-r--r-- | libguile/root.h | 5 | ||||
-rw-r--r-- | libguile/symbols.c | 23 | ||||
-rw-r--r-- | libguile/symbols.h | 1 |
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)); |