klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

commit 0cad9cd9407592834a01d4a7f43479382d96e2e4
parent 167dc11ae9cab38dedd86a0618db5e735b28abdb
Author: Oto Havle <havleoto@gmail.com>
Date:   Sat,  5 Nov 2011 15:18:02 +0100

Added system-error-continuation and klispE_throw_errno_with_irritants().

Diffstat:
Msrc/kerror.c | 111+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msrc/kerror.h | 14++++++++++++++
Msrc/kgc.c | 1+
Msrc/kgerror.c | 20++++++++++++++++++++
Msrc/kgerror.h | 5+++++
Msrc/kgports.c | 10++++------
Msrc/kport.c | 4+++-
Msrc/krepl.c | 4++++
Msrc/kscript.c | 4++++
Msrc/kstate.c | 1+
Msrc/kstate.h | 1+
Msrc/tests/error.k | 23+++++++++++++++++++++++
12 files changed, 191 insertions(+), 7 deletions(-)

diff --git a/src/kerror.c b/src/kerror.c @@ -2,12 +2,15 @@ #include <stdio.h> #include <string.h> #include <stdlib.h> +#include <errno.h> +#include <string.h> #include "klisp.h" #include "kpair.h" #include "kstate.h" #include "kmem.h" #include "kstring.h" +#include "kerror.h" /* TODO: check that all objects passed to throw are rooted */ @@ -98,3 +101,111 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants) /* call_cont protects error from gc */ kcall_cont(K, K->error_cont, error_obj); } + +void klispE_throw_system_error_with_irritants(klisp_State *K, const char *service, int errnum, TValue irritants) +{ + TValue error_description = klispE_describe_errno(K, service, errnum); + krooted_tvs_push(K, error_description); + TValue all_irritants = kimm_cons(K, error_description, irritants); + krooted_tvs_push(K, all_irritants); + TValue error_obj = klispE_new(K, K->next_obj, K->curr_cont, + kcaddr(error_description), + all_irritants); + krooted_tvs_push(K, error_obj); + clear_buffers(K); + kcall_cont(K, K->system_error_cont, error_obj); +} + +/* The array symbolic_error_codes[] assigns locale and target + * platform configuration independent strings to errno values. + * + * Generated from Linux header files: + * + * awk '{printf(" c(%s),\n", $2)}' /usr/include/asm-generic/errno-base.h + * awk '{printf(" c(%s),\n", $2)}' /usr/include/asm-generic/errno.h + * + * and removed errnos not present in mingw. + * + */ +#define c(N) [N] = # N +static const char * const symbolic_error_codes[] = { + c(EPERM), + c(ENOENT), + c(ESRCH), + c(EINTR), + c(EIO), + c(ENXIO), + c(E2BIG), + c(ENOEXEC), + c(EBADF), + c(ECHILD), + c(EAGAIN), + c(ENOMEM), + c(EACCES), + c(EFAULT), + c(EBUSY), + c(EEXIST), + c(EXDEV), + c(ENODEV), + c(ENOTDIR), + c(EISDIR), + c(EINVAL), + c(ENFILE), + c(EMFILE), + c(ENOTTY), + c(EFBIG), + c(ENOSPC), + c(ESPIPE), + c(EROFS), + c(EMLINK), + c(EPIPE), + c(EDOM), + c(ERANGE), + /**/ + c(EDEADLK), + c(ENAMETOOLONG), + c(ENOLCK), + c(ENOSYS), + c(ENOTEMPTY), +}; +#undef c + +/* klispE_describe_errno(K, ERRNUM, SERVICE) returns a list + * + * (SERVICE CODE MESSAGE ERRNUM) + * + * SERVICE (string) identifies the failed system call or service, + * e.g. "rename" or "fopen". + * + * CODE (string) is a platform-independent symbolic representation + * of the error. It corresponds to symbolic constants of <errno.h>, + * e.g. "ENOENT" or "ENOMEM". + * + * MESSAGE (string) platform-dependent human-readable description. + * The MESSAGE may depend on locale or operating system configuration. + * + * ERRNUM (fixint) is the value of errno for debugging puroposes. + * + */ +TValue klispE_describe_errno(klisp_State *K, const char *service, int errnum) +{ + const char *code = NULL; + int tabsize = sizeof(symbolic_error_codes) / sizeof(symbolic_error_codes[0]); + if (0 <= errnum && errnum < tabsize) + code = symbolic_error_codes[errnum]; + if (code == NULL) + code = "UNKNOWN"; + + TValue service_tv = kstring_new_b_imm(K, service); + krooted_tvs_push(K, service_tv); + TValue code_tv = kstring_new_b_imm(K, code); + krooted_tvs_push(K, code_tv); + TValue message_tv = kstring_new_b_imm(K, strerror(errnum)); + krooted_tvs_push(K, message_tv); + + TValue v = kimm_list(K, 4, service_tv, code_tv, message_tv, i2tv(errnum)); + krooted_tvs_pop(K); + krooted_tvs_pop(K); + krooted_tvs_pop(K); + return v; +} diff --git a/src/kerror.h b/src/kerror.h @@ -9,6 +9,7 @@ #define kerror_h #include <stdbool.h> +#include <errno.h> #include "klisp.h" #include "kstate.h" @@ -21,6 +22,8 @@ void klispE_free(klisp_State *K, Error *error); void klispE_throw_simple(klisp_State *K, char *msg); void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants); +void klispE_throw_system_error_with_irritants(klisp_State *K, const char *service, int errnum, TValue irritants); + /* evaluates K__ more than once */ #define klispE_throw_simple_with_irritants(K__, msg__, ...) \ { TValue ls__ = klist(K__, __VA_ARGS__); \ @@ -28,6 +31,17 @@ void klispE_throw_with_irritants(klisp_State *K, char *msg, TValue irritants); /* the pop is implicit in throw_with_irritants */ \ klispE_throw_with_irritants(K__, msg__, ls__); } +#define klispE_throw_errno_with_irritants(K__, service__, ...) \ + { \ + int errnum__ = errno; \ + TValue ls__ = klist(K__, __VA_ARGS__); \ + krooted_tvs_push(K__, ls__); \ + klispE_throw_system_error_with_irritants(K__, service__, errnum__, ls__); \ + } + +#define klispE_throw_errno_simple(K__, service__) \ + klispE_throw_system_error_with_irritants(K__, service__, errno, KNIL); +TValue klispE_describe_errno(klisp_State *K, const char *service, int errnum); #endif diff --git a/src/kgc.c b/src/kgc.c @@ -580,6 +580,7 @@ static void markroot (klisp_State *K) { markvalue(K, K->module_params_sym); markvalue(K, K->root_cont); markvalue(K, K->error_cont); + markvalue(K, K->system_error_cont); markvalue(K, K->kd_in_port_key); markvalue(K, K->kd_out_port_key); diff --git a/src/kgerror.c b/src/kgerror.c @@ -50,6 +50,26 @@ void error_object_irritants(klisp_State *K, TValue *xparams, TValue ptree, kapply_cc(K, err_obj->irritants); } +void do_exception_cont(klisp_State *K, TValue *xparams, TValue obj) +{ + UNUSED(xparams); + /* Just pass error object to general error continuation. */ + kapply_cc(K, obj); +} + +/* Create system-error-continuation. */ +void kinit_error_hierarchy(klisp_State *K) +{ + assert(ttiscontinuation(K->error_cont)); + assert(ttisinert(K->system_error_cont)); + + K->system_error_cont = kmake_continuation(K, K->error_cont, do_exception_cont, 0); + TValue symbol = ksymbol_new(K, "system-error-continuation", KNIL); + krooted_tvs_push(K, symbol); + kadd_binding(K, K->ground_env, symbol, K->system_error_cont); + krooted_tvs_pop(K); +} + /* init ground */ void kinit_error_ground_env(klisp_State *K) { diff --git a/src/kgerror.h b/src/kgerror.h @@ -21,4 +21,9 @@ /* init ground */ void kinit_error_ground_env(klisp_State *K); +/* Second stage of itialization of ground environment. Must be + * called after initializing general error continuation + * K->error_cont. */ +void kinit_error_hierarchy(klisp_State *K); + #endif diff --git a/src/kgports.c b/src/kgports.c @@ -607,9 +607,8 @@ void delete_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) /* TEMP: this should probably be done in a operating system specific manner, but this will do for now */ if (remove(kstring_buf(filename))) { - /* TODO: more meaningful error msg, include errno */ - klispE_throw_simple(K, "the file couldn't be deleted"); - return; + klispE_throw_errno_with_irritants(K, "remove", 1, filename); + return; } else { kapply_cc(K, KINERT); return; @@ -628,9 +627,8 @@ void rename_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) /* TEMP: this should probably be done in a operating system specific manner, but this will do for now */ if (rename(kstring_buf(old_filename), kstring_buf(new_filename))) { - /* TODO: more meaningful error msg, include errno */ - klispE_throw_simple(K, "the file couldn't be renamed"); - return; + klispE_throw_errno_with_irritants(K, "rename", 2, old_filename, new_filename); + return; } else { kapply_cc(K, KINERT); return; diff --git a/src/kport.c b/src/kport.c @@ -14,6 +14,7 @@ #include "kerror.h" #include "kstring.h" #include "kgc.h" +#include "kpair.h" /* XXX: per the c spec, this truncates the file if it exists! */ /* Ask John: what would be best? Probably should also include delete, @@ -27,7 +28,8 @@ TValue kmake_port(klisp_State *K, TValue filename, bool writep) /* for now always use text mode */ FILE *f = fopen(kstring_buf(filename), writep? "w": "r"); if (f == NULL) { - klispE_throw_simple(K, "could't open file"); + klispE_throw_errno_with_irritants(K, "fopen", 2, filename, + kstring_new_b_imm(K, writep? "w": "r")); return KINERT; } else { return kmake_std_port(K, filename, writep, f); diff --git a/src/krepl.c b/src/krepl.c @@ -19,6 +19,7 @@ #include "ksymbol.h" #include "kport.h" #include "kpair.h" +#include "kgerror.h" /* for names */ #include "ktable.h" @@ -264,6 +265,9 @@ void kinit_repl(klisp_State *K) krooted_tvs_pop(K); krooted_tvs_pop(K); + /* Create error continuation hierarchy. */ + kinit_error_hierarchy(K); + #if KTRACK_SI /* save the root cont in next_si to let the loop continuations have source info, this is hackish but works */ diff --git a/src/kscript.c b/src/kscript.c @@ -21,6 +21,7 @@ #include "kport.h" #include "kpair.h" #include "kgcontrol.h" +#include "kgerror.h" /* for names */ #include "ktable.h" @@ -225,6 +226,9 @@ void kinit_script(klisp_State *K, int argc, char *argv[]) krooted_tvs_pop(K); krooted_tvs_pop(K); + /* Create error continuation hierarchy. */ + kinit_error_hierarchy(K); + TValue argv_value = RSI(argv2value(K, argc, argv)); TValue loader = RSI(loader_body(K, argv_value, std_env)); TValue loader_cont = RSI(kmake_continuation(K, root_cont, do_seq, 2, loader, std_env)); diff --git a/src/kstate.c b/src/kstate.c @@ -79,6 +79,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) { K->module_params_sym = KINERT; K->root_cont = KINERT; K->error_cont = KINERT; + K->system_error_cont = KINERT; K->frealloc = f; K->ud = ud; diff --git a/src/kstate.h b/src/kstate.h @@ -73,6 +73,7 @@ struct klisp_State { /* it is used in get-module */ TValue root_cont; TValue error_cont; + TValue system_error_cont; /* initialized by kinit_error_hierarchy() */ klisp_Alloc frealloc; /* function to reallocate memory */ void *ud; /* auxiliary data to `frealloc' */ diff --git a/src/tests/error.k b/src/tests/error.k @@ -44,3 +44,26 @@ ($check-error (error-object-irritants)) ($check-error (error-object-irritants e1 e2)) ($check-error (error-object-irritants "not an error object"))) + +;; XXX system-error-continuation + +($check-predicate (continuation? system-error-continuation)) + +($let* + ( (catch-system-error + ($lambda (proc) + (guard-dynamic-extent + () + proc + (list (list system-error-continuation + ($lambda (obj divert) + ($let + ( ( ((service code message errno) . tail) + (error-object-irritants obj))) + (apply divert (list* service code tail)))))))))) + + ($check equal? + (catch-system-error + ($lambda () + (rename-file "nonexistent-file-name" "other-file-name"))) + (list "rename" "ENOENT" "nonexistent-file-name" "other-file-name")))