More exception stuff

lisp/kernel.gl

@@ -1,7 +1,3 @@
 ;; -*- mode: lisp-data -*-
 
-(fset 'test-fun (lambda (x)
+(function-arity (lambda (y &optional x x)))
-                  (error (list x))))
-
-(test-fun "hi")
-

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
+        signal_value_constant(sym);
-        abort();
     }
     ((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
+            lisp_signal(Qargument_error,
-            abort();
+                        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, ",@");

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
+        signal_value_constant(sym);
-        abort();
     }
     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);

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
+        signal_argument_error(res);
-        printf("Bad arguments to builtin \"");
-        debug_print(stdout, orig_func);
-        printf("\": %s\n", process_args_strerror(res));
-        abort();
     }
     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
+        signal_argument_error(par);
-        fprintf(stderr, "Bad args to interp func: %s\n",
-                process_args_strerror(par));
-        abort();
     }
     return UNWIND_AND_RETURN(stack_ref, Fprogn(fobj->impl.interp.body));
 }
 
-DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
+static LispFunction *coerce_to_function(LispVal *func) {
-      "") {
-    StackFrame *stack_ref = LISP_STACK_REF();
-    push_call_frame(func, args);
     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
+        signal_type_error(fobj, LIST(Qcallable));
-        fprintf(stderr, "Not a function: ");
-        debug_print(stderr, func);
-        fputc('\n', stderr);
-        abort();
     }
     // 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
+                    lisp_signal(
-                    fprintf(stderr, "Invalid (declare (name ...)) form!\n");
+                        Qfunction_declare_form_error,
-                    abort();
+                        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
+        const char *c_msg = llps_strerror(llpr.status);
-        fprintf(stderr,
+        LispVal *msg = make_lisp_string(c_msg, strlen(c_msg), false, false);
-                "Lambda list parse error: %s: ", llps_strerror(llpr.status));
+        lisp_signal(Qlambda_list_error, msg);
-        debug_print(stderr, args);
-        fputc('\n', stderr);
-        abort();
     }
     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);

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

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);
 }

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
+        lisp_signal(Qunbound_variable_error, LIST(name));
-        printf("Unbound symbol: ");
-        debug_print(stdout, name);
-        fputc('\n', stdout);
-        abort();
     }
     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
+        lisp_signal(Qargument_error,
-        abort();
+                    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
+                signal_type_error(XCAR(binding), LIST(Qsymbol));
-                abort();
             }
             RPLACA(XCDR(binding), Feval(SECOND(binding), Vlexical_environment));
         } else if (!SYMBOLP(binding)) {
-            // TODO better error
+            signal_type_error(binding, LIST(Qsymbol));
-            abort();
         }
     }
     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);

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

src/lisp_string.c

@@ -1,5 +1,7 @@
 #include "lisp_string.h"
 
+#include <stdarg.h>
+#include <stdio.h>
 #include <string.h>
 
 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");

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

src/main.c

@@ -37,9 +37,13 @@ int main(int argc, const char **argv) {
                 LispVal *args = FOURTH(frame);
                 fprintf(stderr, " %c ", evaled ? '-' : '*');
                 Fprinc(name, Qerror_write_byte);
+                if (NILP(args)) {
+                    fprintf(stderr, "()\n");
+                } else {
                     Fprinc(args, Qerror_write_byte);
                     fputc('\n', stderr);
                 }
+            }
             CLEAR_EXCEPTION();
             had_toplevel_error = true;
             goto toplevel_error;

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
+        signal_type_error(ch, Qchar);
-        abort();
     }
     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) {
+    check_print_base(opts->base);
-        opts->base = 10;
-    }
     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
+        signal_type_error(name, Qcondition_class);
-        abort();
     }
     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:

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);
 

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) {
+    if (the_stack.depth == LISP_STACK_SOFT_MAX_DEPTH) {
-        // TODO error
+        lisp_signal(Qexcessive_lisp_nesting_error, Qnil);
-        abort();
     }
     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
+        signal_value_constant(name);
-        abort();
     }
     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
+        signal_value_constant(name);
-        abort();
     }
     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);

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