diff options
| -rw-r--r-- | eval.c | 71 | ||||
| -rw-r--r-- | eval.h | 2 | ||||
| -rw-r--r-- | share/txr/stdlib/debugger.tl | 11 | ||||
| -rw-r--r-- | unwind.c | 40 | ||||
| -rw-r--r-- | unwind.h | 6 |
5 files changed, 93 insertions, 37 deletions
@@ -106,7 +106,7 @@ val eval_only_s, compile_only_s; val special_s, unbound_s; val whole_k, form_k, symacro_k; -val last_form_evaled, last_form_expanded; +val last_form_evaled; val call_f; @@ -359,6 +359,7 @@ val set_last_form_evaled(val form) void error_trace(val exsym, val exvals, val out_stream, val prefix) { val last = last_form_evaled; + val xlast = uw_last_form_expanded(); val info = source_loc_str(last, nil); if (cdr(exvals) || !stringp(car(exvals))) @@ -401,23 +402,23 @@ void error_trace(val exsym, val exvals, val out_stream, val prefix) } } - if (last_form_expanded) { - val ex_info = source_loc_str(last_form_expanded, nil); - val form = last_form_expanded; + if (xlast) { + val ex_info = source_loc_str(xlast, nil); + val form = xlast; if (ex_info) format(out_stream, lit("~a during expansion at ~a of form ~!~s\n"), - prefix, ex_info, last_form_expanded, nao); + prefix, ex_info, xlast, nao); else format(out_stream, lit("~a during expansion of form ~!~s\n"), - prefix, last_form_expanded, nao); + prefix, xlast, nao); if (info) format(out_stream, lit("~a by macro code located at ~a\n"), prefix, info, nao); for (;;) { - val origin = lookup_origin(form); + val origin = lookup_origin(xlast); val oinfo = source_loc_str(origin, nil); if (origin) { @@ -1433,13 +1434,11 @@ val funcall_interp(val interp_fun, struct args *args) static val expand_eval(val form, val env) { val lfe_save = last_form_evaled; - val lfx_save = last_form_expanded; - val form_ex = (last_form_expanded = last_form_evaled = nil, + val form_ex = (last_form_evaled = nil, expand(form, nil)); val loading = cdr(lookup_var(dyn_env, load_recursive_s)); val ret = ((void) (loading || uw_release_deferred_warnings()), eval(form_ex, default_null_arg(env), form)); - last_form_expanded = lfx_save; last_form_evaled = lfe_save; return ret; } @@ -2389,7 +2388,7 @@ static val expand_lisp1_setq(val form, val menv) eval_error(form, lit("~s: misapplied to form ~s"), op, sym, nao); if (!lookup_var(nil, sym) && !lookup_fun(nil, sym)) - eval_defr_warn(last_form_expanded, + eval_defr_warn(uw_last_form_expanded(), cons(var_s, sym), lit("~s: unbound variable/function ~s"), op, sym, nao); @@ -2421,7 +2420,7 @@ static val expand_setqf(val form, val menv) eval_error(form, lit("~s: cannot assign lexical function ~s"), op, sym, nao); if (!lookup_fun(nil, sym)) - eval_defr_warn(last_form_expanded, + eval_defr_warn(uw_last_form_expanded(), cons(fun_s, sym), lit("~s: unbound function ~s"), op, sym, nao); @@ -3310,7 +3309,7 @@ tail: !uw_tentative_def_exists(cons(var_s, form)) && !uw_tentative_def_exists(cons(fun_s, form))) { - eval_defr_warn(last_form_expanded, + eval_defr_warn(uw_last_form_expanded(), cons(sym_s, form), lit("unbound variable/function ~s"), form, nao); } @@ -4535,7 +4534,7 @@ again: return expand(rlcp_tree(symac, form), menv); } if (!lookup_var(menv, form)) - eval_defr_warn(last_form_expanded, + eval_defr_warn(uw_last_form_expanded(), cons(var_s, form), lit("unbound variable ~s"), form, nao); return form; @@ -4710,13 +4709,13 @@ again: } if (!lookup_fun(menv, arg)) { if (special_operator_p(arg)) - eval_warn(last_form_expanded, + eval_warn(uw_last_form_expanded(), lit("fun used on special operator ~s"), arg, nao); else if (!bindable(arg)) - eval_warn(last_form_expanded, + eval_warn(uw_last_form_expanded(), lit("~s appears in operator position"), arg, nao); else - eval_defr_warn(last_form_expanded, + eval_defr_warn(uw_last_form_expanded(), cons(fun_s, arg), lit("unbound function ~s"), arg, nao); @@ -4876,10 +4875,10 @@ again: insym_ex = expand(insym, menv); } else if (!lookup_fun(menv, sym) && !special_operator_p(sym)) { if (!bindable(sym)) - eval_warn(last_form_expanded, + eval_warn(uw_last_form_expanded(), lit("~s appears in operator position"), sym, nao); else - eval_defr_warn(last_form_expanded, + eval_defr_warn(uw_last_form_expanded(), cons(fun_s, sym), lit("unbound function ~s"), sym, nao); @@ -4909,16 +4908,19 @@ again: val expand(val form, val menv) { val ret = nil; - val lfe_save = last_form_expanded; +#if CONFIG_DEBUG_SUPPORT + uw_frame_t expand_fr; + uw_push_expand(&expand_fr, form, menv); +#endif - if (consp(form)) - last_form_expanded = form; ret = do_expand(form, menv); - last_form_expanded = lfe_save; if (!lookup_origin(ret)) set_origin(ret, form); +#if CONFIG_DEBUG_SUPPORT + uw_pop_frame(&expand_fr); +#endif return ret; } @@ -5000,23 +5002,26 @@ val macro_form_p(val form, val menv) static val do_macroexpand_1(val form, val menv, val (*lookup)(val, val)) { val macro; +#if CONFIG_DEBUG_SUPPORT + uw_frame_t expand_fr; + uw_push_expand(&expand_fr, form, menv); +#endif menv = default_null_arg(menv); if (consp(form) && (macro = lookup_mac(menv, car(form)))) { val mac_expand = expand_macro(form, macro, menv); - if (mac_expand == form) - return form; - return rlcp_tree(rlcp_tree(mac_expand, form), macro); - } - - if (bindable(form) && (macro = lookup(menv, form))) { + if (mac_expand != form) + form = rlcp_tree(rlcp_tree(mac_expand, form), macro); + } else if (bindable(form) && (macro = lookup(menv, form))) { val mac_expand = cdr(macro); - if (mac_expand == form) - return form; - return rlcp_tree(mac_expand, macro); + if (mac_expand != form) + form = rlcp_tree(mac_expand, macro); } +#if CONFIG_DEBUG_SUPPORT + uw_pop_frame(&expand_fr); +#endif return form; } @@ -6112,7 +6117,7 @@ void eval_init(void) val length_f = func_n1(length); protect(&top_vb, &top_fb, &top_mb, &top_smb, &special, &builtin, &dyn_env, - &op_table, &pm_table, &last_form_evaled, &last_form_expanded, + &op_table, &pm_table, &last_form_evaled, &call_f, &unbound_s, &origin_hash, convert(val *, 0)); top_fb = make_hash(t, nil, nil); top_vb = make_hash(t, nil, nil); @@ -30,7 +30,7 @@ extern val hash_lit_s, hash_construct_s, struct_lit_s, qref_s, uref_s; extern val eval_error_s, if_s, call_s; extern val eq_s, eql_s, equal_s; extern val car_s, cdr_s; -extern val last_form_evaled, last_form_expanded; +extern val last_form_evaled; extern val load_path_s, load_recursive_s; extern val special_s, struct_s; diff --git a/share/txr/stdlib/debugger.tl b/share/txr/stdlib/debugger.tl index 8eeb9ce2..26f30741 100644 --- a/share/txr/stdlib/debugger.tl +++ b/share/txr/stdlib/debugger.tl @@ -78,6 +78,15 @@ ^[,(cadr form)] ^(,sym))))))) +(defmeth expand-frame print-trace (fr pr-fr nx-fr prefix) + (let* ((form fr.form) + (loc (source-loc-str form))) + (put-string `@prefix X:@(if loc `(@loc):`)`) + (prinl form))) + +(defmeth expand-frame loc (fr) + (source-loc-str fr.form)) + (defun print-backtrace (: (*stdout* *stdout*) (prefix "")) (with-resources ((imode (set-indent-mode *stdout* indent-foff) (set-indent-mode *stdout* imode)) @@ -86,7 +95,7 @@ (length (set-max-length *stdout* 10) (set-max-length *stdout* length))) (window-map 1 nil (lambda (pr el nx) el.(print-trace pr nx prefix)) - (find-frames-by-mask (logior uw-fcall uw-eval))))) + (find-frames-by-mask (logior uw-fcall uw-eval uw-expand))))) (defun debugger () (with-disabled-debugging @@ -67,7 +67,7 @@ static val sys_cont_s, sys_cont_poison_s; static val sys_cont_free_s, sys_capture_cont_s; static val frame_type, catch_frame_type, handle_frame_type; -static val fcall_frame_type, eval_frame_type; +static val fcall_frame_type, eval_frame_type, expand_frame_type; static val deferred_warnings, tentative_defs; @@ -440,6 +440,13 @@ val uw_find_frames_by_mask(val mask_in) slotset(frame, env_s, fr->el.env); break; } + case UW_EXPAND: + { + frame = allocate_struct(expand_frame_type); + slotset(frame, form_s, fr->el.form); + slotset(frame, env_s, fr->el.env); + break; + } default: break; } @@ -454,6 +461,22 @@ val uw_find_frames_by_mask(val mask_in) #endif +#if CONFIG_DEBUG_SUPPORT + +val uw_last_form_expanded(void) +{ + uw_frame_t *fr; + + for (fr = uw_stack; fr != 0; fr = fr->uw.up) { + if (fr->uw.type == UW_EXPAND) + return fr->el.form; + } + + return nil; +} + +#endif + val uw_invoke_catch(val catch_frame, val sym, struct args *args) { uw_frame_t *ex, *ex_point; @@ -593,6 +616,16 @@ void uw_push_eval(uw_frame_t *fr, val form, val env) uw_stack = fr; } +void uw_push_expand(uw_frame_t *fr, val form, val env) +{ + memset(fr, 0, sizeof *fr); + fr->el.type = UW_EXPAND; + fr->el.form = form; + fr->el.env = env; + fr->el.up = uw_stack; + uw_stack = fr; +} + #endif static val exception_subtypes; @@ -1184,6 +1217,10 @@ void uw_late_init(void) frame_type, nil, list(form_s, env_s, nao), nil, nil, nil, nil); + expand_frame_type = make_struct_type(intern(lit("expand-frame"), user_package), + frame_type, nil, + list(form_s, env_s, nao), + nil, nil, nil, nil); #endif reg_mac(intern(lit("defex"), user_package), func_n2(me_defex)); reg_var(unhandled_hook_s = intern(lit("*unhandled-hook*"), @@ -1220,6 +1257,7 @@ void uw_late_init(void) reg_varl(intern(lit("uw-guard"), system_package), num_fast(1U <<UW_GUARD)); reg_varl(intern(lit("uw-fcall"), system_package), num_fast(1U <<UW_FCALL)); reg_varl(intern(lit("uw-eval"), system_package), num_fast(1U <<UW_EVAL)); + reg_varl(intern(lit("uw-expand"), system_package), num_fast(1U <<UW_EXPAND)); reg_fun(intern(lit("find-frames-by-mask"), user_package), func_n1(uw_find_frames_by_mask)); #endif uw_register_subtype(continue_s, restart_s); @@ -30,7 +30,7 @@ typedef enum uw_frtype { UW_BLOCK, UW_CAPTURED_BLOCK, UW_MENV, UW_CATCH, UW_HANDLE, UW_CONT_COPY, UW_GUARD, #if CONFIG_DEBUG_SUPPORT - UW_FCALL, UW_EVAL + UW_FCALL, UW_EVAL, UW_EXPAND #endif } uw_frtype_t; @@ -146,6 +146,7 @@ void uw_push_handler(uw_frame_t *, val matches, val fun); #if CONFIG_DEBUG_SUPPORT void uw_push_fcall(uw_frame_t *, val fun, struct args *args); void uw_push_eval(uw_frame_t *, val form, val env); +void uw_push_expand(uw_frame_t *, val form, val env); #endif noreturn val uw_throw(val sym, val exception); noreturn val uw_throwv(val sym, struct args *); @@ -174,6 +175,9 @@ val uw_find_frame(val extype, val frtype); val uw_find_frames(val extype, val frtype); #if CONFIG_DEBUG_SUPPORT val uw_find_frames_by_mask(val mask); +val uw_last_form_expanded(void); +#else +define uw_last_form_expanded() ((void) 0) #endif val uw_invoke_catch(val catch_frame, val sym, struct args *); val uw_muffle_warning(val exc, struct args *); |