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

Support for catching exceptions and reworked lexical variables

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-19 02:34:38 -07:00
parent 91f2ab8e0a
commit 2b7f9b2fd6
4 changed files with 393 additions and 180 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
src/kernel.sl
View File

@ -85,23 +85,12 @@
(setq vars (pair (first ent) vars) (setq vars (pair (first ent) vars)
vals (pair (second ent) vals)) vals (pair (second ent) vals))
(throw 'argument-error)))) (throw 'argument-error))))
(apply 'list 'funcall (apply 'list 'lambda (reverse vars) body) (apply 'list 'funcall (apply 'list 'lambda
(reverse vars)
'(declare (name nil))
body)
(reverse vals))))) (reverse vals)))))
(defun plist-put (plist key value)
(let ((tail plist))
(while (and tail (tail tail))
(if (eq (head tail) key)
(sethead (tail tail) value))
(setq tail (tail (tail tail))))))
(defun put (symbol key value)
(let ((cur (symbol-plist symbol)))
()))
(defun get (symbol key default)
())
(defun lasttail (list) (defun lasttail (list)
"Return the last pair in LIST." "Return the last pair in LIST."
(let (out) (let (out)
@ -146,23 +135,6 @@
(pair pred (tail cond)))) (pair pred (tail cond))))
conds))))) conds)))))
(defun internal-expand-\` (form &opt (level 0)) (defmacro unwind-protect (form &rest unwind-forms)
(tcase (list 'condition-case form
(()))) (pair :finally unwind-forms)))
(defmacro \` (form)
(internal-expand-\` form))
;; (println (macroexpand-1 '`(,@a)))
(defmacro a (form)
(list 'b (ensure-list form)))
(defmacro b (form)
(list 'c (ensure-list form)))
(defmacro c (form)
(list 'd form))
;; (let ((a '(1 2 3)))
;; (println `(,a)))

421
src/lisp.c
View File

@ -170,6 +170,8 @@ DEF_STATIC_SYMBOL(opt, "&opt");
DEF_STATIC_SYMBOL(key, "&key"); DEF_STATIC_SYMBOL(key, "&key");
DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys"); DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys");
DEF_STATIC_SYMBOL(rest, "&rest"); DEF_STATIC_SYMBOL(rest, "&rest");
DEF_STATIC_SYMBOL(declare, "declare");
DEF_STATIC_SYMBOL(name, "name");
static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod, static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod,
LispVal *found_args) { LispVal *found_args) {
@ -368,8 +370,8 @@ malformed:
Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil)); Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
} }
LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body, LispVal *make_lisp_function(LispVal *name, LispVal *args, LispVal *lexenv,
bool is_macro) { LispVal *body, bool is_macro) {
CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION); CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION);
self->is_builtin = false; self->is_builtin = false;
self->is_macro = is_macro; self->is_macro = is_macro;
@ -383,6 +385,7 @@ LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body,
cancel_cleanup(cl); cancel_cleanup(cl);
// do these after the potential throw // do these after the potential throw
self->name = refcount_ref(name);
self->lexenv = refcount_ref(lexenv); self->lexenv = refcount_ref(lexenv);
if (STRINGP(HEAD(body))) { if (STRINGP(HEAD(body))) {
self->doc = refcount_ref(HEAD(body)); self->doc = refcount_ref(HEAD(body));
@ -679,23 +682,21 @@ size_t list_length(LispVal *obj) {
} }
StackFrame *the_stack = NULL; StackFrame *the_stack = NULL;
LispVal *stack_return = NULL;
DEF_STATIC_SYMBOL(toplevel, "toplevel"); DEF_STATIC_SYMBOL(toplevel, "toplevel");
DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); // DO NOT INTERN
DEF_STATIC_SYMBOL(return_signal, "return-signal"); // DO NOT INTERN
void stack_enter(LispVal *name, LispVal *detail, bool inherit) { void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame)); StackFrame *frame = lisp_malloc(sizeof(StackFrame));
frame->name = (LispSymbol *) name; frame->name = (LispSymbol *) name;
frame->hidden = false; frame->hidden = true;
frame->detail = detail; frame->detail = detail;
frame->lexenv = make_lisp_hashtable(Qnil, Qnil); frame->lexenv = Qnil;
if (inherit && the_stack) { if (inherit && the_stack) {
puthash(LISPVAL(frame->lexenv), Qparent_lexenv, frame->lexenv = refcount_ref(the_stack->lexenv);
LISPVAL(the_stack->lexenv));
} }
frame->enable_handlers = true; frame->enable_handlers = true;
frame->handlers = make_lisp_hashtable(Qnil, Qnil); frame->handlers = make_lisp_hashtable(Qnil, Qnil);
frame->unwind_forms = Qnil; frame->unwind_form = Qnil;
frame->cleanup_handlers = NULL; frame->cleanup_handlers = NULL;
frame->next = the_stack; frame->next = the_stack;
@ -709,20 +710,21 @@ void stack_leave(void) {
refcount_unref(frame->detail); refcount_unref(frame->detail);
refcount_unref(frame->lexenv); refcount_unref(frame->lexenv);
refcount_unref(frame->handlers); refcount_unref(frame->handlers);
FOREACH(elt, frame->unwind_forms) {
WITH_PUSH_FRAME(Qnil, Qnil, false, {
the_stack->hidden = true;
refcount_unref(Feval(elt)); //
});
}
refcount_unref(frame->unwind_forms);
while (frame->cleanup_handlers) { while (frame->cleanup_handlers) {
frame->cleanup_handlers->fun(frame->cleanup_handlers->data); frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
struct CleanupHandlerEntry *next = frame->cleanup_handlers->next; struct CleanupHandlerEntry *next = frame->cleanup_handlers->next;
lisp_free(frame->cleanup_handlers); lisp_free(frame->cleanup_handlers);
frame->cleanup_handlers = next; frame->cleanup_handlers = next;
} }
LispVal *unwind_form = frame->unwind_form;
// steal the ref
frame->unwind_form = Qnil;
lisp_free(frame); lisp_free(frame);
if (!NILP(unwind_form)) {
WITH_CLEANUP(unwind_form, {
refcount_unref(Feval(unwind_form)); //
})
}
} }
void *register_cleanup(lisp_cleanup_func_t fun, void *data) { void *register_cleanup(lisp_cleanup_func_t fun, void *data) {
@ -795,15 +797,20 @@ DEFUN(backtrace, "backtrace", (void) ) {
return head; return head;
} }
DEFUN(return_from, "return-from", (LispVal * name, LispVal *value)) {
// TODO actually write this
abort();
}
#pragma GCC diagnostic push #pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion" #pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) { DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
CHECK_TYPE(TYPE_SYMBOL, signal); CHECK_TYPE(TYPE_SYMBOL, signal);
LispVal *error_arg = LispVal *error_arg =
const_list(false, 2, Fpair(signal, rest), Fbacktrace()); const_list(false, 2, Fpair(signal, rest), Fbacktrace());
for (; the_stack; stack_leave()) { while (the_stack) {
if (!the_stack->enable_handlers) { if (!the_stack->enable_handlers) {
continue; goto up_frame;
} }
LispVal *handler = LispVal *handler =
gethash(LISPVAL(the_stack->handlers), signal, Qunbound); gethash(LISPVAL(the_stack->handlers), signal, Qunbound);
@ -816,16 +823,30 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
LispVal *var = HEAD(handler); LispVal *var = HEAD(handler);
LispVal *form = TAIL(handler); LispVal *form = TAIL(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, { WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
if (!NILP(var)) { if (!NILP(var)) {
// TODO make sure this isn't constant // TODO make sure this isn't constant
puthash(the_stack->lexenv, var, error_arg); push_to_lexenv(&the_stack->lexenv, var, error_arg);
} }
WITH_CLEANUP_DOUBLE_PTR(error_arg, { WITH_CLEANUP(error_arg, {
refcount_unref(Feval(form)); // stack_return = Feval(form); //
}); });
}); });
longjmp(the_stack->start, 1); // return a nonzero value longjmp(the_stack->start, STACK_EXIT_THROW);
}
up_frame: {
// steal the form so we can call it after we unwind (in case it
// throws)
LispVal *unwind_form = the_stack->unwind_form;
the_stack->unwind_form = Qnil;
stack_leave();
if (!NILP(unwind_form)) {
void *cl_handler =
register_cleanup(&refcount_unref_as_callback, error_arg);
WITH_CLEANUP(unwind_form, {
refcount_unref(Feval(unwind_form)); //
});
cancel_cleanup(cl_handler);
}
} }
} }
fprintf(stderr, fprintf(stderr,
@ -841,6 +862,8 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
} }
#pragma GCC diagnostic pop #pragma GCC diagnostic pop
DEF_STATIC_SYMBOL(success, ":success");
DEF_STATIC_SYMBOL(finally, ":finally");
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal"); DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error"); DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error"); DEF_STATIC_SYMBOL(read_error, "read-error");
@ -852,6 +875,7 @@ DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error");
DEF_STATIC_SYMBOL(argument_error, "argument-error"); DEF_STATIC_SYMBOL(argument_error, "argument-error");
DEF_STATIC_SYMBOL(invalid_function_error, "invalid-function-error"); DEF_STATIC_SYMBOL(invalid_function_error, "invalid-function-error");
DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error"); DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error");
DEF_STATIC_SYMBOL(return_frame_error, "return-frame-error");
LispVal *predicate_for_type(LispType type) { LispVal *predicate_for_type(LispType type) {
switch (type) { switch (type) {
@ -913,6 +937,7 @@ static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
return true; return true;
case TYPE_FUNCTION: { case TYPE_FUNCTION: {
LispFunction *fn = obj; LispFunction *fn = obj;
*held = refcount_list_push(*held, fn->name);
*held = refcount_list_push(*held, fn->args); *held = refcount_list_push(*held, fn->args);
*held = refcount_list_push(*held, fn->kwargs); *held = refcount_list_push(*held, fn->kwargs);
*held = refcount_list_push(*held, fn->oargs); *held = refcount_list_push(*held, fn->oargs);
@ -962,11 +987,11 @@ static void free_obj_callback(void *obj, void *ignored) {
} }
lisp_free(tbl->data); lisp_free(tbl->data);
} break; } break;
case TYPE_FUNCTION:
case TYPE_SYMBOL: case TYPE_SYMBOL:
case TYPE_PAIR: case TYPE_PAIR:
case TYPE_INTEGER: case TYPE_INTEGER:
case TYPE_FLOAT: case TYPE_FLOAT:
case TYPE_FUNCTION:
// no internal data to free // no internal data to free
break; break;
default: default:
@ -993,9 +1018,13 @@ void lisp_init(void) {
REGISTER_SYMBOL(allow_other_keys); REGISTER_SYMBOL(allow_other_keys);
REGISTER_SYMBOL(key); REGISTER_SYMBOL(key);
REGISTER_SYMBOL(rest); REGISTER_SYMBOL(rest);
REGISTER_SYMBOL(declare);
REGISTER_SYMBOL(name);
REGISTER_SYMBOL(comma); REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at); REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote); REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL(success);
REGISTER_SYMBOL(finally);
REGISTER_SYMBOL(shutdown_signal); REGISTER_SYMBOL(shutdown_signal);
REGISTER_SYMBOL(type_error); REGISTER_SYMBOL(type_error);
REGISTER_SYMBOL(read_error); REGISTER_SYMBOL(read_error);
@ -1007,11 +1036,10 @@ void lisp_init(void) {
REGISTER_SYMBOL(argument_error); REGISTER_SYMBOL(argument_error);
REGISTER_SYMBOL(invalid_function_error); REGISTER_SYMBOL(invalid_function_error);
REGISTER_SYMBOL(no_applicable_method_error); REGISTER_SYMBOL(no_applicable_method_error);
REGISTER_SYMBOL(return_frame_error);
refcount_init_static(Qtoplevel); refcount_init_static(Qtoplevel);
refcount_init_static(&_Qtoplevel_name); refcount_init_static(&_Qtoplevel_symnamestr);
refcount_init_static(Qparent_lexenv);
refcount_init_static(&_Qparent_lexenv_name);
REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing..."); REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing...");
REGISTER_FUNCTION(sethead, "(pair newval)", REGISTER_FUNCTION(sethead, "(pair newval)",
@ -1106,7 +1134,14 @@ void lisp_init(void) {
"Logical or (with short circuit evaluation.)"); "Logical or (with short circuit evaluation.)");
REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ."); REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ.");
REGISTER_FUNCTION(function_docstr, "(func)", REGISTER_FUNCTION(function_docstr, "(func)",
"Return the documentation string of FUNC.") "Return the documentation string of FUNC.");
REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", "");
REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", "");
REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", "");
REGISTER_FUNCTION(return_from, "(name &opt value)",
"Return from the function named NAME and return VALUE.");
REGISTER_FUNCTION(intern, "(name)", "");
REGISTER_FUNCTION(condition_case, "(form &rest handlers)", "");
} }
void lisp_shutdown(void) { void lisp_shutdown(void) {
@ -1118,15 +1153,8 @@ void lisp_shutdown(void) {
refcount_default_context = NULL; refcount_default_context = NULL;
} }
static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) { static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
while (HASHTABLEP(lexenv)) { return Fplist_get(lexenv, key, Qunbound, Qnil);
LispVal *value = gethash(lexenv, key, Qunbound);
if (value != Qunbound) {
return refcount_ref(value);
}
lexenv = gethash(lexenv, Qparent_lexenv, Qunbound);
}
return Qunbound;
} }
static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) { static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
@ -1140,7 +1168,6 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
if (sym_val != Qunbound) { if (sym_val != Qunbound) {
return sym_val; return sym_val;
} }
// TODO free args (not just this call, all calls to Fthrow)
Fthrow(Qvoid_variable_error, const_list(true, 1, key)); Fthrow(Qvoid_variable_error, const_list(true, 1, key));
} }
@ -1190,7 +1217,6 @@ DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) {
static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) { static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *final_args = Qnil; LispVal *final_args = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, { WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
void *cl_handle = register_cleanup( void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &unref_double_ptr, &final_args); (lisp_cleanup_func_t) &unref_double_ptr, &final_args);
LispVal *end; LispVal *end;
@ -1285,7 +1311,11 @@ too_few:
return NULL; return NULL;
} }
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) { static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
LispVal *args_lexenv) {
if (func->is_macro) {
the_stack->lexenv = refcount_ref(args_lexenv);
}
size_t nargs; size_t nargs;
LispVal **arg_vec = process_builtin_args(name, func, args, &nargs); LispVal **arg_vec = process_builtin_args(name, func, args, &nargs);
struct UnrefListData cleanup_data = {.vals = arg_vec, .len = nargs}; struct UnrefListData cleanup_data = {.vals = arg_vec, .len = nargs};
@ -1337,7 +1367,8 @@ static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
} }
static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args, static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
LispVal *lexenv) { LispVal **lexenv) {
LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil);
enum { REQ, OPT, KEY, REST } mode = REQ; enum { REQ, OPT, KEY, REST } mode = REQ;
LispVal *rargs = func->rargs; LispVal *rargs = func->rargs;
LispVal *oargs = func->oargs; LispVal *oargs = func->oargs;
@ -1349,7 +1380,7 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
mode = OPT; mode = OPT;
continue; // skip increment continue; // skip increment
} }
puthash(lexenv, HEAD(rargs), arg); push_to_lexenv(lexenv, HEAD(rargs), arg);
rargs = TAIL(rargs); rargs = TAIL(rargs);
} break; } break;
case OPT: { case OPT: {
@ -1358,9 +1389,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
continue; // skip increment continue; // skip increment
} }
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs)); struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs));
puthash(lexenv, oad->name, arg); push_to_lexenv(lexenv, oad->name, arg);
if (!NILP(oad->pred_var)) { if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qt); push_to_lexenv(lexenv, oad->pred_var, Qt);
} }
oargs = TAIL(oargs); oargs = TAIL(oargs);
} break; } break;
@ -1383,9 +1414,10 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto missing_value; goto missing_value;
} }
LispVal *value = HEAD(args); LispVal *value = HEAD(args);
puthash(lexenv, oad->name, value); puthash(added_kwds, oad->name, Qt);
push_to_lexenv(lexenv, oad->name, value);
if (!NILP(oad->pred_var)) { if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qt); push_to_lexenv(lexenv, oad->pred_var, Qt);
} }
break; break;
case REST: case REST:
@ -1401,9 +1433,9 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
goto too_many_args; goto too_many_args;
} }
} }
puthash(lexenv, func->rest_arg, args); push_to_lexenv(lexenv, func->rest_arg, args);
// done processing // done processing
return; goto done_adding;
} }
args = TAIL(args); args = TAIL(args);
} }
@ -1415,12 +1447,12 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
HASHTABLE_FOREACH(arg, desc_lv, func->kwargs, { HASHTABLE_FOREACH(arg, desc_lv, func->kwargs, {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv); struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
// only check the current function's lexenv and not its parents' // only check the current function's lexenv and not its parents'
if (Fgethash(lexenv, oad->name, Qunbound) == Qunbound) { if (NILP(gethash(added_kwds, oad->name, Qnil))) {
LispVal *eval_res = Feval(oad->default_form); LispVal *eval_res = Feval(oad->default_form);
puthash(lexenv, oad->name, eval_res); push_to_lexenv(lexenv, oad->name, eval_res);
refcount_unref(eval_res); refcount_unref(eval_res);
if (!NILP(oad->pred_var)) { if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qnil); push_to_lexenv(lexenv, oad->pred_var, Qnil);
} }
} }
}); });
@ -1428,28 +1460,31 @@ static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
FOREACH(arg, oargs) { FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg); struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
LispVal *default_val = Feval(oad->default_form); LispVal *default_val = Feval(oad->default_form);
puthash(lexenv, oad->name, default_val); push_to_lexenv(lexenv, oad->name, default_val);
refcount_unref(default_val); refcount_unref(default_val);
if (!NILP(oad->pred_var)) { if (!NILP(oad->pred_var)) {
puthash(lexenv, oad->pred_var, Qnil); push_to_lexenv(lexenv, oad->pred_var, Qnil);
} }
} }
if (!NILP(func->rest_arg)) { if (!NILP(func->rest_arg)) {
puthash(lexenv, func->rest_arg, Qnil); push_to_lexenv(lexenv, func->rest_arg, Qnil);
} }
done_adding:
refcount_unref(added_kwds);
return; return;
// TODO different messages // TODO different messages
missing_required: missing_required:
too_many_args: too_many_args:
missing_value: missing_value:
unknown_key: unknown_key:
refcount_unref(added_kwds);
Fthrow(Qargument_error, Fpair(fname, Qnil)); Fthrow(Qargument_error, Fpair(fname, Qnil));
} }
static LispVal *call_lisp_function(LispVal *name, LispFunction *func, static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
LispVal *args, LispVal *args_lexenv) { LispVal *args, LispVal *args_lexenv) {
puthash(the_stack->lexenv, Qparent_lexenv, func->lexenv); the_stack->lexenv = refcount_ref(func->lexenv);
process_lisp_args(name, func, args, the_stack->lexenv); process_lisp_args(name, func, args, &the_stack->lexenv);
if (func->is_macro) { if (func->is_macro) {
if (!the_stack->next) { if (!the_stack->next) {
abort(); abort();
@ -1492,12 +1527,13 @@ static LispVal *call_function(LispVal *func, LispVal *args,
// builtin macros inherit their parents lexenv // builtin macros inherit their parents lexenv
refcount_ref(args); refcount_ref(args);
WITH_CLEANUP(args, { WITH_CLEANUP(args, {
WITH_PUSH_FRAME(func, args, false, { WITH_PUSH_FRAME(
if (fobj->is_macro && fobj->is_builtin) { SYMBOLP(func) ? func : Qlambda, args,
puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv); false, // make sure the lexenv is nil
} {
the_stack->hidden = false;
if (fobj->is_builtin) { if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args); retval = call_builtin(func, fobj, args, args_lexenv);
} else { } else {
retval = call_lisp_function(func, fobj, args, args_lexenv); retval = call_lisp_function(func, fobj, args, args_lexenv);
} }
@ -1560,7 +1596,6 @@ DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
LispVal *copy = Qnil; LispVal *copy = Qnil;
LispVal *copy_end; LispVal *copy_end;
WITH_PUSH_FRAME(Qnil, Qnil, true, { WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
void *cl_handle = register_cleanup(&unref_double_ptr, &copy); void *cl_handle = register_cleanup(&unref_double_ptr, &copy);
while (!NILP(tortise)) { while (!NILP(tortise)) {
if (!LISTP(LISPVAL(tortise))) { if (!LISTP(LISPVAL(tortise))) {
@ -1609,9 +1644,10 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
LispVal *expansion = Qnil; LispVal *expansion = Qnil;
WITH_CLEANUP_DOUBLE_PTR(fobj, { WITH_CLEANUP_DOUBLE_PTR(fobj, {
WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, { WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, {
puthash(the_stack->lexenv, Qparent_lexenv, fobj->lexenv); the_stack->hidden = false;
the_stack->lexenv = refcount_ref(fobj->lexenv);
process_lisp_args(Fhead(form), fobj, Ftail(form), process_lisp_args(Fhead(form), fobj, Ftail(form),
the_stack->lexenv); &the_stack->lexenv);
expansion = Fprogn(fobj->body); expansion = Fprogn(fobj->body);
}); });
}); });
@ -1637,9 +1673,13 @@ DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) {
} }
} }
DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) { // func should ref its return value
static LispVal *filter_body_tree(LispVal *form,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
if (PAIRP(form)) { if (PAIRP(form)) {
LispVal *toplevel_orig = Fmacroexpand_toplevel(form); LispVal *toplevel_orig = func(form, user_data);
LispVal *toplevel; LispVal *toplevel;
WITH_CLEANUP(toplevel_orig, { WITH_CLEANUP(toplevel_orig, {
toplevel = Fcopy_list(toplevel_orig); // toplevel = Fcopy_list(toplevel_orig); //
@ -1648,7 +1688,8 @@ DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
void *cl_handler = register_cleanup(&unref_double_ptr, &toplevel); void *cl_handler = register_cleanup(&unref_double_ptr, &toplevel);
if (PAIRP(toplevel) && NILP(Feq(Qquote, HEAD(toplevel)))) { if (PAIRP(toplevel) && NILP(Feq(Qquote, HEAD(toplevel)))) {
FOREACH_TAIL(tail, TAIL(toplevel)) { FOREACH_TAIL(tail, TAIL(toplevel)) {
Fsethead(tail, Fmacroexpand_all(HEAD(tail))); Fsethead(tail,
filter_body_tree(HEAD(tail), func, user_data));
} }
} }
cancel_cleanup(cl_handler); cancel_cleanup(cl_handler);
@ -1660,6 +1701,14 @@ DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
return Qnil; return Qnil;
} }
static LispVal *macroexpand_toplevel_as_callback(LispVal *form, void *ignored) {
return Fmacroexpand_toplevel(form);
}
DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
return filter_body_tree(form, macroexpand_toplevel_as_callback, NULL);
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) { DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
LispVal *args = Qnil; LispVal *args = Qnil;
LispVal *end; LispVal *end;
@ -1741,7 +1790,6 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) {
LispVal *res = Feval(cond); LispVal *res = Feval(cond);
LispVal *retval = Qnil; LispVal *retval = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, { WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
if (!NILP(res)) { if (!NILP(res)) {
retval = Feval(t); retval = Feval(t);
} else { } else {
@ -1843,16 +1891,14 @@ DEFUN(sub, "-", (LispVal * args)) {
static void set_symbol_in_lexenv(LispVal *key, LispVal *newval, static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
LispVal *lexenv) { LispVal *lexenv) {
while (HASHTABLEP(lexenv)) { LispVal *lexval = Fplist_assoc(lexenv, key, Qnil);
if (gethash(lexenv, key, Qunbound) != Qunbound) { if (PAIRP(lexval)) {
puthash(lexenv, key, newval); Fsethead(TAIL(lexval), newval);
return; } else {
}
lexenv = gethash(lexenv, Qparent_lexenv, Qnil);
}
refcount_ref(newval); refcount_ref(newval);
refcount_unref(((LispSymbol *) key)->value); refcount_unref(((LispSymbol *) key)->value);
((LispSymbol *) key)->value = newval; ((LispSymbol *) key)->value = newval;
}
} }
DEFMACRO(setq, "setq", (LispVal * args)) { DEFMACRO(setq, "setq", (LispVal * args)) {
@ -1890,28 +1936,127 @@ DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
return refcount_ref(new_func); return refcount_ref(new_func);
} }
// clang-format off
DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) {
bool success = false;
LispVal *success_form = Qunbound;
LispVal *finally_form = Qunbound;
LispVal *retval = Qnil;
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(Qnil, Qnil, true, {
void *cl_handler = register_cleanup(&unref_double_ptr, &success_form);
void *cl_handler2 = register_cleanup(&unref_double_ptr, &finally_form);
FOREACH(entry, rest) {
if (HEAD(entry) == Qsuccess) {
if (success_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
success_form = Fpair(Qprogn, TAIL(entry));
} else if (HEAD(entry) == Qfinally) {
if (finally_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
finally_form = Fpair(Qprogn, TAIL(entry));
} else {
LispVal *var = HEAD(HEAD(entry)); LispVal *types = HEAD(TAIL(HEAD(entry)));
if (!PAIRP(types)) {
types = const_list(true, 1, types);
} else {
types = refcount_ref(types);
}
WITH_CLEANUP(types, {
FOREACH(type, types) {
LispVal *handler = push_many(TAIL(entry), 2,
Qprogn, var);
puthash(the_stack->handlers, type, handler);
refcount_unref(handler);
}
});
}
}
cancel_cleanup(cl_handler2);
if (finally_form != Qunbound) {
the_stack->unwind_form = finally_form;
}
retval = Feval(form);
cancel_cleanup(cl_handler);
success = true;
}, {
retval = refcount_ref(stack_return);
});
// call this out here so it is not covered by the handlers
if (success && success_form != Qunbound) {
void *cl_handler = register_cleanup(&refcount_unref_as_callback, retval);
WITH_CLEANUP(success_form, {
refcount_unref(Feval(success_form));
});
cancel_cleanup(cl_handler);
}
return retval;
}
// clang-format on
// true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
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));
}
}
return true;
}
return false;
}
static LispVal *expand_function_body_callback(LispVal *body, void *data) {
return Fmacroexpand_toplevel(body);
}
static inline LispVal *expand_function_body(LispVal *body) {
return filter_body_tree(body, expand_function_body_callback, NULL);
}
DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) { DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
CHECK_TYPE(TYPE_SYMBOL, name); CHECK_TYPE(TYPE_SYMBOL, name);
LispVal *func = make_lisp_function(args, the_stack->lexenv, body, false); if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *expanded_body = expand_function_body(body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, args, the_stack->lexenv, body, false);
});
refcount_unref(Ffset(name, func)); refcount_unref(Ffset(name, func));
return func; return func;
} }
DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) { DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
CHECK_TYPE(TYPE_SYMBOL, name); CHECK_TYPE(TYPE_SYMBOL, name);
LispVal *func = make_lisp_function(args, the_stack->lexenv, body, true); if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *expanded_body = expand_function_body(body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, args, the_stack->lexenv, body, true);
});
refcount_unref(Ffset(name, func)); refcount_unref(Ffset(name, func));
return func; return func;
} }
DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) { DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
LispVal *name = Qlambda;
if (parse_function_declare(HEAD(body), &name)) {
body = TAIL(body);
}
LispVal *expanded_body = Fmacroexpand_all(body); LispVal *expanded_body = Fmacroexpand_all(body);
LispVal *retval = Qnil; LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, { WITH_CLEANUP(expanded_body, {
retval = func = make_lisp_function(name, args, the_stack->lexenv, expanded_body,
make_lisp_function(args, the_stack->lexenv, expanded_body, false); false);
}); });
return retval; return func;
} }
DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) { DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) {
@ -2110,6 +2255,72 @@ DEFUN(function_docstr, "function-docstr", (LispVal * func)) {
return retval; return retval;
} }
static bool call_eq_pred(LispVal *pred, LispVal *v1, LispVal *v2) {
if (NILP(pred)) {
return !NILP(Feq(v1, v2));
} else {
LispVal *fcall_args = const_list(true, 2, v1, v2);
bool res = false;
WITH_CLEANUP(fcall_args, {
LispVal *lvpr = Ffuncall(pred, fcall_args); //
res = !NILP(lvpr);
refcount_unref(lvpr);
});
return res;
}
}
DEFUN(plist_get, "plist-get",
(LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(TAIL(cur))) {
return refcount_ref(def);
}
return refcount_ref(HEAD(TAIL(cur)));
}
}
return refcount_ref(def);
}
DEFUN(plist_set, "plist-set",
(LispVal * plist, LispVal *key, LispVal *value, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(TAIL(cur))) {
break;
}
return refcount_ref(HEAD(TAIL(cur)));
}
}
return push_many(plist, 2, value, key);
}
DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred)) {
for (LispVal *prev = Qnil, *cur = plist; !NILP(cur);
prev = cur, cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(prev)) {
return refcount_ref(TAIL(TAIL(plist)));
} else {
Fsettail(TAIL(prev), TAIL(TAIL(cur)));
}
return Qnil;
}
}
return refcount_ref(plist);
}
DEFUN(plist_assoc, "plist-assoc",
(LispVal * plist, LispVal *key, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
return cur;
}
}
return Qnil;
}
static void debug_dump_real(FILE *stream, void *obj, bool first) { static void debug_dump_real(FILE *stream, void *obj, bool first) {
switch (TYPEOF(obj)) { switch (TYPEOF(obj)) {
case TYPE_STRING: { case TYPE_STRING: {
@ -2158,13 +2369,23 @@ static void debug_dump_real(FILE *stream, void *obj, bool first) {
} }
fputc(']', stream); fputc(']', stream);
} break; } break;
case TYPE_FUNCTION: case TYPE_FUNCTION: {
LispVal *name = ((LispFunction *) obj)->name;
if (((LispFunction *) obj)->is_builtin) { if (((LispFunction *) obj)->is_builtin) {
fprintf(stream, "<builtin at %#jx>", (uintmax_t) obj); fprintf(stream, "<builtin ");
} else { } else {
fprintf(stream, "<function at %#jx>", (uintmax_t) obj); if (name == Qlambda) {
fprintf(stream, "<lambda"); // no space!
name = NULL;
} else {
fprintf(stream, "<function ");
} }
break; }
if (name) {
debug_dump_real(stream, name, false);
}
fprintf(stream, " at %#jx>", (uintmax_t) obj);
} break;
case TYPE_HASHTABLE: { case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) obj; LispHashtable *tbl = (LispHashtable *) obj;
fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>", fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>",
@ -2214,33 +2435,3 @@ static bool debug_print_tree_callback(void *obj, const RefcountList *trail,
void debug_print_tree(FILE *stream, void *obj) { void debug_print_tree(FILE *stream, void *obj) {
refcount_debug_walk_tree(obj, debug_print_tree_callback, stream); refcount_debug_walk_tree(obj, debug_print_tree_callback, stream);
} }
void debug_dump_lexenv(FILE *stream, LispVal *lexenv) {
if (!the_stack) {
fprintf(stream, "debug_dump_lexenv: No stack frames...\n");
}
if (!lexenv) {
lexenv = the_stack->lexenv;
}
bool first = true;
while (!NILP(lexenv)) {
if (first) {
fprintf(stream, "Lexical variables (most recent frame first):\n");
} else {
fprintf(stream, "\nNext parent:\n");
}
first = false;
LispVal *next_lexenv = Qnil;
HASHTABLE_FOREACH(var, val, lexenv, {
if (var == Qparent_lexenv) {
next_lexenv = val;
} else {
fprintf(stream, " - ");
debug_dump(stream, var, false);
fprintf(stream, " -> ");
debug_dump(stream, val, true);
}
});
lexenv = next_lexenv;
}
}

75
src/lisp.h
View File

@ -107,6 +107,7 @@ typedef void (*lisp_function_ptr_t)(void);
typedef struct { typedef struct {
LISP_OBJECT_HEADER; LISP_OBJECT_HEADER;
LispVal *name;
LispVal *doc; LispVal *doc;
LispVal *args; LispVal *args;
bool is_builtin; bool is_builtin;
@ -218,10 +219,10 @@ inline static bool NUMBERP(LispVal *v) {
.is_static = true, \ .is_static = true, \
} }
#define DEF_STATIC_SYMBOL(c_name, lisp_name) \ #define DEF_STATIC_SYMBOL(c_name, lisp_name) \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \ DEF_STATIC_STRING(_Q##c_name##_symnamestr, lisp_name); \
static LispSymbol _Q##c_name = { \ static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \ .type = TYPE_SYMBOL, \
.name = &_Q##c_name##_name, \ .name = &_Q##c_name##_symnamestr, \
.plist = Qnil, \ .plist = Qnil, \
.function = Qunbound, \ .function = Qunbound, \
.value = Qunbound, \ .value = Qunbound, \
@ -234,12 +235,14 @@ inline static bool NUMBERP(LispVal *v) {
// The args and doc fields are filled when the function is registered // The args and doc fields are filled when the function is registered
#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args, static_kw) \ #define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args, static_kw) \
static_kw LispVal *F##c_name c_args; \ static_kw LispVal *F##c_name c_args; \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \ DEF_STATIC_STRING(_Q##c_name##_fnnamestr, lisp_name); \
static LispSymbol _Q##c_name; \
static LispFunction _Q##c_name##_function = { \ static LispFunction _Q##c_name##_function = { \
.type = TYPE_FUNCTION, \ .type = TYPE_FUNCTION, \
.is_builtin = true, \ .is_builtin = true, \
.is_macro = macrop, \ .is_macro = macrop, \
.builtin = (void (*)(void)) & F##c_name, \ .builtin = (void (*)(void)) & F##c_name, \
.name = LISPVAL(&_Q##c_name), \
.doc = Qnil, \ .doc = Qnil, \
.args = Qnil, \ .args = Qnil, \
.rargs = Qnil, \ .rargs = Qnil, \
@ -250,7 +253,7 @@ inline static bool NUMBERP(LispVal *v) {
}; \ }; \
static LispSymbol _Q##c_name = { \ static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \ .type = TYPE_SYMBOL, \
.name = &_Q##c_name##_name, \ .name = &_Q##c_name##_fnnamestr, \
.plist = Qnil, \ .plist = Qnil, \
.value = Qunbound, \ .value = Qunbound, \
.function = LISPVAL(&_Q##c_name##_function), \ .function = LISPVAL(&_Q##c_name##_function), \
@ -315,8 +318,8 @@ LispVal *make_lisp_integer(intmax_t value);
LispVal *make_lisp_float(long double value); LispVal *make_lisp_float(long double value);
LispVal *make_lisp_vector(LispVal **data, size_t length); LispVal *make_lisp_vector(LispVal **data, size_t length);
void set_function_args(LispFunction *func, LispVal *args); void set_function_args(LispFunction *func, LispVal *args);
LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body, LispVal *make_lisp_function(LispVal *name, LispVal *args, LispVal *lexenv,
bool is_macro); LispVal *body, bool is_macro);
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn); LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
LispVal *make_user_pointer(void *data, void (*free_func)(void *)); LispVal *make_user_pointer(void *data, void (*free_func)(void *));
#define ALLOC_USERPTR(type, free_func) \ #define ALLOC_USERPTR(type, free_func) \
@ -388,6 +391,28 @@ static inline LispVal *make_list(size_t len, LispVal **vals) {
} }
return list; return list;
} }
static inline LispVal *push_many(LispVal *list, int count, ...) {
LispVal *new_list = list;
bool first = true;
va_list args;
va_start(args, count);
while (count--) {
new_list = Fpair(va_arg(args, LispVal *), new_list);
if (!first) {
refcount_unref(((LispPair *) new_list)->tail);
first = false;
}
}
va_end(args);
return new_list;
}
static inline void push_to_lexenv(LispVal **lexenv, LispVal *key,
LispVal *value) {
LispVal *old = *lexenv;
*lexenv = push_many(*lexenv, 2, value, key);
refcount_unref(old);
}
typedef void (*lisp_cleanup_func_t)(void *); typedef void (*lisp_cleanup_func_t)(void *);
struct CleanupHandlerEntry { struct CleanupHandlerEntry {
struct CleanupHandlerEntry *next; struct CleanupHandlerEntry *next;
@ -402,15 +427,18 @@ typedef struct StackFrame {
LispVal *lexenv; // symbol -> value LispVal *lexenv; // symbol -> value
bool enable_handlers; bool enable_handlers;
LispVal *handlers; // symbol -> (error-var form) LispVal *handlers; // symbol -> (error-var form)
LispVal *unwind_forms; LispVal *unwind_form;
struct CleanupHandlerEntry *cleanup_handlers; struct CleanupHandlerEntry *cleanup_handlers;
jmp_buf start; jmp_buf start;
} StackFrame; } StackFrame;
#define STACK_EXIT_NORMAL 0
#define STACK_EXIT_THROW 1
extern StackFrame *the_stack; extern StackFrame *the_stack;
extern LispVal *stack_return;
extern LispVal *Qtoplevel; extern LispVal *Qtoplevel;
extern LispVal *Qparent_lexenv;
void stack_enter(LispVal *name, LispVal *detail, bool inherit); void stack_enter(LispVal *name, LispVal *detail, bool inherit);
void stack_leave(void); void stack_leave(void);
@ -423,15 +451,26 @@ struct UnrefListData {
void unref_free_list_double_ptr(void *ptr); void unref_free_list_double_ptr(void *ptr);
void unref_double_ptr(void *ptr); void unref_double_ptr(void *ptr);
void cancel_cleanup(void *handle); void cancel_cleanup(void *handle);
#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \ #define WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(name, detail, inherit, body, \
on_return) \
stack_enter(name, detail, inherit); \ stack_enter(name, detail, inherit); \
if (setjmp(the_stack->start) == 0) { \ { \
int __with_push_frame_jmpval = setjmp(the_stack->start); \
if (__with_push_frame_jmpval == STACK_EXIT_NORMAL) { \
body \ body \
} else if (__with_push_frame_jmpval == STACK_EXIT_THROW) { \
on_return; \
refcount_unref(stack_return); \
stack_return = NULL; \
} \ } \
stack_leave(); 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) \ #define WITH_PUSH_FRAME(name, detail, inherit, body) \
WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \ WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \
body) body)
#define WITH_CLEANUP_DOUBLE_PTR(var, body) \ #define WITH_CLEANUP_DOUBLE_PTR(var, body) \
{ \ { \
void *__with_cleanup_cleanup = register_cleanup( \ void *__with_cleanup_cleanup = register_cleanup( \
@ -450,8 +489,11 @@ void cancel_cleanup(void *handle);
} }
DECLARE_FUNCTION(backtrace, (void) ); DECLARE_FUNCTION(backtrace, (void) );
noreturn DECLARE_FUNCTION(return_from, (LispVal * name, LispVal *value));
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest)); noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
extern LispVal *Qsuccess;
extern LispVal *Qfinally;
extern LispVal *Qshutdown_signal; extern LispVal *Qshutdown_signal;
extern LispVal *Qtype_error; extern LispVal *Qtype_error;
extern LispVal *Qread_error; extern LispVal *Qread_error;
@ -463,6 +505,7 @@ extern LispVal *Qmalformed_lambda_list_error;
extern LispVal *Qargument_error; extern LispVal *Qargument_error;
extern LispVal *Qinvalid_function_error; extern LispVal *Qinvalid_function_error;
extern LispVal *Qno_applicable_method_error; extern LispVal *Qno_applicable_method_error;
extern LispVal *Qreturn_frame_error;
LispVal *predicate_for_type(LispType type); LispVal *predicate_for_type(LispType type);
#define CHECK_TYPE(type, val) \ #define CHECK_TYPE(type, val) \
@ -528,6 +571,7 @@ DECLARE_FUNCTION(sub, (LispVal * args));
DECLARE_FUNCTION(setq, (LispVal * args)); DECLARE_FUNCTION(setq, (LispVal * args));
DECLARE_FUNCTION(progn, (LispVal * forms)); DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func)); DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
DECLARE_FUNCTION(condition_case, (LispVal * form, LispVal *rest));
DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body)); DECLARE_FUNCTION(defun, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body)); DECLARE_FUNCTION(defmacro, (LispVal * name, LispVal *args, LispVal *body));
DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
@ -561,6 +605,12 @@ DECLARE_FUNCTION(and, (LispVal * rest));
DECLARE_FUNCTION(or, (LispVal * rest)); DECLARE_FUNCTION(or, (LispVal * rest));
DECLARE_FUNCTION(type_of, (LispVal * val)); DECLARE_FUNCTION(type_of, (LispVal * val));
DECLARE_FUNCTION(function_docstr, (LispVal * func)); DECLARE_FUNCTION(function_docstr, (LispVal * func));
DECLARE_FUNCTION(plist_get,
(LispVal * plist, LispVal *key, LispVal *def, LispVal *pred));
DECLARE_FUNCTION(plist_set, (LispVal * plist, LispVal *key, LispVal *value,
LispVal *pred));
DECLARE_FUNCTION(plist_rem, (LispVal * plist, LispVal *key, LispVal *pred));
DECLARE_FUNCTION(plist_assoc, (LispVal * plist, LispVal *key, LispVal *pred));
void debug_dump(FILE *stream, void *obj, bool newline); void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table); void debug_print_hashtable(FILE *stream, LispVal *table);
@ -570,7 +620,8 @@ extern LispVal *Qopt;
extern LispVal *Qkey; extern LispVal *Qkey;
extern LispVal *Qallow_other_keys; extern LispVal *Qallow_other_keys;
extern LispVal *Qrest; extern LispVal *Qrest;
extern LispVal *Qreturn_signal; extern LispVal *Qdeclare;
extern LispVal *Qname;
// some internal functions // some internal functions
LispVal *puthash(LispVal *table, LispVal *key, LispVal *value); LispVal *puthash(LispVal *table, LispVal *key, LispVal *value);

1
src/main.c
View File

@ -88,7 +88,6 @@ int main(int argc, const char **argv) {
REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", ""); REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", "");
size_t pos = 0; size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, { WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
the_stack->hidden = true;
LispVal *err_var = INTERN_STATIC("err-var"); LispVal *err_var = INTERN_STATIC("err-var");
puthash(the_stack->handlers, Qt, puthash(the_stack->handlers, Qt,
// simply call the above function // simply call the above function