commit 1a3a9ea745d00a5a2f686839849bf3b9da78cfc7
parent 218051473ab30d17a601fb08fbae8d26c56ce6bc
Author: Oto Havle <havleoto@gmail.com>
Date: Mon, 31 Oct 2011 12:57:26 +0100
Added error, error-object?, error-object-message, error-object-irritants.
Diffstat:
6 files changed, 142 insertions(+), 2 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -38,7 +38,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
kgpromises.o kgkd_vars.o kgks_vars.o kgports.o kgchars.o kgnumbers.o \
- kgstrings.o kgblobs.o kgsystem.o \
+ kgstrings.o kgblobs.o kgsystem.o kgerror.o \
$(if $(USE_LIBFFI),kgffi.o)
# TEMP: in klisp there is no distinction between core & lib
@@ -169,6 +169,10 @@ kgequalp.o: kgequalp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kstring.h kblob.h kcontinuation.h kerror.h \
kghelpers.h kapplicative.h koperative.h kenvironment.h ksymbol.h kgeqp.h \
kinteger.h imath.h krational.h imrat.h kgequalp.h
+kgerror.o: kgerror.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kstring.h kpair.h kgc.h kerror.h kghelpers.h \
+ kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
+ kgerror.h
kghelpers.o: kghelpers.c kghelpers.h kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kerror.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h
@@ -209,7 +213,7 @@ kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgenvironments.h kgenv_mut.h kgcombiners.h kgcontinuations.h \
kgencapsulations.h kgpromises.h kgkd_vars.h kgks_vars.h kgnumbers.h \
kgstrings.h kgchars.h kgports.h kgblobs.h ktable.h keval.h krepl.h \
- kscript.h kgsystem.h kgffi.h
+ kscript.h kgsystem.h kgerror.h kgffi.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
ksymbol.h kstring.h kghelpers.h kpair.h kgc.h kenvironment.h kgchars.h \
diff --git a/src/kgerror.c b/src/kgerror.c
@@ -0,0 +1,63 @@
+/*
+** kgerror.c
+** Error handling features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kstring.h"
+#include "kpair.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgerror.h"
+
+void r7rs_error(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ if (ttispair(ptree) && ttisstring(kcar(ptree))) {
+ klispE_throw_with_irritants(K, kstring_buf(kcar(ptree)), kcdr(ptree));
+ } else {
+ klispE_throw_with_irritants(K, "Unknown error in user code", ptree);
+ }
+}
+
+void error_object_message(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "error object", ttiserror, error_tv);
+ Error *err_obj = tv2error(error_tv);
+ assert(ttisstring(err_obj->msg));
+ kapply_cc(K, err_obj->msg);
+}
+
+void error_object_irritants(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, ptree, "error object", ttiserror, error_tv);
+ Error *err_obj = tv2error(error_tv);
+ kapply_cc(K, err_obj->irritants);
+}
+
+/* init ground */
+void kinit_error_ground_env(klisp_State *K)
+{
+ TValue ground_env = K->ground_env;
+ TValue symbol, value;
+
+ add_applicative(K, ground_env, "error-object?", typep, 2, symbol, i2tv(K_TERROR));
+ add_applicative(K, ground_env, "error", r7rs_error, 0);
+ add_applicative(K, ground_env, "error-object-message", error_object_message, 0);
+ add_applicative(K, ground_env, "error-object-irritants", error_object_irritants, 0);
+}
diff --git a/src/kgerror.h b/src/kgerror.h
@@ -0,0 +1,24 @@
+/*
+** kgerror.h
+** Error handling features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kgerror_h
+#define kgerror_h
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kobject.h"
+#include "klisp.h"
+#include "kstate.h"
+#include "kghelpers.h"
+
+/* init ground */
+void kinit_error_ground_env(klisp_State *K);
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -37,6 +37,7 @@
#include "kgports.h"
#include "kgblobs.h"
#include "kgsystem.h"
+#include "kgerror.h"
#if KUSE_LIBFFI
# include "kgffi.h"
@@ -143,6 +144,7 @@ void kinit_ground_env(klisp_State *K)
kinit_ports_ground_env(K);
kinit_blobs_ground_env(K);
kinit_system_ground_env(K);
+ kinit_error_ground_env(K);
#if KUSE_LIBFFI
kinit_ffi_ground_env(K);
#endif
diff --git a/src/tests/error.k b/src/tests/error.k
@@ -0,0 +1,46 @@
+;; check.k & test-helpers.k should be loaded
+;;
+;; Tests of error handling applicatives.
+;;
+
+;; XXX error
+;;
+($check-error (error "test"))
+
+;; XXX error-object? error-object-message error-object-irritants
+;;
+($let*
+ ( (capture-error-object
+ ($lambda (proc)
+ (guard-dynamic-extent
+ ()
+ proc
+ (list (list error-continuation
+ ($lambda (obj divert)
+ (apply divert obj)))))))
+ (e1 (capture-error-object ($lambda () (error "a"))))
+ (e2 (capture-error-object ($lambda () (error "b" 1 2 3))))
+ (e3 (capture-error-object ($lambda () (error))))
+ (e4 (capture-error-object ($lambda () (error 1)))))
+
+ ($check-predicate (error-object? e1 e2 e3))
+ ($check-not-predicate (error-object? ""))
+ ($check-not-predicate (error-object? #f))
+ ($check-not-predicate (error-object? ()))
+ ($check-not-predicate (error-object? 0))
+
+ ($check equal? (error-object-message e1) "a")
+ ($check equal? (error-object-message e2) "b")
+
+ ($check-error (error-object-message))
+ ($check-error (error-object-message e1 e2))
+ ($check-error (error-object-message "not an error object"))
+
+ ($check equal? (error-object-irritants e1) ())
+ ($check equal? (error-object-irritants e2) (list 1 2 3))
+ ($check equal? (error-object-irritants e3) ())
+ ($check equal? (error-object-irritants e4) (list 1))
+
+ ($check-error (error-object-irritants))
+ ($check-error (error-object-irritants e1 e2))
+ ($check-error (error-object-irritants "not an error object")))
diff --git a/src/tests/test-all.k b/src/tests/test-all.k
@@ -21,5 +21,6 @@
(load "tests/strings.k")
(load "tests/characters.k")
(load "tests/ports.k")
+(load "tests/error.k")
(check-report)
