diff options
| -rw-r--r-- | eval.c | 2 | ||||
| -rw-r--r-- | lisplib.c | 18 | ||||
| -rw-r--r-- | share/txr/stdlib/error.tl | 46 | ||||
| -rw-r--r-- | struct.c | 2 | ||||
| -rw-r--r-- | unwind.c | 2 |
5 files changed, 70 insertions, 0 deletions
@@ -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)); @@ -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 <kaz@kylheku.com> +;; 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 ())))) @@ -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; } } @@ -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), |