From 09ae630cdede6556d645e65de0b779d377e616a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 24 Jun 2015 13:31:47 +0200 Subject: [PATCH] stack: add special conditional handler for stack-overflow MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Add `serror' and `stack-error-handler', which behave like normal `cerror' -> `universal-error-handler' call order, except fact, that after handling stack-overflow condition they reset appropriate stack limit. Fixes #56. Signed-off-by: Daniel Kochmański --- src/c/error.d | 7 +++++++ src/c/stacks.d | 6 +++--- src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/clos/conditions.lsp | 5 +++++ src/h/external.h | 1 + 6 files changed, 20 insertions(+), 3 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index c6fc20fb9..83a33efa7 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -541,6 +541,13 @@ FEwin32_error(const char *msg, int narg, ...) cl_grab_rest_args(args)); @) +@(defun si::serror (cformat eformat &rest args) +@ + ecl_enable_interrupts(); + return funcall(4, @'si::stack-error-handler', cformat, eformat, + cl_grab_rest_args(args)); +@) + void init_error(void) { diff --git a/src/c/stacks.d b/src/c/stacks.d index 48f947e51..d271c9389 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -71,7 +71,7 @@ ecl_cs_overflow(void) #endif else ecl_unrecoverable_error(env, stack_overflow_msg); - cl_cerror(6, make_constant_base_string("Extend stack size"), + cl_serror(6, make_constant_base_string("Extend stack size"), @'ext::stack-overflow', @':size', ecl_make_fixnum(size), @':type', @'ext::c-stack'); size += size / 2; @@ -158,7 +158,7 @@ ecl_bds_overflow(void) ecl_unrecoverable_error(env, stack_overflow_msg); } env->bds_limit += margin; - cl_cerror(6, make_constant_base_string("Extend stack size"), + cl_serror(6, make_constant_base_string("Extend stack size"), @'ext::stack-overflow', @':size', ecl_make_fixnum(size), @':type', @'ext::binding-stack'); ecl_bds_set_size(env, size + (size / 2)); @@ -511,7 +511,7 @@ frs_overflow(void) /* used as condition in list.d */ ecl_unrecoverable_error(env, stack_overflow_msg); } env->frs_limit += margin; - cl_cerror(6, make_constant_base_string("Extend stack size"), + cl_serror(6, make_constant_base_string("Extend stack size"), @'ext::stack-overflow', @':size', ecl_make_fixnum(size), @':type', @'ext::frame-stack'); frs_set_size(env, size + size / 2); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 5d5e6c2cb..4710bfa43 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -295,6 +295,7 @@ cl_symbols[] = { {"CELL-ERROR", CL_ORDINARY, NULL, -1, OBJNULL}, {"CELL-ERROR-NAME", CL_ORDINARY, NULL, -1, OBJNULL}, {"CERROR", CL_ORDINARY, cl_cerror, -1, OBJNULL}, +{SYS_ "SERROR", CL_ORDINARY, cl_serror, -1, OBJNULL}, {"CHAR", CL_ORDINARY, cl_char, 2, OBJNULL}, {"CHAR-CODE", CL_ORDINARY, cl_char_code, 1, OBJNULL}, {"CHAR-CODE-LIMIT", CL_CONSTANT, NULL, -1, ecl_make_fixnum(ECL_CHAR_CODE_LIMIT)}, @@ -1269,6 +1270,7 @@ cl_symbols[] = { {SYS_ "TERMINAL-INTERRUPT", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "TOP-LEVEL", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "UNIVERSAL-ERROR-HANDLER", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "STACK-ERROR-HANDLER", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "VALID-FUNCTION-NAME-P", SI_ORDINARY, si_valid_function_name_p, 1, OBJNULL}, {SYS_ "WRITE-OBJECT", SI_SPECIAL, si_write_object, 2, OBJNULL}, {SYS_ "WRITE-UGLY-OBJECT", SI_SPECIAL, si_write_ugly_object, 2, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index cb5d6406e..1777c28f4 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -295,6 +295,7 @@ cl_symbols[] = { {"CELL-ERROR",NULL}, {"CELL-ERROR-NAME",NULL}, {"CERROR","cl_cerror"}, +{SYS_ "SERROR","cl_serror"}, {"CHAR","cl_char"}, {"CHAR-CODE","cl_char_code"}, {"CHAR-CODE-LIMIT",NULL}, @@ -1269,6 +1270,7 @@ cl_symbols[] = { {SYS_ "TERMINAL-INTERRUPT",NULL}, {SYS_ "TOP-LEVEL",NULL}, {SYS_ "UNIVERSAL-ERROR-HANDLER",NULL}, +{SYS_ "STACK-ERROR-HANDLER",NULL}, {SYS_ "VALID-FUNCTION-NAME-P","si_valid_function_name_p"}, {SYS_ "WRITE-OBJECT","si_write_object"}, {SYS_ "WRITE-UGLY-OBJECT","si_write_ugly_object"}, diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index a8ada19dc..a4f6e8a69 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -831,5 +831,10 @@ strings." (signal condition) (invoke-debugger condition)))))) +(defun sys::stack-error-handler (continue-string datum args) + (unwind-protect (universal-error-handler continue-string datum args) + (si:reset-margin + (getf args :type)))) + (defun sys::tpl-continue-command (&rest any) (apply #'invoke-restart 'continue any)) diff --git a/src/h/external.h b/src/h/external.h index 8cb23607f..e7f1cc9db 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -560,6 +560,7 @@ extern ECL_API cl_object si_bc_join(cl_object lex, cl_object code, cl_object dat extern ECL_API cl_object cl_error _ECL_ARGS((cl_narg narg, cl_object eformat, ...)) ecl_attr_noreturn; extern ECL_API cl_object cl_cerror _ECL_ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...)); +extern ECL_API cl_object cl_serror _ECL_ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...)); extern ECL_API void ecl_internal_error(const char *s) ecl_attr_noreturn; extern ECL_API void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_attr_noreturn;