From 06b285ac2c60fd5f8dd5eee24c794d7ef21fee46 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 15 Jan 2017 15:11:25 -0800 Subject: Functions for error reporting out of macros. * eval.c (eval_init): Register sys:ctx-form and sys:ctx-name intrinsics. * lisplib.c (error_set_entries, error_instantiate): New static functions. (lisplib_init): Register autoloading of error.tl via new functions. * share/txr/stdlib/error.tl: New file. * struct.c (make_struct_type): Purge deferred warnings. * unwind.c (uw_late_init): Register purge-deferred-warning intrinsic. --- eval.c | 2 ++ lisplib.c | 18 ++++++++++++++++++ share/txr/stdlib/error.tl | 46 ++++++++++++++++++++++++++++++++++++++++++++++ struct.c | 2 ++ unwind.c | 2 ++ 5 files changed, 70 insertions(+) create mode 100644 share/txr/stdlib/error.tl diff --git a/eval.c b/eval.c index c203186d..0a9ad60e 100644 --- a/eval.c +++ b/eval.c @@ -5795,6 +5795,8 @@ void eval_init(void) reg_fun(intern(lit("func-set-env"), user_package), func_n2(func_set_env)); reg_fun(intern(lit("functionp"), user_package), func_n1(functionp)); reg_fun(intern(lit("interp-fun-p"), user_package), func_n1(interp_fun_p)); + reg_fun(intern(lit("ctx-form"), system_package), func_n1(ctx_form)); + reg_fun(intern(lit("ctx-name"), system_package), func_n1(ctx_name)); reg_fun(intern(lit("range"), user_package), func_n3o(range, 0)); reg_fun(intern(lit("range*"), user_package), func_n3o(range_star, 0)); diff --git a/lisplib.c b/lisplib.c index 9d0472e4..b9aaf349 100644 --- a/lisplib.c +++ b/lisplib.c @@ -481,6 +481,23 @@ static val pmac_instantiate(val set_fun) return nil; } +static val error_set_entries(val dlt, val fun) +{ + val name[] = { + lit("compile-error"), lit("compile-warning"), lit("compile-defr-warning"), + nil + }; + set_dlt_entries(dlt, name, fun); + return nil; +} + +static val error_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~aerror.tl"), stdlib_path, nao)); + return nil; +} + val dlt_register(val dlt, val (*instantiate)(val), val (*set_entries)(val, val)) @@ -518,6 +535,7 @@ void lisplib_init(void) dlt_register(dl_table, getput_instantiate, getput_set_entries); dlt_register(dl_table, tagbody_instantiate, tagbody_set_entries); dlt_register(dl_table, pmac_instantiate, pmac_set_entries); + dlt_register(dl_table, error_instantiate, error_set_entries); } val lisplib_try_load(val sym) diff --git a/share/txr/stdlib/error.tl b/share/txr/stdlib/error.tl new file mode 100644 index 00000000..355b39e6 --- /dev/null +++ b/share/txr/stdlib/error.tl @@ -0,0 +1,46 @@ +;; Copyright 2017 +;; Kaz Kylheku +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, this +;; list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defun sys:loc (ctx) + (iflet ((loc (source-loc-str (sys:ctx-form ctx)))) + `(@loc) ` "")) + +(defun compile-error (ctx fmt . args) + (let ((loc (sys:loc ctx)) + (name (sys:ctx-name ctx))) + (throwf 'eval-error `@loc~s: @fmt` name . args))) + +(defun compile-warning (ctx fmt . args) + (let ((loc (sys:loc ctx)) + (name (sys:ctx-name ctx))) + (throwf 'warning `@loc~s: @fmt` name . args))) + +(defun compile-defr-warning (ctx tag fmt . args) + (let ((loc (sys:loc ctx)) + (name (sys:ctx-name ctx))) + (catch + (throw 'warning (fmt `@loc~s: @fmt` name . args) . tag) + (continue ())))) diff --git a/struct.c b/struct.c index bfa6acbd..7517b8dd 100644 --- a/struct.c +++ b/struct.c @@ -349,6 +349,8 @@ val make_struct_type(val name, val super, call_stinitfun_chain(st, stype); + uw_purge_deferred_warning(cons(struct_type_s, name)); + return stype; } } diff --git a/unwind.c b/unwind.c index 4c839735..4f259e06 100644 --- a/unwind.c +++ b/unwind.c @@ -1022,6 +1022,8 @@ void uw_late_init(void) reg_fun(throw_s, func_n1v(uw_throwv)); reg_fun(intern(lit("throwf"), user_package), func_n2v(uw_throwfv)); reg_fun(error_s, func_n1v(uw_errorfv)); + reg_fun(intern(lit("purge-deferred-warning"), user_package), + func_n1(uw_purge_deferred_warning)); reg_fun(intern(lit("register-exception-subtypes"), user_package), func_n0v(register_exception_subtypes)); reg_fun(intern(lit("exception-subtype-p"), user_package), -- cgit v1.2.3