From 460bcf507b2c339abbb84e8dc37dd42fc256907e Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Wed, 14 Jan 2026 00:00:42 -0800 Subject: [PATCH] Make backtraces better --- src/kernel.sl | 175 ++------------------------------------------------ src/lisp.c | 61 ++++++++++++------ src/lisp.h | 67 ++++++++++--------- src/main.c | 18 +++++- 4 files changed, 100 insertions(+), 221 deletions(-) diff --git a/src/kernel.sl b/src/kernel.sl index d5bd362..fd31d2a 100644 --- a/src/kernel.sl +++ b/src/kernel.sl @@ -118,10 +118,11 @@ (setq vars (pair (first ent) vars) vals (pair (second ent) vals)) (throw 'argument-error)))) - (apply 'list 'funcall (apply 'list 'lambda - (reverse vars) - (list 'declare (list 'name '::let)) - body) + (apply 'list (apply 'list 'lambda + (reverse vars) + (list 'declare (list 'name '::let) + (list 'no-backtrace t)) + body) (reverse vals))))) (defmacro let* (bindings &rest body) @@ -290,11 +291,6 @@ (define-type-predicate hash-table hash-table-p) (define-type-predicate user-pointer user-pointer-p) (define-type-predicate record recordp) -(define-type-predicate native-record (obj &opt backing-type) - (and (recordp obj) - (record-native-p obj) - (or (not backing-type) - (typep (record-native-backing obj) backing-type)))) (define-type-predicate number (obj &opt min max) (typep obj (list 'or (list 'float min max) (list 'integer min max)))) @@ -510,163 +506,4 @@ (list (list 'set-symbol-value-docstr (list '\' name) doc))))) -;; Object stuff -(defun symbol-class (symbol) - (unless (symbolp symbol) - (throw 'type-error '(symbolp) symbol)) - (get symbol 'class)) - -(defun set-symbol-class (symbol class) - (unless (symbolp symbol) - (throw 'type-error '(symbolp) symbol)) - (put symbol 'class class)) - -(defun classp (obj) - (or (eq (type-of obj) 'class))) -(define-type-predicate class classp) - -(defun %default-slot-value (class obj slot) - (let* ((slots (record-slot class 3)) - (unbound ::unbound) - (res (gethash slots slot unbound))) - (when (eq res unbound) - (throw 'slot-error slot)) - (record-slot obj res))) - -(defun %default-set-slot-value (class obj slot value) - (let* ((slots (record-slot class 3)) - (unbound ::unbound) - (res (gethash slots slot unbound))) - (when (eq res unbound) - (throw 'slot-error slot)) - (set-record-slot obj res value))) - -(defun %default-lookup-method (class method) - (let* ((methods (record-slot class 4)) - (unbound ::unbound) - (res (gethash methods method unbound))) - (unless (eq res unbound) - res))) - -(defun %default-define-method (class method function) - (let* ((methods (record-slot class 4))) - (puthash methods method function))) - -(defun %construct-class (class name superclass &rest slots) - nil) - -;; Objects are records that have a class object as their first slot -;; Classes are records with their type set to 'class. The slots are -;; - class (class) -;; - name (symbol) -;; - superclass (class) -;; - slots (hash-table[symbol->integer]) -;; - methods (hash-table[symbol->function]) -;; -;; Special methods: -;; - (@construct obj &rest args) -;; Called when a new instance of this class is created. The newly allocated -;; object is passed to OBJ and the arguments to 'make-instance are passed to -;; ARGS. -;; - (@print obj stream) -;; Called to write OBJ out to STREAM. -(set-symbol-class 'class (make-record 'class 3)) -(let ((class (symbol-class 'standard-class)) - (slots (make-hash-table)) - (methods (make-hash-table))) - (set-record-slot class 0 class) - (set-record-slot class 1 'class) - (set-record-slot class 2 class) - (set-record-slot class 3 slots) - (set-record-slot class 4 methods) - - (puthash slots 'name 1) - (puthash slots 'superclass 2) - (puthash slots 'slots 3) - (puthash slots 'methods 4) - - (puthash methods '@construct '%construct-class) - (puthash methods '@slot-value '%default-slot-value) - (puthash methods '@set-slot-value '%default-set-slot-value) - (puthash methods '@lookup-method '%default-lookup-method) - (puthash methods '@define-method '%default-define-method)) - -(defun objectp (obj) - "Return non-nil if OBJ is an object." - (and (recordp obj) - (plusp (length obj)) - (classp (record-slot obj 0)))) -(define-type-predicate object objectp) - -(defun object-class (obj) - "Return the class of OBJ." - (unless (objectp obj) - (throw 'type-error '(objectp) obj)) - (record-slot obj 0)) - -(defun methodp (obj) - "Return non-nil if OBJ is a method object." - (if (symbolp obj) - (methodp (symbol-function obj t)) - (and (eq (type-of obj) 'method) - (= (length obj) 1) - (callable-record-p obj)))) -(define-type-predicate method methodp) - -;; Methods are callable records of length 1. The first slot is a hash table -;; mapping extra types to functions. -(defun make-method () - "Return a new empty method object." - (let ((record (make-record 'method 1)) - (extra-types (make-hash-table))) - (flet ((call-default (obj &rest args) - (let* ((unbound ::unbound) - (res (gethash extra-types t unbound))) - (when (eq res unbound) - (throw 'no-applicable-method-error obj)) - (apply res obj args)))) - (set-record-function - record - (lambda (obj &rest args) - (if (objectp obj) - (let ((method ())))) - (cond - ((and (objectp obj))))))) - (set-record-slot record 0 extra-types) - record)) - -(defun %class-max-slot-index (class) - "Return the highest slot index of CLASS." - (let ((max 0)) - (foreach (lambda (key val) - (when (> val max) - (setq max val))) - (record-slot class 2)) - max)) - -(defun make-instance (class &rest args) - (tcase class - (symbol (setq class (symbol-class class))) - ((not class) (throw 'type-error '(classp) class))) - (let ((constructor (gethash (record-slot class 3) '@construct)) - (object (make-record (record-slot class - (%class-max-slot-index class))))) - (when (functionp constructor) - (apply constructor object args)) - object)) - -(defmacro defclass (name &rest rest) - (unless (symbolp name) - (throw 'type-error '(symbolp) name)) - (let (doc) - (when (stringp (head rest)) - (setq doc (head rest) - rest (head rest))) - ())) - -(println (make-instance ())) - -(println (symbol-class 'standard-class)) -(doindex (i (symbol-class 'standard-class)) - (print "- ") - (println (record-slot (symbol-class 'standard-class) i))) +(dovector (a [1 2 3])) diff --git a/src/lisp.c b/src/lisp.c index 75379c6..f72ee53 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -75,6 +75,7 @@ DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys"); DEF_STATIC_SYMBOL(rest, "&rest"); DEF_STATIC_SYMBOL(declare, "declare"); DEF_STATIC_SYMBOL(name, "name"); +DEF_STATIC_SYMBOL(no_backtrace, "no-backtrace"); DEF_STATIC_SYMBOL(symbol, "symbol"); DEF_STATIC_SYMBOL(integer, "integer"); @@ -173,6 +174,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) { case TYPE_FUNCTION: { LispFunction *fn = obj; *held = refcount_list_push(*held, fn->name); + *held = refcount_list_push(*held, fn->props); *held = refcount_list_push(*held, fn->return_tag); *held = refcount_list_push(*held, fn->args); *held = refcount_list_push(*held, fn->kwargs); @@ -351,7 +353,7 @@ static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod, LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args, LispVal *lexenv, LispVal *body, LispVal *doc, - bool is_macro) { + bool is_macro, LispVal *props) { CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION); self->is_builtin = false; self->is_macro = is_macro; @@ -375,6 +377,7 @@ LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args, self->lexenv = refcount_ref(lexenv); self->doc = refcount_ref(doc); self->body = refcount_ref(body); + self->props = refcount_ref(props); return LISPVAL(self); } @@ -1007,7 +1010,7 @@ static LispVal *call_function(LispVal *func, LispVal *args, refcount_ref(args); WITH_CLEANUP(args, { WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS( - refcount_ref(fobj->name), refcount_ref(args), + refcount_ref(fobj), refcount_ref(args), false, // make sure the lexenv is nil { the_stack->hidden = false; @@ -1205,7 +1208,7 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form, LispVal *lexical_macros), WITH_CLEANUP(return_ptr, { WITH_CLEANUP(fobj, { WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS( - refcount_ref(HEAD(form)), refcount_ref(TAIL(form)), false, + refcount_ref(fobj), refcount_ref(TAIL(form)), false, { the_stack->hidden = false; if (!NILP(fobj->return_tag)) { @@ -1590,14 +1593,20 @@ DEFMACRO( // true if the form was a declare form static bool parse_function_declare(LispVal *form, LispVal **name_ptr, - bool *is_macro_ptr) { + bool *is_macro_ptr, LispVal *props_ht) { if (PAIRP(form) && HEAD(form) == Qdeclare) { FOREACH(elt, TAIL(form)) { if (name_ptr && PAIRP(elt) && HEAD(elt) == Qname && PAIRP(TAIL(elt))) { *name_ptr = HEAD(TAIL(elt)); - } else if (is_macro_ptr && elt == Qmacro) { + } else if (is_macro_ptr + && (elt == Qmacro + || (PAIRP(elt) && HEAD(elt) == Qmacro))) { *is_macro_ptr = true; + } else if (SYMBOLP(elt)) { + puthash(props_ht, elt, Qt); + } else if (PAIRP(elt) && SYMBOLP(HEAD(elt)) && LISTP(TAIL(elt))) { + puthash(props_ht, HEAD(elt), HEAD(TAIL(elt))); } } return true; @@ -1663,7 +1672,8 @@ DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)", } LispVal *name = Qunbound; bool is_macro = false; - if (parse_function_declare(HEAD(body), &name, &is_macro)) { + LispVal *props_ht = make_lisp_hashtable(Qnil, Qnil); + if (parse_function_declare(HEAD(body), &name, &is_macro, props_ht)) { body = TAIL(body); } LispVal *return_tag; @@ -1673,21 +1683,26 @@ DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)", tag_name = Qnil; return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) Qnil)->name)); } else { - CHECK_TYPE(TYPE_SYMBOL, name); + if (!SYMBOLP(name)) { + refcount_unref(props_ht); + CHECK_TYPE(TYPE_SYMBOL, name); + } return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name)); tag_name = name; } LispVal *func = Qnil; - WITH_CLEANUP(return_tag, { - LispVal *expanded_body = - expand_function_body(tag_name, return_tag, body); - LispVal *exp_args = Fcopy_list(args); - WITH_CLEANUP(exp_args, { - expand_lambda_list_for_toplevel(exp_args); - WITH_CLEANUP(expanded_body, { - func = make_lisp_function(name, return_tag, args, - the_stack->lexenv, expanded_body, doc, - is_macro); + WITH_CLEANUP(props_ht, { + WITH_CLEANUP(return_tag, { + LispVal *expanded_body = + expand_function_body(tag_name, return_tag, body); + LispVal *exp_args = Fcopy_list(args); + WITH_CLEANUP(exp_args, { + expand_lambda_list_for_toplevel(exp_args); + WITH_CLEANUP(expanded_body, { + func = make_lisp_function(name, return_tag, args, + the_stack->lexenv, expanded_body, + doc, is_macro, props_ht); + }); }); }); }); @@ -1838,6 +1853,12 @@ DEFUN(function_docstr, "function-docstr", (LispVal * func), "(func)", return retval; } +DEFUN(function_properties, "function-properties", (LispVal * func), "(func)", + "Return the property hash table of FUNC.") { + CHECK_TYPE(TYPE_FUNCTION, func); + return refcount_ref(((LispFunction *) func)->props); +} + void free_opt_arg_desc(void *obj) { struct OptArgDesc *oad = obj; refcount_unref(oad->name); @@ -3716,7 +3737,9 @@ static int64_t internal_print(void *obj, int64_t fd, bool readably, int64_t np = CHECK_IO_RESULT(dprintf(fd, "["), fd); for (size_t i = 0; i < v->length; ++i) { np += internal_print(v->data[i], fd, readably, true); - np += CHECK_IO_RESULT(dprintf(fd, " "), fd); + if (i != v->length - 1) { + np += CHECK_IO_RESULT(dprintf(fd, " "), fd); + } } np += CHECK_IO_RESULT(dprintf(fd, "]"), fd); return np; @@ -4228,6 +4251,7 @@ static void register_symbols_and_functions(void) { REGISTER_SYMBOL(rest); REGISTER_SYMBOL(declare); REGISTER_SYMBOL(name); + REGISTER_SYMBOL(no_backtrace); REGISTER_SYMBOL(comma); REGISTER_SYMBOL(comma_at); REGISTER_SYMBOL(backquote); @@ -4316,6 +4340,7 @@ static void register_symbols_and_functions(void) { REGISTER_FUNCTION(builtinp); REGISTER_FUNCTION(special_form_p); REGISTER_FUNCTION(function_docstr); + REGISTER_FUNCTION(function_properties); // ########################### // # Pair and List Functions # diff --git a/src/lisp.h b/src/lisp.h index 21f2738..0fdcc66 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -108,6 +108,7 @@ typedef struct { LispVal *args; bool is_builtin; bool is_macro; + LispVal *props; // hash-table size_t n_req; LispVal *rargs; @@ -197,6 +198,7 @@ extern LispVal *Qallow_other_keys; extern LispVal *Qrest; extern LispVal *Qdeclare; extern LispVal *Qname; +extern LispVal *Qno_backtrace; // Type symbols not defined elsewhere extern LispVal *Qsymbol; @@ -219,8 +221,7 @@ extern LispVal *current_package; // ################### // # Type predicates # // ################### -#define STATICP(v) (LISPVAL(v)->ref_count < 0) -#define TYPEOF(v) (LISPVAL(v)->type) +#define TYPEOF(v) (LISPVAL(v)->type) // only use on symbols! #define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_const_value || KEYWORDP(v)) @@ -354,17 +355,18 @@ inline static bool NUMBERP(LispVal *v) { ((LispSymbol *) Q##sym)->is_const_value = true; \ ((LispSymbol *) Q##sym)->is_special_var = true; #define REGISTER_SYMBOL(sym) REGISTER_SYMBOL_INTO(sym, system_package) -#define REGISTER_STATIC_FUNCTION(name) \ - REGISTER_SYMBOL_NOINTERN(name); \ - { \ - LispVal *obj = ((LispSymbol *) Q##name)->function; \ - refcount_init_static(obj); \ - ((LispFunction *) (obj))->doc = STATIC_STRING(_F##name##doccstr); \ - LispVal *src = STATIC_STRING(_F##name##lisp_args_cstr); \ - LispVal *a = Fread(src, system_package); \ - set_function_args((LispFunction *) (obj), a); \ - refcount_unref(src); \ - refcount_unref(a); \ +#define REGISTER_STATIC_FUNCTION(name) \ + REGISTER_SYMBOL_NOINTERN(name); \ + { \ + LispVal *obj = ((LispSymbol *) Q##name)->function; \ + refcount_init_static(obj); \ + ((LispFunction *) (obj))->doc = STATIC_STRING(_F##name##doccstr); \ + ((LispFunction *) (obj))->props = make_lisp_hashtable(Qnil, Qnil); \ + LispVal *src = STATIC_STRING(_F##name##lisp_args_cstr); \ + LispVal *a = Fread(src, system_package); \ + set_function_args((LispFunction *) (obj), a); \ + refcount_unref(src); \ + refcount_unref(a); \ } #define REGISTER_FUNCTION(fn) \ REGISTER_STATIC_FUNCTION(fn); \ @@ -411,7 +413,7 @@ LispVal *make_lisp_float(long double value); LispVal *make_lisp_vector(LispVal **data, size_t length); LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args, LispVal *lexenv, LispVal *body, LispVal *doc, - bool is_macro); + bool is_macro, LispVal *props); LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn); LispVal *make_user_pointer(void *data, void (*free_func)(void *)); #define ALLOC_USERPTR(type, free_func) \ @@ -484,6 +486,7 @@ DECLARE_FUNCTION(macrop, (LispVal * val, LispVal *lexical_macros)); DECLARE_FUNCTION(builtinp, (LispVal * val)); DECLARE_FUNCTION(special_form_p, (LispVal * val)); DECLARE_FUNCTION(function_docstr, (LispVal * func)); +DECLARE_FUNCTION(function_properties, (LispVal * func)); struct OptArgDesc { size_t index; // only for keywords @@ -702,25 +705,25 @@ void cancel_cleanup(void *handle); // ################ // # Stack Macros # // ################ -#define WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \ - on_return) \ - stack_enter(name, detail, inherit); \ - { \ - int __with_push_frame_jmpval = setjmp(the_stack->start); \ - if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \ - body \ - } else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \ - on_return; \ - refcount_unref(stack_return); \ - stack_return = NULL; \ - } \ - stack_leave(); \ +#define WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(func_obj, detail, inherit, \ + body, on_return) \ + stack_enter(func_obj, detail, inherit); \ + { \ + int __with_push_frame_jmpval = setjmp(the_stack->start); \ + if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \ + body \ + } else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \ + on_return; \ + refcount_unref(stack_return); \ + stack_return = NULL; \ + } \ + stack_leave(); \ } -#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \ - WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, ) -#define WITH_PUSH_FRAME(name, detail, inherit, body) \ - WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \ - body) +#define WITH_PUSH_FRAME_NO_REF(func_obj, detail, inherit, body) \ + WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(func_obj, detail, inherit, body, ) +#define WITH_PUSH_FRAME(func_obj, detail, inherit, body) \ + WITH_PUSH_FRAME_NO_REF(refcount_ref(func_obj), refcount_ref(detail), \ + inherit, body) #define WITH_CLEANUP_DOUBLE_PTR(var, body) \ { \ diff --git a/src/main.c b/src/main.c index 0660d19..8ee4c86 100644 --- a/src/main.c +++ b/src/main.c @@ -30,9 +30,23 @@ STATIC_DEFUN(toplevel_error_handler, "toplevel-error-handler", } fprintf(stderr, "\nBacktrace (toplevel comes last):\n"); FOREACH(frame, backtrace) { + if (!FUNCTIONP(HEAD(frame))) { + // not an actual function + continue; + } + LispFunction *fobj = (LispFunction *) HEAD(frame); + LispVal *hide_obj = Fgethash(fobj->props, Qno_backtrace, Qnil); + bool hide = !NILP(hide_obj); + refcount_unref(hide_obj); + if (hide) { + continue; + } + LispVal *name = NILP(fobj->name) ? LISPVAL(fobj) : fobj->name; + LispVal *to_print = Fpair(name, TAIL(frame)); fprintf(stderr, " "); - Fprint(frame, Qt, stream); - if (SYMBOLP(HEAD(frame)) && !NILP(Fmacrop(HEAD(frame), Qnil))) { + Fprint(to_print, Qt, stream); + refcount_unref(to_print); + if (!fobj->is_builtin && fobj->is_macro) { fprintf(stderr, " ;; macro"); } fputc('\n', stderr);