Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Make backtraces better

Browse Source
This commit is contained in:
Alexander Rosenberg
2026-01-14 00:00:42 -08:00
parent f1d3a71c32
commit 460bcf507b
4 changed files with 100 additions and 221 deletions
Download Patch File Download Diff File Expand all files Collapse all files

171
src/kernel.sl
View File

@ -118,9 +118,10 @@
(setq vars (pair (first ent) vars)
vals (pair (second ent) vals))
(throw 'argument-error))))
(apply 'list 'funcall (apply 'list 'lambda
(apply 'list (apply 'list 'lambda
(reverse vars)
(list 'declare (list 'name '::let))
(list 'declare (list 'name '::let)
(list 'no-backtrace t))
body)
(reverse vals)))))
@ -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]))

41
src/lisp.c
View File

@ -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,11 +1683,15 @@ DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)",
tag_name = Qnil;
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) Qnil)->name));
} else {
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(props_ht, {
WITH_CLEANUP(return_tag, {
LispVal *expanded_body =
expand_function_body(tag_name, return_tag, body);
@ -1686,8 +1700,9 @@ DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)",
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);
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,8 +3737,10 @@ 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);
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 #

23
src/lisp.h
View File

@ -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,7 +221,6 @@ extern LispVal *current_package;
// ###################
// # Type predicates #
// ###################
#define STATICP(v) (LISPVAL(v)->ref_count < 0)
#define TYPEOF(v) (LISPVAL(v)->type)
// only use on symbols!
@ -360,6 +361,7 @@ inline static bool NUMBERP(LispVal *v) {
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); \
@ -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,9 +705,9 @@ 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); \
#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) { \
@ -716,11 +719,11 @@ void cancel_cleanup(void *handle);
} \
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) \
{ \

18
src/main.c
View File

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