kgerrors.c (5059B)
1 /* 2 ** kgerrors.c 3 ** Error handling features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <stdbool.h> 8 #include <stdint.h> 9 10 #include "kstate.h" 11 #include "kobject.h" 12 #include "kstring.h" 13 #include "kpair.h" 14 #include "kerror.h" 15 16 #include "kghelpers.h" 17 #include "kgerrors.h" 18 19 void kgerror(klisp_State *K) 20 { 21 TValue *xparams = K->next_xparams; 22 TValue ptree = K->next_value; 23 TValue denv = K->next_env; 24 klisp_assert(ttisenvironment(K->next_env)); 25 UNUSED(xparams); 26 UNUSED(denv); 27 28 bind_al1tp(K, ptree, "string", ttisstring, str, rest); 29 /* copy the list of irritants, to avoid modification later */ 30 /* also check that is a list! */ 31 TValue irritants = check_copy_list(K, rest, false, NULL, NULL); 32 krooted_tvs_push(K, irritants); 33 /* the msg is implicitly copied here */ 34 klispE_throw_with_irritants(K, kstring_buf(str), irritants); 35 } 36 37 void kgraise(klisp_State *K) 38 { 39 TValue *xparams = K->next_xparams; 40 TValue ptree = K->next_value; 41 TValue denv = K->next_env; 42 klisp_assert(ttisenvironment(K->next_env)); 43 UNUSED(xparams); 44 UNUSED(denv); 45 46 bind_1p(K, ptree, obj); 47 kcall_cont(K, G(K)->error_cont, obj); 48 } 49 50 void error_object_message(klisp_State *K) 51 { 52 TValue *xparams = K->next_xparams; 53 TValue ptree = K->next_value; 54 TValue denv = K->next_env; 55 klisp_assert(ttisenvironment(K->next_env)); 56 UNUSED(xparams); 57 UNUSED(denv); 58 bind_1tp(K, ptree, "error object", ttiserror, error_tv); 59 Error *err_obj = tv2error(error_tv); 60 /* the string is immutable, no need to copy it */ 61 klisp_assert(ttisstring(err_obj->msg)); 62 kapply_cc(K, err_obj->msg); 63 } 64 65 void error_object_irritants(klisp_State *K) 66 { 67 TValue *xparams = K->next_xparams; 68 TValue ptree = K->next_value; 69 TValue denv = K->next_env; 70 klisp_assert(ttisenvironment(K->next_env)); 71 UNUSED(xparams); 72 UNUSED(denv); 73 bind_1tp(K, ptree, "error object", ttiserror, error_tv); 74 Error *err_obj = tv2error(error_tv); 75 kapply_cc(K, err_obj->irritants); 76 } 77 78 void do_error_exit(klisp_State *K) 79 { 80 TValue *xparams = K->next_xparams; 81 TValue obj = K->next_value; 82 klisp_assert(ttisnil(K->next_env)); 83 UNUSED(xparams); 84 85 /* TEMP Just pass the error to the root continuation */ 86 kapply_cc(K, obj); 87 } 88 89 /* REFACTOR this is the same as do_pass_value */ 90 static void do_exception_cont(klisp_State *K) 91 { 92 TValue *xparams = K->next_xparams; 93 TValue obj = K->next_value; 94 klisp_assert(ttisnil(K->next_env)); 95 UNUSED(xparams); 96 /* Just pass error object to general error continuation. */ 97 kapply_cc(K, obj); 98 } 99 100 /* REFACTOR maybe this should be in kerror.c */ 101 /* Create system-error-continuation. */ 102 static void kinit_error_hierarchy(klisp_State *K) 103 { 104 klisp_assert(ttisinert(G(K)->error_cont)); 105 G(K)->error_cont = kmake_continuation(K, G(K)->root_cont, 106 do_error_exit, 0); 107 108 TValue str, tail, si; 109 110 #if KTRACK_SI 111 str = kstring_new_b_imm(K, __FILE__); 112 tail = kcons(K, i2tv(__LINE__), i2tv(0)); 113 si = kcons(K, str, tail); 114 kset_source_info(K, G(K)->error_cont, si); 115 #endif 116 117 klisp_assert(ttisinert(G(K)->system_error_cont)); 118 G(K)->system_error_cont = kmake_continuation(K, G(K)->error_cont, 119 do_exception_cont, 0); 120 #if KTRACK_SI 121 str = kstring_new_b_imm(K, __FILE__); 122 tail = kcons(K, i2tv(__LINE__), i2tv(0)); 123 si = kcons(K, str, tail); 124 kset_source_info(K, G(K)->system_error_cont, si); 125 #endif 126 } 127 128 /* init ground */ 129 void kinit_error_ground_env(klisp_State *K) 130 { 131 TValue ground_env = G(K)->ground_env; 132 TValue symbol, value; 133 134 add_applicative(K, ground_env, "error-object?", typep, 2, symbol, 135 i2tv(K_TERROR)); 136 add_applicative(K, ground_env, "error", kgerror, 0); 137 add_applicative(K, ground_env, "raise", kgraise, 0); 138 /* MAYBE add get- and remove object from these names */ 139 add_applicative(K, ground_env, "error-object-message", 140 error_object_message, 0); 141 add_applicative(K, ground_env, "error-object-irritants", 142 error_object_irritants, 0); 143 /* TODO raise-continuable from r7rs doesn't make sense in the Kernel 144 system of handling continuations. 145 What we could have is a more sophisticated system 146 of restarts, which would be added to an error object 147 and would encapsulate continuations and descriptions of them. 148 It would be accessible with 149 error-object-restarts or something like that. 150 See Common Lisp and mit scheme for examples 151 */ 152 153 /* 7.2.7 error-continuation */ 154 kinit_error_hierarchy(K); 155 add_value(K, ground_env, "error-continuation", G(K)->error_cont); 156 add_value(K, ground_env, "system-error-continuation", G(K)->system_error_cont); 157 } 158 159 void kinit_error_cont_names(klisp_State *K) 160 { 161 Table *t = tv2table(G(K)->cont_name_table); 162 163 add_cont_name(K, t, do_error_exit, "error"); 164 add_cont_name(K, t, do_exception_cont, "system-error"); 165 }