diff options
| -rw-r--r-- | eval.c | 45 | ||||
| -rw-r--r-- | lib.c | 5 | ||||
| -rw-r--r-- | lib.h | 2 | ||||
| -rw-r--r-- | lisplib.c | 5 | ||||
| -rw-r--r-- | parser.c | 12 | ||||
| -rw-r--r-- | parser.y | 9 | ||||
| -rw-r--r-- | share/txr/stdlib/except.tl | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/place.tl | 6 | ||||
| -rw-r--r-- | tests/011/macros-2.txr | 15 | ||||
| -rw-r--r-- | tests/012/ifa.tl | 2 | ||||
| -rw-r--r-- | tests/012/struct.tl | 10 | ||||
| -rw-r--r-- | txr.1 | 36 | ||||
| -rw-r--r-- | unwind.c | 13 |
13 files changed, 131 insertions, 32 deletions
@@ -211,27 +211,50 @@ val ctx_name(val obj) return nil; } -noreturn val eval_error(val ctx, val fmt, ...) +noreturn static void eval_exception(val sym, val ctx, val fmt, va_list vl) { uses_or2; - va_list vl; val form = ctx_form(ctx); val stream = make_string_output_stream(); val loc = or2(source_loc_str(form, nil), source_loc_str(last_form_evaled, nil)); - va_start (vl, fmt); - if (loc) format(stream, lit("(~a) "), loc, nao); (void) vformat(stream, fmt, vl); - va_end (vl); - uw_throw(eval_error_s, get_string_from_stream(stream)); + uw_throw(sym, get_string_from_stream(stream)); +} + +noreturn val eval_error(val ctx, val fmt, ...) +{ + va_list vl; + va_start (vl, fmt); + eval_exception(eval_error_s, ctx, fmt, vl); + va_end (vl); abort(); } +static val eval_warn(val ctx, val fmt, ...) +{ + va_list vl; + + uw_catch_begin (cons(continue_s, nil), exsym, exvals); + + va_start (vl, fmt); + eval_exception(warning_s, ctx, fmt, vl); + va_end (vl); + + uw_catch(exsym, exvals) { (void) exsym; (void) exvals; } + + uw_unwind; + + uw_catch_end; + + return nil; +} + val lookup_origin(val form) { return gethash(origin_hash, form); @@ -3107,9 +3130,10 @@ static val supplement_op_syms(val ssyms, val max) static val me_op(val form, val menv) { cons_bind (sym, body, form); + val new_menv = make_var_shadowing_env(menv, cons(rest_s, nil)); val body_ex = if3(sym == op_s, - expand_forms_lisp1(body, menv), - expand(body, menv)); + expand_forms_lisp1(body, new_menv), + expand(body, new_menv)); val rest_gensym = gensym(lit("rest-")); cons_bind (syms, body_trans, transform_op(body_ex, nil, rest_gensym)); val ssyms = sort(syms, func_n2(lt), car_f); @@ -3597,6 +3621,8 @@ static val do_expand(val form, val menv) return form; return expand(rlcp_tree(symac, form), menv); } + if (!lookup_var(menv, form)) + eval_warn(last_form_expanded, lit("unbound variable ~s"), form, nao); return form; } else if (atom(form)) { return form; @@ -3886,7 +3912,8 @@ val expand(val form, val menv) val ret = nil; val lfe_save = last_form_expanded; - last_form_expanded = form; + if (consp(form)) + last_form_expanded = form; ret = do_expand(form, menv); last_form_expanded = lfe_save; @@ -101,7 +101,7 @@ val eof_s, eol_s, assert_s, name_s; val error_s, type_error_s, internal_error_s, panic_s; val numeric_error_s, range_error_s; val query_error_s, file_error_s, process_error_s, syntax_error_s; -val timeout_error_s, system_error_s; +val timeout_error_s, system_error_s, warning_s, restart_s, continue_s; val gensym_counter_s, nullify_s, from_list_s, lambda_set_s; val nothrow_k, args_k, colon_k, auto_k, fun_k; @@ -9329,6 +9329,9 @@ static void obj_init(void) system_error_s = intern(lit("system-error"), user_package); timeout_error_s = intern(lit("timeout-error"), user_package); assert_s = intern(lit("assert"), user_package); + warning_s = intern(lit("warning"), user_package); + restart_s = intern(lit("restart"), user_package); + continue_s = intern(lit("continue"), user_package); name_s = intern(lit("name"), user_package); nullify_s = intern(lit("nullify"), user_package); from_list_s = intern(lit("from-list"), user_package); @@ -441,7 +441,7 @@ extern val eof_s, eol_s, assert_s, name_s; extern val error_s, type_error_s, internal_error_s, panic_s; extern val numeric_error_s, range_error_s; extern val query_error_s, file_error_s, process_error_s, syntax_error_s; -extern val system_error_s, timeout_error_s; +extern val system_error_s, timeout_error_s, warning_s, restart_s, continue_s; extern val gensym_counter_s; #define gensym_counter (deref(lookup_var_l(nil, gensym_counter_s))) @@ -238,7 +238,10 @@ static val hash_instantiate(val set_fun) static val except_set_entries(val dlt, val fun) { - val name[] = { lit("handle"), nil }; + val name[] = { + lit("handle"), lit("ignwarn"), lit("macro-time-ignwarn"), + nil + }; set_dlt_entries(dlt, name, fun); return nil; } @@ -887,6 +887,12 @@ static val get_home_path(void) return getenv_wrap(lit("HOME")); } +static val repl_warning(val out_stream, val exc, val arg) +{ + format(out_stream, lit("** warning: ~!~a\n"), arg, nao); + uw_throw(continue_s, nil); +} + val repl(val bindings, val in_stream, val out_stream) { val ifd = stream_get_prop(in_stream, fd_k); @@ -911,6 +917,7 @@ val repl(val bindings, val in_stream, val out_stream) val hist_len_var = lookup_global_var(listener_hist_len_s); val multi_line_var = lookup_global_var(listener_multi_line_p_s); val sel_inclusive_var = lookup_global_var(listener_sel_inclusive_p_s); + val rw_f = func_f2(out_stream, repl_warning); for (; bindings; bindings = cdr(bindings)) { val binding = car(bindings); @@ -937,6 +944,7 @@ val repl(val bindings, val in_stream, val out_stream) val var_counter = mod(counter, num_fast(100)); val var_name = format(nil, lit("*~d"), var_counter, nao); val var_sym = intern(var_name, user_package); + uw_frame_t uw_handler; char *prompt_u8 = utf8_dup_to(c_str(prompt)); @@ -984,6 +992,8 @@ val repl(val bindings, val in_stream, val out_stream) uw_catch_begin (catch_all, exsym, exvals); + uw_push_handler(&uw_handler, cons(warning_s, nil), rw_f); + { val name = format(nil, lit("expr-~d"), prev_counter, nao); val line = string_utf8(line_u8); @@ -1003,6 +1013,8 @@ val repl(val bindings, val in_stream, val out_stream) } } + uw_pop_frame(&uw_handler); + uw_catch (exsym, exvals) { val exinfo = cons(exsym, exvals); reg_varl(var_sym, exinfo); @@ -1740,9 +1740,15 @@ void yybadtoken(parser_t *parser, int tok, val context) yyerrorf(scnr, lit("unexpected character ~a"), chr(tok), nao); } +static val warning_continue(val exc, val arg) +{ + uw_throw(continue_s, nil); +} + int parse_once(val stream, val name, parser_t *parser) { int res = 0; + uw_frame_t uw_handler; #if CONFIG_DEBUG_SUPPORT debug_state_t ds = debug_set_state(opt_dbg_expansion ? 0 : -1, opt_dbg_expansion); @@ -1753,6 +1759,7 @@ int parse_once(val stream, val name, parser_t *parser) parser->stream = stream; parser->name = name; + uw_push_handler(&uw_handler, cons(warning_s, nil), func_n2(warning_continue)); uw_catch_begin(cons(error_s, nil), esym, eobj); @@ -1774,6 +1781,8 @@ int parse_once(val stream, val name, parser_t *parser) uw_catch_end; + uw_pop_frame(&uw_handler); + return res; } diff --git a/share/txr/stdlib/except.tl b/share/txr/stdlib/except.tl index ad5cb0b9..addc3a66 100644 --- a/share/txr/stdlib/except.tl +++ b/share/txr/stdlib/except.tl @@ -44,3 +44,6 @@ syms-fragments))) ,[mapcar car syms-fragments] ,try-form))) + +(defmacro ignwarn (. forms) + ^(handler-bind (lambda (exc-sym arg) (throw 'continue)) (warning) ,*forms)) diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index 20650ad0..b18fddbf 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -183,7 +183,7 @@ (expander (get-update-expander place)) (sys:*pl-env* env) (expansion [expander getter setter place body]) - (expansion-ex (sys:expand expansion env))) + (expansion-ex (ignwarn (sys:expand expansion env)))) (sys:cp-origin expansion-ex place))) (defun call-clobber-expander (ssetter unex-place env body) @@ -191,7 +191,7 @@ (expander (get-clobber-expander place)) (sys:*pl-env* env) (expansion [expander ssetter place body]) - (expansion-ex (sys:expand expansion env))) + (expansion-ex (ignwarn (sys:expand expansion env)))) (sys:cp-origin expansion-ex place))) (defun call-delete-expander (deleter unex-place env body) @@ -199,7 +199,7 @@ (expander (get-delete-expander place)) (sys:*pl-env* env) (expansion [expander deleter place body]) - (expansion-ex (sys:expand expansion env))) + (expansion-ex (ignwarn (sys:expand expansion env)))) (sys:cp-origin expansion-ex place)))) (defmacro with-update-expander ((getter setter) unex-place env body) diff --git a/tests/011/macros-2.txr b/tests/011/macros-2.txr index 96045ca4..debc6eca 100644 --- a/tests/011/macros-2.txr +++ b/tests/011/macros-2.txr @@ -20,13 +20,14 @@ (prinl i))) (prinl - (sys:expand - '(whilst ((< i 100)) - (if (< (inc i) 20) - continue) - (if (> i 30) - break) - (prinl i)))) + (ignwarn + (sys:expand + '(whilst ((< i 100)) + (if (< (inc i) 20) + continue) + (if (> i 30) + break) + (prinl i))))) (let ((i 0)) (whilst ((< i 5)) diff --git a/tests/012/ifa.tl b/tests/012/ifa.tl index 91fa4512..d669244d 100644 --- a/tests/012/ifa.tl +++ b/tests/012/ifa.tl @@ -11,7 +11,7 @@ 7) ;; ambiguous: is "it" x or is "it" y? -(test (ifa (> x y) (print it)) :error) +(test (let (x y) (ifa (> x y) (print it))) :error) ;; "it" is (+ 3 (* 2 x)) (test (let ((x 5)) diff --git a/tests/012/struct.tl b/tests/012/struct.tl index cecdfb15..a22d32d0 100644 --- a/tests/012/struct.tl +++ b/tests/012/struct.tl @@ -24,7 +24,7 @@ (test s #S(bar a 100 b 4)) -(test (sys:expand 'a.b.c.d) +(test (ignwarn (sys:expand 'a.b.c.d)) (slot (slot (slot a 'b) 'c) 'd)) @@ -36,11 +36,11 @@ [(slot s 'a) b c]) (set *gensym-counter* 0) -(stest (sys:expand 's.(a)) +(stest (ignwarn (sys:expand 's.(a))) "(call (slot s 'a)\n \ \ s)") (set *gensym-counter* 0) -(stest (sys:expand 's.(a b c)) +(stest (ignwarn (sys:expand 's.(a b c))) "(call (slot s 'a)\n \ \ s b c)") (test (sys:expand 's.[a].d) @@ -48,11 +48,11 @@ (test (sys:expand 's.[a b c].d) (slot [(slot s 'a) b c] 'd)) (set *gensym-counter* 0) -(stest (sys:expand 's.(a).d) +(stest (ignwarn (sys:expand 's.(a).d)) "(slot (call (slot s 'a)\n \ \ s) 'd)") (set *gensym-counter* 0) -(stest (sys:expand 's.(a b c).d) +(stest (ignwarn (sys:expand 's.(a b c).d)) "(slot (call (slot s 'a)\n \ \ s b c)\n 'd)") @@ -32183,6 +32183,42 @@ form terminates without evaluating the remaining forms, and yields .codn nil . +.coNP Macro @ ignwarn +.synb +.mets (ignwarn << form *) +.syne +.desc +The +.code ignwarn +macro resembles +.codn ignerr . +It arranges for the evaluation of each +.meta form +in left-to-right order. If all the forms are evaluated, then the +value of the last one is returned. If no forms are present, then +.code nil +is returned. + +If any +.meta form +throws an exception of type +.code warning +then this exception is intercepted by a handler established by +.codn ignwarn . +This handler reacts by throwing an exception of type +.codn continue . + +The effect is that the warning is ignored, since the handler +doesn't issue any diagnostic, and passes control to the warning's +continue point. + +Note: all sites within \*(TX which throw a +.code warning +also provide a nearby catch for a +.code continue +exception, for resuming evaluation at the point where the warning +was issued. + .coNP Operator @ handler-bind .synb .mets (handler-bind < function-form < symbol-list << body-form *) @@ -556,6 +556,13 @@ val uw_throw(val sym, val args) abort(); } + if (sym == warning_s) { + --reentry_count; + format(std_error, lit("warning: ~a\n"), car(args), nao); + uw_throw(continue_s, nil); + abort(); + } + { loc pfun = lookup_var_l(nil, unhandled_hook_s); val fun = deref(pfun); @@ -667,10 +674,6 @@ val uw_register_subtype(val sub, val sup) sub, sup, nao); } - if (uw_exception_subtype_p(sub, sup)) - uw_throwf(type_error_s, lit("~s is already an exception subtype of ~s"), - sub, sup, nao); - if (uw_exception_subtype_p(sup, sub)) uw_throwf(type_error_s, lit("~s is already an exception supertype of ~s"), sub, sup, nao); @@ -975,4 +978,6 @@ void uw_late_init(void) func_n2v(uw_invoke_catch)); reg_fun(sys_capture_cont_s = intern(lit("capture-cont"), system_package), func_n3o(uw_capture_cont, 2)); + uw_register_subtype(continue_s, restart_s); + uw_register_subtype(warning_s, t); } |