diff --git a/include/picrin/pair.h b/include/picrin/pair.h index a298e257..28c722bf 100644 --- a/include/picrin/pair.h +++ b/include/picrin/pair.h @@ -7,6 +7,7 @@ pic_value pic_cdr(pic_state *, pic_value); bool pic_list_p(pic_state *, pic_value); pic_value pic_list(pic_state *, size_t, ...); +pic_value pic_list_from_array(pic_state *, size_t, pic_value *); int pic_length(pic_state *, pic_value); pic_value pic_reverse(pic_state *, pic_value); diff --git a/src/error.c b/src/error.c index 7f98508a..502224c5 100644 --- a/src/error.c +++ b/src/error.c @@ -1,7 +1,9 @@ #include #include +#include #include "picrin.h" +#include "picrin/pair.h" #include "picrin/proc.h" #include "picrin/error.h" @@ -25,7 +27,8 @@ pic_errorf(pic_state *pic, const char *msg, size_t n, ...) void pic_abort(pic_state *pic, const char *msg) { - puts(msg); + fprintf(stderr, "abort: %s\n", msg); + fflush(stderr); abort(); } @@ -114,6 +117,26 @@ pic_error_raise_continuable(pic_state *pic) return a; } +static pic_value +pic_error_error(pic_state *pic) +{ + char *str; + int len, argc; + pic_value *argv; + struct pic_error *e; + + pic_get_args(pic, "s*", &str, &len, &argc, &argv); + + e = (struct pic_error *)pic_obj_alloc(pic, sizeof(struct pic_error), PIC_TT_ERROR); + e->type = PIC_ERROR_OTHER; + e->msg = strdup(str); + e->irrs = pic_list_from_array(pic, argc, argv); + + pic_raise(pic, pic_obj_value(e)); + + /* never returns */ + return pic_undef_value(); +} static pic_value pic_error_error_object_p(pic_state *pic) { @@ -182,6 +205,7 @@ pic_init_error(pic_state *pic) pic_defun(pic, "with-exception-handler", pic_error_with_exception_handler); pic_defun(pic, "raise", pic_error_raise); pic_defun(pic, "raise-continuable", pic_error_raise_continuable); + pic_defun(pic, "error", pic_error_error); pic_defun(pic, "error-object?", pic_error_error_object_p); pic_defun(pic, "error-object-message", pic_error_error_object_message); pic_defun(pic, "error-object-irritants", pic_error_error_object_irritants); diff --git a/src/pair.c b/src/pair.c index 6d96fcb6..d3ebc772 100644 --- a/src/pair.c +++ b/src/pair.c @@ -67,6 +67,19 @@ pic_list(pic_state *pic, size_t c, ...) return pic_reverse(pic, v); } +pic_value +pic_list_from_array(pic_state *pic, size_t c, pic_value *vs) +{ + pic_value v; + int i; + + v = pic_nil_value(); + for (i = 0; i < c; ++i) { + v = pic_cons(pic, vs[i], v); + } + return pic_reverse(pic, v); +} + int pic_length(pic_state *pic, pic_value obj) {