From 2533b0db7df9cdba5ee61586d8314ad145d57435 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Thu, 3 Sep 2026 11:33:44 -0700 Subject: [PATCH] More exception stuff --- lisp/kernel.gl | 6 +--- src/base.c | 14 +++++--- src/base.h | 10 ++++-- src/function.c | 84 ++++++++++++++++++++++++++++++++--------------- src/function.h | 13 ++++++++ src/hashtable.c | 16 ++++++--- src/lisp.c | 19 +++++------ src/lisp.h | 3 ++ src/lisp_string.c | 31 +++++++++++++++-- src/lisp_string.h | 5 +++ src/main.c | 8 +++-- src/print.c | 44 +++++++++++++++++++------ src/print.h | 4 +++ src/stack.c | 15 +++++---- src/stack.h | 4 +++ 15 files changed, 200 insertions(+), 76 deletions(-) diff --git a/lisp/kernel.gl b/lisp/kernel.gl index fd8ce7f..05a4180 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,7 +1,3 @@ ;; -*- mode: lisp-data -*- -(fset 'test-fun (lambda (x) - (error (list x)))) - -(test-fun "hi") - +(function-arity (lambda (y &optional x x))) diff --git a/src/base.c b/src/base.c index c3b8178..295f829 100644 --- a/src/base.c +++ b/src/base.c @@ -173,8 +173,7 @@ DEFUN(set, "set", (LispVal * sym, LispVal *value), "(sym value)", "") { DEFUN(fset, "fset", (LispVal * sym, LispVal *value), "(sym value)", "") { CHECK_TYPE(sym, TYPE_SYMBOL); if (CONST_FUNCTION_P(sym)) { - // TODO throw - abort(); + signal_value_constant(sym); } ((LispSymbol *) sym)->function = value; MARK_OBJECT_ADDED(value, sym); @@ -199,6 +198,10 @@ DEFUN(put, "put", (LispVal * sym, LispVal *key, LispVal *val), "(sym key val)", return Fsetplist(sym, Fplist_put(Fsymbol_plist(sym), key, val)); } +noreturn void signal_value_constant(LispVal *value) { + lisp_signal(Qvalue_constant_error, LIST(value)); +} + DEFINE_SYMBOL(fixnum, "fixnum"); DEFINE_SYMBOL(float, "float"); // cons defined in list.c @@ -275,8 +278,8 @@ static void check_handler_bind_handlers(LispVal *handlers) { DOLIST(handler, handlers) { CHECK_LISTP(handler); if (!list_length_eq(handler, 2)) { - // TODO error - abort(); + lisp_signal(Qargument_error, + LIST(LISP_LITSTR("Wrong number of arguments."))); } CHECK_TYPE(XCDR(handler), TYPE_FUNCTION); if (LISTP(XCAR(handler))) { @@ -330,6 +333,9 @@ DEFINE_CONDITION_CLASS(error, t); DEFINE_SYMBOL(type_error, "type-error"); DEFINE_CONDITION_CLASS(type_error, error); +DEFINE_SYMBOL(value_constant_error, "value-constant-error"); +DEFINE_CONDITION_CLASS(value_constant_error, error); + DEFINE_SYMBOL(backquote, "`"); DEFINE_SYMBOL(comma, ","); DEFINE_SYMBOL(comma_at, ",@"); diff --git a/src/base.h b/src/base.h index 7bde8b9..c4a03cb 100644 --- a/src/base.h +++ b/src/base.h @@ -353,6 +353,8 @@ DECLARE_FUNCTION(setplist, (LispVal * sym, LispVal *plist)); DECLARE_FUNCTION(get, (LispVal * sym, LispVal *key, LispVal *def)); DECLARE_FUNCTION(put, (LispVal * sym, LispVal *key, LispVal *val)); +noreturn void signal_value_constant(LispVal *value); + static ALWAYS_INLINE LispVal *SYMBOL_VALUE(LispVal *sym) { assert(SYMBOLP(sym)); LispSymbol *s = (LispSymbol *) sym; @@ -379,12 +381,11 @@ static ALWAYS_INLINE bool DYNAMIC_SYMBOL_P(LispVal *sym) { return ((LispSymbol *) sym)->flags & SYMBOL_DYNAMIC; } -static ALWAYS_INLINE void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) { +static inline void SET_SYMBOL_VALUE(LispVal *sym, LispVal *value) { assert(SYMBOLP(sym)); LispSymbol *s = (LispSymbol *) sym; if (CONST_VALUE_P(sym)) { - // TODO throw - abort(); + signal_value_constant(sym); } switch (s->value_type) { case SYMBOL_NORMAL: @@ -425,6 +426,9 @@ MAKE_CONDITION_CLASS(error); DECLARE_SYMBOL(type_error); MAKE_CONDITION_CLASS(type_error); +DECLARE_SYMBOL(value_constant_error); +MAKE_CONDITION_CLASS(value_constant_error); + // Defined in lisp code (eventually) but used in read.c DECLARE_SYMBOL(backquote); DECLARE_SYMBOL(comma); diff --git a/src/function.c b/src/function.c index 9a8a0d1..6eeab55 100644 --- a/src/function.c +++ b/src/function.c @@ -2,6 +2,7 @@ #include "hashtable.h" #include "lisp.h" +#include "lisp_string.h" #include "list.h" #include "read.h" #include "stack.h" @@ -327,6 +328,12 @@ process_complex_native_args(LispFunction *fobj, LispVal *args, return PROCESS_ARGS_OK; } +static noreturn void signal_argument_error(enum ProcessArgsResult res) { + const char *c_msg = process_args_strerror(res); + LispVal *msg = make_lisp_string(c_msg, strlen(c_msg), false, false); + lisp_signal(Qargument_error, LIST(msg)); +} + static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) { StackFrame *stack_ref = LISP_STACK_REF(); @@ -340,11 +347,7 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, enum ProcessArgsResult res = process_complex_native_args(fobj, args, arg_arr, &rest_idx); if (res != PROCESS_ARGS_OK) { - // TODO better errors - printf("Bad arguments to builtin \""); - debug_print(stdout, orig_func); - printf("\": %s\n", process_args_strerror(res)); - abort(); + signal_argument_error(res); } for (intptr_t i = 0; i < count; ++i) { if (!arg_arr[i]) { @@ -461,18 +464,12 @@ call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) { enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, evaled_args); if (par != PROCESS_ARGS_OK) { - // TODO better error handling - fprintf(stderr, "Bad args to interp func: %s\n", - process_args_strerror(par)); - abort(); + signal_argument_error(par); } return UNWIND_AND_RETURN(stack_ref, Fprogn(fobj->impl.interp.body)); } -DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", - "") { - StackFrame *stack_ref = LISP_STACK_REF(); - push_call_frame(func, args); +static LispFunction *coerce_to_function(LispVal *func) { LispFunction *fobj = func; if (SYMBOLP(func)) { fobj = Fsymbol_function(func, Qt); @@ -480,15 +477,19 @@ DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", fobj = Feval(func, Vlexical_environment); } if (NILP(fobj)) { - // TODO throw exception - fprintf(stderr, "Not a function: "); - debug_print(stderr, func); - fputc('\n', stderr); - abort(); + signal_type_error(fobj, LIST(Qcallable)); } // include symbol here for the error message CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL); assert(FUNCTIONP(fobj)); + return fobj; +} + +DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", + "") { + StackFrame *stack_ref = LISP_STACK_REF(); + push_call_frame(func, args); + LispFunction *fobj = coerce_to_function(func); switch (fobj->type) { case FUNCTION_NATIVE: return UNWIND_AND_RETURN(stack_ref, call_native(func, fobj, args)); @@ -506,9 +507,9 @@ static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) { if (EQ(XCAR(decl), Qname)) { CHECK_TYPE(SECOND(decl), TYPE_SYMBOL); if (!list_length_eq(decl, 2)) { - // TODO better error - fprintf(stderr, "Invalid (declare (name ...)) form!\n"); - abort(); + lisp_signal( + Qfunction_declare_form_error, + LIST(LISP_LITSTR("Invalid (declare (name ...)) form"))); } fobj->name = SECOND(decl); } @@ -523,12 +524,9 @@ DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body), LambdaListParseResult llpr; parse_lambda_list(&llpr, args); if (llpr.status != LLPS_OK) { - // TODO better handling - fprintf(stderr, - "Lambda list parse error: %s: ", llps_strerror(llpr.status)); - debug_print(stderr, args); - fputc('\n', stderr); - abort(); + const char *c_msg = llps_strerror(llpr.status); + LispVal *msg = make_lisp_string(c_msg, strlen(c_msg), false, false); + lisp_signal(Qlambda_list_error, msg); } CHECK_LISTP(body); LispFunction *fobj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION); @@ -549,5 +547,37 @@ DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body), return fobj; } +DEFUN(callablep, "callablep", (LispVal * obj), "(obj)", "") { + if (FUNCTIONP(obj) || (CONSP(obj) && EQ(XCAR(obj), Qlambda)) + || (SYMBOLP(obj) && FUNCTIONP(Fsymbol_function(obj, Qt)))) { + return Qt; + } + return Qnil; +} + +DEFUN(function_arity, "function-arity", (LispVal * func), "(func)", + "Return a list of the form (NUM-REQ NUM-OPT KW-NAMES HAS-REST).") { + LispFunction *fobj = coerce_to_function(func); + LispVal *kw = Qnil; + if (HASH_TABLE_P(fobj->args.kw)) { + HT_FOREACH_INDEX(fobj->args.kw, i) { + kw = CONS(SECOND(HASH_VALUE(fobj->args.kw, i)), kw); + } + } + return LIST(MAKE_FIXNUM(fobj->args.n_req), MAKE_FIXNUM(fobj->args.n_opt), + kw, NILP(fobj->args.rest) ? Qnil : Qt); +} + DEFINE_SYMBOL(declare, "declare"); DEFINE_SYMBOL(name, "name"); + +DEFINE_SYMBOL(callable, "callable"); +DEFINE_SYMBOL(argument_error, "argument-error"); +DEFINE_CONDITION_CLASS(argument_error, error); + +DEFINE_SYMBOL(function_definition_error, "function-definition-error"); +DEFINE_CONDITION_CLASS(function_definition_error, error); +DEFINE_SYMBOL(lambda_list_error, "lambda-list-error"); +DEFINE_CONDITION_CLASS(lambda_list_error, function_definition_error); +DEFINE_SYMBOL(function_declare_form_error, "function-declare-form-error"); +DEFINE_CONDITION_CLASS(function_declare_form_error, function_definition_error); diff --git a/src/function.h b/src/function.h index c1b4439..a619576 100644 --- a/src/function.h +++ b/src/function.h @@ -94,8 +94,21 @@ DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args)); #define CALL0(func) (Ffuncall((func), Qnil)) DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); +DECLARE_FUNCTION(callablep, (LispVal * obj)); +DECLARE_FUNCTION(function_arity, (LispVal * func)); DECLARE_SYMBOL(declare); DECLARE_SYMBOL(name); +DECLARE_SYMBOL(callable); +DECLARE_SYMBOL(argument_error); +MAKE_CONDITION_CLASS(argument_error); + +DECLARE_SYMBOL(function_definition_error); +MAKE_CONDITION_CLASS(function_definition_error); +DECLARE_SYMBOL(lambda_list_error); +MAKE_CONDITION_CLASS(lambda_list_error); +DECLARE_SYMBOL(function_declare_form_error); +MAKE_CONDITION_CLASS(function_declare_form_error); + #endif diff --git a/src/hashtable.c b/src/hashtable.c index c6dfe75..0cb1732 100644 --- a/src/hashtable.c +++ b/src/hashtable.c @@ -1,5 +1,6 @@ #include "hashtable.h" +#include "lisp.h" #include "lisp_string.h" #define INITIAL_SIZE 32 @@ -49,9 +50,11 @@ static uintptr_t hash_key_for_table(LispHashTable *ht, LispVal *key) { return (uintptr_t) key; } else if (ht->hash_fn == Qhash_string) { // needed for initialization return XFIXNUM(Fhash_string(key)); + } else { + LispVal *hash = CALL(ht->hash_fn, key); + CHECK_TYPE(hash, TYPE_FIXNUM); + return XFIXNUM(hash); } - // TODO change - abort(); } static bool compare_keys(LispHashTable *ht, LispVal *key1, LispVal *key2) { @@ -59,9 +62,9 @@ static bool compare_keys(LispHashTable *ht, LispVal *key1, LispVal *key2) { return EQ(key1, key2); } else if (ht->eq_fn == Qstrings_equal) { // needed for initialization return !NILP(Fstrings_equal(key1, key2)); + } else { + return !NILP(CALL(ht->eq_fn, key1, key2)); } - // TODO change - abort(); } static struct HashTableBucket * @@ -101,9 +104,9 @@ static void maybe_rehash(LispHashTable *ht) { } } -// TODO type checking DEFUN(gethash, "gethash", (LispVal * ht, LispVal *key, LispVal *def), "(ht key &optional def)", "") { + CHECK_TYPE(ht, TYPE_HASH_TABLE); LispHashTable *obj = ht; if (obj->cache_bucket && key == obj->cache_bucket->key) { return obj->cache_bucket->value; @@ -116,6 +119,7 @@ DEFUN(gethash, "gethash", (LispVal * ht, LispVal *key, LispVal *def), DEFUN(puthash, "puthash", (LispVal * ht, LispVal *key, LispVal *val), "(ht key val)", "") { + CHECK_TYPE(ht, TYPE_HASH_TABLE); LispHashTable *obj = ht; if (obj->cache_bucket && key == obj->cache_bucket->key) { obj->cache_bucket->value = val; @@ -138,6 +142,7 @@ DEFUN(puthash, "puthash", (LispVal * ht, LispVal *key, LispVal *val), } DEFUN(remhash, "remhash", (LispVal * ht, LispVal *key), "(ht key)", "") { + CHECK_TYPE(ht, TYPE_HASH_TABLE); LispHashTable *obj = ht; uintptr_t hash = hash_key_for_table(ht, key); struct HashTableBucket *b; @@ -170,5 +175,6 @@ DEFUN(remhash, "remhash", (LispVal * ht, LispVal *key), "(ht key)", "") { } DEFUN(hash_table_count, "hash-table-count", (LispVal * ht), "(ht)", "") { + CHECK_TYPE(ht, TYPE_HASH_TABLE); return MAKE_FIXNUM(((LispHashTable *) ht)->count); } diff --git a/src/lisp.c b/src/lisp.c index 3ea6de8..23e9a52 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -79,11 +79,7 @@ static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) { return lexval; } if (SYMBOL_VALUE(name) == Qunbound) { - // TODO better error - printf("Unbound symbol: "); - debug_print(stdout, name); - fputc('\n', stdout); - abort(); + lisp_signal(Qunbound_variable_error, LIST(name)); } return SYMBOL_VALUE(name); } @@ -133,8 +129,8 @@ DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") { DEFSPECIAL(setq, "setq", (LispVal * bindings), "(&rest bindings)", "") { size_t nbindings = list_length(bindings); if (nbindings < 2 || (nbindings & 1) != 0) { - // TODO error - abort(); + lisp_signal(Qargument_error, + LIST(LISP_LITSTR("Wrong number of arguments."))); } LispVal *value = Qnil; for (LispVal *rest = bindings; !NILP(bindings); @@ -153,13 +149,11 @@ DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body), DOLIST(binding, bindings) { if (CONSP(binding) && list_length_eq(binding, 2)) { if (!SYMBOLP(XCAR(binding))) { - // TODO better error - abort(); + signal_type_error(XCAR(binding), LIST(Qsymbol)); } RPLACA(XCDR(binding), Feval(SECOND(binding), Vlexical_environment)); } else if (!SYMBOLP(binding)) { - // TODO better error - abort(); + signal_type_error(binding, LIST(Qsymbol)); } } push_copy_lexenv(); @@ -209,3 +203,6 @@ DEFSPECIAL(or, "or", (LispVal * forms), "(&rest forms)", "") { DEFUN(null, "null", (LispVal * datum), "(datum)", "") { return NILP(datum) ? Qt : Qnil; } + +DEFINE_SYMBOL(unbound_variable_error, "unbound-variable-error"); +DEFINE_CONDITION_CLASS(unbound_variable_error, error); diff --git a/src/lisp.h b/src/lisp.h index 79a250f..9ca5ac2 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -24,4 +24,7 @@ DECLARE_FUNCTION(and, (LispVal * forms)); DECLARE_FUNCTION(or, (LispVal * forms)); DECLARE_FUNCTION(null, (LispVal * datum)); +DECLARE_SYMBOL(unbound_variable_error); +MAKE_CONDITION_CLASS(unbound_variable_error); + #endif diff --git a/src/lisp_string.c b/src/lisp_string.c index 49cef4e..63166c5 100644 --- a/src/lisp_string.c +++ b/src/lisp_string.c @@ -1,5 +1,7 @@ #include "lisp_string.h" +#include +#include #include LispVal *make_lisp_string(const char *data, size_t length, bool take, @@ -17,9 +19,24 @@ LispVal *make_lisp_string(const char *data, size_t length, bool take, return obj; } +LispVal *lisp_sprintf(const char *format, ...) { + va_list args; + va_start(args, format); + va_list args2; + va_copy(args2, args); + int needed = vsnprintf(NULL, 0, format, args2); + va_end(args2); + char *buffer = lisp_malloc(needed + 1); + int printed = vsnprintf(buffer, needed + 1, format, args); + va_end(args); + assert(printed == needed); + return make_lisp_string(buffer, printed, true, false); +} + DEFUN(strings_equal, "strings-equal", (LispVal * string1, LispVal *string2), "(string1 string2)", "") { - // TODO type checking + CHECK_TYPE(string1, TYPE_STRING); + CHECK_TYPE(string2, TYPE_STRING); if (((LispString *) string1)->length != ((LispString *) string2)->length) { return Qnil; } @@ -32,7 +49,7 @@ DEFUN(strings_equal, "strings-equal", (LispVal * string1, LispVal *string2), } DEFUN(hash_string, "hash-string", (LispVal * string), "(string)", "") { - // TODO type checking + CHECK_TYPE(string, TYPE_STRING); size_t len = ((LispString *) string)->length; const char *str = ((LispString *) string)->data; uintptr_t hash = 5381; @@ -41,3 +58,13 @@ DEFUN(hash_string, "hash-string", (LispVal * string), "(string)", "") { } return MAKE_FIXNUM(hash); } + +DEFUN(charp, "charp", (LispVal * obj), "(obj)", "") { + if (!FIXNUMP(obj)) { + return Qnil; + } + fixnum_t val = XFIXNUM(obj); + return (val >= 0 && val <= 255) ? Qt : Qnil; +} + +DEFINE_SYMBOL(char, "char"); diff --git a/src/lisp_string.h b/src/lisp_string.h index a28ef1b..4af4f56 100644 --- a/src/lisp_string.h +++ b/src/lisp_string.h @@ -10,7 +10,12 @@ LispVal *make_lisp_string(const char *data, size_t length, bool take, #define LISP_LITSTR(litstr) \ (make_lisp_string(litstr, sizeof(litstr) - 1, false, false)) +LispVal *lisp_sprintf(const char *format, ...) FORMAT(1, 2); + DECLARE_FUNCTION(strings_equal, (LispVal * string1, LispVal *string2)); DECLARE_FUNCTION(hash_string, (LispVal * string)); +DECLARE_FUNCTION(charp, (LispVal * obj)); +DECLARE_SYMBOL(char); + #endif diff --git a/src/main.c b/src/main.c index 4eb38aa..7323f8f 100644 --- a/src/main.c +++ b/src/main.c @@ -37,8 +37,12 @@ int main(int argc, const char **argv) { LispVal *args = FOURTH(frame); fprintf(stderr, " %c ", evaled ? '-' : '*'); Fprinc(name, Qerror_write_byte); - Fprinc(args, Qerror_write_byte); - fputc('\n', stderr); + if (NILP(args)) { + fprintf(stderr, "()\n"); + } else { + Fprinc(args, Qerror_write_byte); + fputc('\n', stderr); + } } CLEAR_EXCEPTION(); had_toplevel_error = true; diff --git a/src/print.c b/src/print.c index 5a2c8ad..49dcdaa 100644 --- a/src/print.c +++ b/src/print.c @@ -14,16 +14,17 @@ DEFVAR(print_base, "print-base", "", MAKE_FIXNUM(10)); DEFVAR(print_base_upper, "print-base-upper", "", Qt); DEFVAR(print_precision, "print-precision", "", MAKE_FIXNUM(6)); DEFVAR(print_quoted, "print-quoted", "", Qt); +DEFVAR(print_empty_list, "print-empty-list", "", Qnil); static void lisp_fputc(LispVal *ch, FILE *file) { if (NILP(ch)) { fflush(file); + return; } CHECK_TYPE(ch, TYPE_FIXNUM); fixnum_t f = XFIXNUM(ch); if (f < 0 || f > 255) { - // TODO error - abort(); + signal_type_error(ch, Qchar); } fputc(f, file); } @@ -47,6 +48,7 @@ struct PrintOptions { bool base_upper; fixnum_t precision; bool quoted; + bool empty_list; }; struct PrintContext { @@ -56,6 +58,20 @@ struct PrintContext { LispVal *length_stack; }; +static void check_print_base(fixnum_t base) { + switch (base) { + case 2: + case 8: + case 10: + case 16: + break; + default: + lisp_signal( + Qprint_error, + LIST(lisp_sprintf("Invalid base: %" LISP_FIXNUM_PRINTF(d), base))); + } +} + static void init_print_options(struct PrintOptions *opts, bool readable) { opts->readable = readable; opts->circle = !NILP(Vprint_circular); @@ -73,9 +89,7 @@ static void init_print_options(struct PrintOptions *opts, bool readable) { } CHECK_TYPE(Vprint_base, TYPE_FIXNUM); opts->base = XFIXNUM(Vprint_base); - if (opts->base < 2 || opts->base > 16) { - opts->base = 10; - } + check_print_base(opts->base); opts->base_upper = !NILP(Vprint_base_upper); CHECK_TYPE(Vprint_precision, TYPE_FIXNUM); opts->precision = XFIXNUM(Vprint_precision); @@ -85,6 +99,7 @@ static void init_print_options(struct PrintOptions *opts, bool readable) { opts->precision = LISP_FLOAT_MAX_PRECISION; } opts->quoted = !NILP(Vprint_quoted); + opts->empty_list = !NILP(Vprint_empty_list); } static void init_print_context(struct PrintContext *restrict pc, bool readable, @@ -130,7 +145,6 @@ static void print_fixnum_base(struct PrintContext *restrict pc, LispVal *val) { print_char(pc, '6'); break; default: - // TODO error abort(); } print_char(pc, '#'); @@ -139,7 +153,7 @@ static void print_fixnum_base(struct PrintContext *restrict pc, LispVal *val) { static void print_fixnum(struct PrintContext *restrict pc, LispVal *val) { fixnum_t fn = XFIXNUM(val); if (fn == 0) { - Ffuncall(pc->print_char_fun, MAKE_FIXNUM('0')); + CALL(pc->print_char_fun, MAKE_FIXNUM('0')); } else { if (pc->opts.base != 10 && pc->opts.readable) { print_fixnum_base(pc, val); @@ -270,6 +284,10 @@ static void print_pretty_string(struct PrintContext *restrict pc, static void print_readable_symbol(struct PrintContext *restrict pc, LispVal *val) { + if (NILP(val) && pc->opts.empty_list) { + print_buffer(pc, "()", 2); + return; + } LispSymbol *sym = val; assert(STRINGP(sym->name)); LispString *n = sym->name; @@ -292,6 +310,10 @@ static void print_readable_symbol(struct PrintContext *restrict pc, static void print_pretty_symbol(struct PrintContext *restrict pc, LispVal *val) { + if (NILP(val) && pc->opts.empty_list) { + print_buffer(pc, "()", 2); + return; + } LispSymbol *sym = val; assert(STRINGP(sym->name)); print_pretty_string(pc, sym->name); @@ -405,13 +427,12 @@ DEFUN(print_condition, "print-condition", (LispVal * name, LispVal *data, LispVal *print_char_fun), "(name data &optional print-char-fun)", "") { if (NILP(Fcondition_class_p(name))) { - // TODO type error - abort(); + signal_type_error(name, Qcondition_class); } LispVal *printer = Fcondition_printer(name); if (NILP(printer)) { // default format - Fprinc(CONS(name, data), print_char_fun); + Fprin1(CONS(name, data), print_char_fun); } else { // custom format CALL(printer, data, print_char_fun); @@ -419,6 +440,9 @@ DEFUN(print_condition, "print-condition", return Qnil; } +DEFINE_SYMBOL(print_error, "print-error"); +DEFINE_CONDITION_CLASS(print_error, error); + void debug_print(FILE *file, LispVal *obj) { switch (TYPE_OF(obj)) { case TYPE_FIXNUM: diff --git a/src/print.h b/src/print.h index d47f2b1..e289b0f 100644 --- a/src/print.h +++ b/src/print.h @@ -12,6 +12,7 @@ DECLARE_VARIABLE(print_base); DECLARE_VARIABLE(print_base_upper); DECLARE_VARIABLE(print_precision); DECLARE_VARIABLE(print_quoted); +DECLARE_VARIABLE(print_empty_list); // For now, a print character function takes nil to mean flush DECLARE_FUNCTION(write_byte, (LispVal * ch)); @@ -26,6 +27,9 @@ DECLARE_FUNCTION(prin1, (LispVal * val, LispVal *print_char_fun)); DECLARE_FUNCTION(print_condition, (LispVal * name, LispVal *data, LispVal *print_char_fun)); +DECLARE_SYMBOL(print_error); +MAKE_CONDITION_CLASS(print_error); + __attribute__((no_sanitize("address"))) void debug_print(FILE *file, LispVal *obj); diff --git a/src/stack.c b/src/stack.c index be384f3..d597217 100644 --- a/src/stack.c +++ b/src/stack.c @@ -56,9 +56,8 @@ void lisp_teardown_stack(void) { } static ALWAYS_INLINE StackFrame *PUSH_NEW_FRAME(enum StackFrameKind kind) { - if (the_stack.depth == the_stack.max_depth) { - // TODO error - abort(); + if (the_stack.depth == LISP_STACK_SOFT_MAX_DEPTH) { + lisp_signal(Qexcessive_lisp_nesting_error, Qnil); } StackFrame *last_refs = the_stack.depth ? the_stack.frames[the_stack.depth - 1].last_references @@ -250,8 +249,7 @@ void push_dynamic_binding(LispVal *name, LispVal *new_value) { void set_lexical_variable(LispVal *name, LispVal *value) { assert(SYMBOLP(name)); if (CONST_VALUE_P(name)) { - // TODO throw - abort(); + signal_value_constant(name); } if (DYNAMIC_SYMBOL_P(name)) { SET_SYMBOL_VALUE(name, value); @@ -263,8 +261,7 @@ void set_lexical_variable(LispVal *name, LispVal *value) { void new_lexical_variable(LispVal *name, LispVal *value) { assert(SYMBOLP(name)); if (CONST_VALUE_P(name)) { - // TODO throw - abort(); + signal_value_constant(name); } if (DYNAMIC_SYMBOL_P(name)) { push_dynamic_binding(name, value); @@ -366,6 +363,7 @@ noreturn void continue_unwinding(void) { } noreturn void lisp_signal(LispVal *name, LispVal *data) { + CHECK_LISTP(data); if (NILP(Fcondition_class_p(name))) { signal_type_error(name, LIST(Qcondition_class)); } @@ -392,3 +390,6 @@ DEFUN(backtrace, "backtrace", (void), "()", "") { } return out; } + +DEFINE_SYMBOL(excessive_lisp_nesting_error, "excessive-lisp-nesting-error"); +DEFINE_CONDITION_CLASS(excessive_lisp_nesting_error, error); diff --git a/src/stack.h b/src/stack.h index 430519e..aecdbf0 100644 --- a/src/stack.h +++ b/src/stack.h @@ -15,6 +15,7 @@ enum StackFrameKind { }; #define LISP_STACK_MAX_DEPTH 4096 +#define LISP_STACK_SOFT_MAX_DEPTH 4000 #define LOCAL_REFERENCES_BLOCK_LENGTH 64 #define LISP_LONGJMP_FOR_UNWIND 1 @@ -231,4 +232,7 @@ DECLARE_FUNCTION(backtrace, (void) ); } \ }; +DECLARE_SYMBOL(excessive_lisp_nesting_error); +MAKE_CONDITION_CLASS(excessive_lisp_nesting_error); + #endif