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:
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")))
