Zander671/glisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Work on functions

Browse Source
This commit is contained in:
Alexander Rosenberg
2026-01-29 00:00:05 -08:00
parent 22ffac9321
commit 5029405a70
12 changed files with 292 additions and 123 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/base.c
View File

@ -51,7 +51,7 @@ void internal_CHECK_TYPE_signal_type_error(LispVal *obj, size_t count,
fprintf(stderr, "Type error! Got: %s | Expected: (or ",
LISP_TYPE_NAMES[TYPE_OF(obj)]);
for (size_t i = 0; i < count; ++i) {
fprintf(stderr, "%s%s", LISP_TYPE_NAMES[i],
fprintf(stderr, "%s%s", LISP_TYPE_NAMES[types[i]],
i < count - 1 ? " " : ")\n");
}
abort();

276
src/function.c
View File

@ -46,15 +46,19 @@ static LispVal *intern_as_keyword(LispVal *name) {
}
// on error, put the object that caused the problem in entry
static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
LispVal *entry) {
static LambdaListParseStatus
parse_optional_arg_spec(LispVal *used_names, LispVal **out, LispVal *entry) {
// single symbol
if (SYMBOLP(entry)) {
if (!is_valid_variable_name(entry)) {
*out = entry;
return LLPS_BAD_NAME;
} else if (!NILP(Fgethash(used_names, entry, Qnil))) {
*out = entry;
return LLPS_REPEAT_NAME;
}
*out = LIST(entry, Qnil, Qnil);
Fputhash(used_names, entry, Qt);
return LLPS_OK;
} else if (!CONSP(entry)) {
*out = entry;
@ -65,7 +69,11 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
if (!is_valid_variable_name(name)) {
*out = name;
return LLPS_BAD_NAME;
} else if (!NILP(Fgethash(used_names, name, Qnil))) {
*out = name;
return LLPS_REPEAT_NAME;
}
Fputhash(used_names, name, Qt);
if (list_length_eq(entry, 1)) {
*out = LIST(XCAR(entry), Qnil, Qnil);
return LLPS_OK;
@ -75,8 +83,13 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
} else if (list_length_eq(entry, 3)) {
LispVal *pvar = XCAR(XCDR(XCDR(entry)));
if (!is_valid_variable_name(pvar)) {
*out = pvar;
return LLPS_BAD_NAME;
} else if (!NILP(Fgethash(used_names, pvar, Qnil))) {
*out = pvar;
return LLPS_REPEAT_NAME;
}
Fputhash(used_names, pvar, Qt);
*out = LIST(XCAR(entry), XCAR(XCDR(entry)), pvar);
return LLPS_OK;
} else {
@ -85,11 +98,12 @@ static LambdaListParseStatus parse_optional_arg_spec(LispVal **out,
}
}
#define RETURN_ERROR(err, obj) \
{ \
result->status = err; \
result->err_obj = (obj); \
return; \
#define RETURN_ERROR(err, obj) \
{ \
release_hash_table_no_gc(used_names); \
result->status = err; \
result->err_obj = (obj); \
return; \
}
void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
enum { REQ = 0, OPT = 1, KEY = 2, REST = 4, MUST_CHANGE } mode = REQ;
@ -97,6 +111,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
result->err_obj = Qnil;
result->status = LLPS_OK;
struct LambdaList *out = &result->lambda_list;
LispVal *used_names = make_hash_table_no_gc(Qnil, Qnil);
// TODO check for repeat names
out->n_req = 0;
out->n_opt = 0;
@ -148,12 +163,16 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
RETURN_ERROR(LLPS_REPEAT_REST, cur);
} else if (!is_valid_variable_name(cur)) {
RETURN_ERROR(LLPS_BAD_NAME, cur)
} else if (!NILP(Fgethash(used_names, cur, Qnil))) {
RETURN_ERROR(LLPS_REPEAT_NAME, cur);
}
Fputhash(used_names, cur, Qt);
out->rest = cur;
++cur_idx;
} else if (mode == OPT || mode == KEY) {
LispVal *entry;
LambdaListParseStatus status = parse_optional_arg_spec(&entry, cur);
LambdaListParseStatus status =
parse_optional_arg_spec(used_names, &entry, cur);
if (status != LLPS_OK) {
RETURN_ERROR(status, entry)
}
@ -167,7 +186,10 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
++cur_idx;
} else if (!is_valid_variable_name(cur)) {
RETURN_ERROR(LLPS_BAD_NAME, cur);
} else if (!NILP(Fgethash(used_names, cur, Qnil))) {
RETURN_ERROR(LLPS_REPEAT_NAME, cur);
} else {
Fputhash(used_names, cur, Qt);
out->req = CONS(cur, out->req);
++out->n_req;
++cur_idx;
@ -175,6 +197,7 @@ void parse_lambda_list(LambdaListParseResult *result, LispVal *list) {
}
out->req = Fnreverse(out->req);
out->opt = Fnreverse(out->opt);
release_hash_table_no_gc(used_names);
}
#undef RETURN_ERROR
@ -212,61 +235,19 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void),
}
// Calling functions
// A simple function has only required args
static ALWAYS_INLINE bool SIMPLE_FUNCTION_P(LispFunction *fobj) {
return !fobj->args.n_opt
&& (NILP(fobj->args.kw) || !HASH_TABLE_COUNT(fobj->args.kw))
&& NILP(fobj->args.rest);
}
static ALWAYS_INLINE LispVal *
call_simple_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
assert(fobj->args.n_req <= MAX_NATIVE_FUNCTION_ARGS);
push_stack_frame(orig_func, fobj, args);
if (!list_length_eq(args, fobj->args.n_req)) {
// TODO incorrect arg count
fprintf(stderr, "Wrong arg count!!\n");
abort();
}
LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS];
size_t acount = 0;
static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) {
LispVal *start = Qnil;
LispVal *end;
DOLIST(arg, args) {
if (fobj->flags.no_eval_args) {
arg_arr[acount] = arg;
if (NILP(start)) {
start = CONS(Feval(arg, PARENT_LEXENV()), Qnil);
end = start;
} else {
arg_arr[acount] = Feval(arg, PARENT_LEXENV());
RPLACD(end, CONS(Feval(arg, PARENT_LEXENV()), Qnil));
end = XCDR(end);
}
add_local_reference(arg_arr[acount++]);
}
LispVal *retval;
switch (acount) {
case 0:
retval = fobj->impl.native.zero();
break;
case 1:
retval = fobj->impl.native.one(arg_arr[0]);
break;
case 2:
retval = fobj->impl.native.two(arg_arr[0], arg_arr[1]);
break;
case 3:
retval = fobj->impl.native.three(arg_arr[0], arg_arr[1], arg_arr[2]);
break;
case 4:
retval = fobj->impl.native.four(arg_arr[0], arg_arr[1], arg_arr[2],
arg_arr[3]);
break;
case 5:
retval = fobj->impl.native.five(arg_arr[0], arg_arr[1], arg_arr[2],
arg_arr[3], arg_arr[4]);
break;
default:
abort();
}
the_stack.nogc_retval = retval;
pop_stack_frame();
add_local_reference(the_stack.nogc_retval);
return retval;
return start;
}
enum ProcessArgsResult {
@ -298,7 +279,8 @@ static ALWAYS_INLINE size_t NATIVE_FUNCTION_TOTAL_ARG_COUNT(LispVal *val) {
static ALWAYS_INLINE enum ProcessArgsResult
process_complex_native_args(LispFunction *fobj, LispVal *args,
LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS]) {
LispVal *restrict out[MAX_NATIVE_FUNCTION_ARGS],
intptr_t *rest_idx) {
size_t rem_req = fobj->args.n_req;
size_t rem_opt = fobj->args.n_opt;
size_t idx = 0;
@ -320,7 +302,10 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
return PROCESS_ARGS_TOO_MANY;
}
if (!NILP(fobj->args.rest)) {
*rest_idx = idx;
out[idx++] = args;
} else {
*rest_idx = -1;
}
if (NILP(fobj->args.kw)) { // we are not a keyword function
return PROCESS_ARGS_OK;
@ -343,12 +328,18 @@ process_complex_native_args(LispFunction *fobj, LispVal *args,
return PROCESS_ARGS_OK;
}
static ALWAYS_INLINE LispVal *
call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
LispFunction *fobj, LispVal *args) {
push_stack_frame(orig_func, fobj, args);
if (!fobj->flags.no_eval_args) {
args = evaluate_function_arguments(args);
}
set_stack_evaluated_args(args);
LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL};
size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj);
intptr_t rest_idx;
enum ProcessArgsResult res =
process_complex_native_args(fobj, args, arg_arr);
process_complex_native_args(fobj, args, arg_arr, &rest_idx);
if (res != PROCESS_ARGS_OK) {
// TODO better errors
printf("Bad arguments to builtin \"");
@ -356,12 +347,9 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
printf("\": %s\n", process_args_strerror(res));
abort();
}
push_stack_frame(orig_func, fobj, args);
for (intptr_t i = 0; i < count; ++i) {
if (!arg_arr[i]) {
arg_arr[i] = Qnil;
} else if (!fobj->flags.no_eval_args) {
arg_arr[i] = Feval(arg_arr[i], PARENT_LEXENV());
}
add_local_reference(arg_arr[i]);
}
@ -396,35 +384,163 @@ call_complex_native(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
return retval;
}
static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func,
LispFunction *fobj, LispVal *args) {
if (SIMPLE_FUNCTION_P(fobj)) {
return call_simple_native(orig_func, fobj, args);
static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec,
LispVal *value) {
new_lexical_variable(XCAR(spec), value);
if (!NILP(THIRD(spec))) {
new_lexical_variable(THIRD(spec), Qt);
}
return call_complex_native(orig_func, fobj, args);
}
static ALWAYS_INLINE void
push_missing_optional_argument_to_lexenv(LispVal *spec) {
new_lexical_variable(XCAR(spec), Feval(SECOND(spec), TOP_LEXENV()));
if (!NILP(THIRD(spec))) {
new_lexical_variable(THIRD(spec), Qnil);
}
}
static ALWAYS_INLINE enum ProcessArgsResult
push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) {
LISP_STACK_TOP()->lexenv = fobj->impl.interp.lexenv;
LispVal *rem_req = fobj->args.req;
LispVal *rem_opt = fobj->args.opt;
while (!NILP(rem_req)) {
if (NILP(args)) {
return PROCESS_ARGS_TOO_FEW;
}
new_lexical_variable(XCAR(rem_req), XCAR(args));
args = XCDR(args);
rem_req = XCDR(rem_req);
}
while (!NILP(rem_opt) && !NILP(args)) {
push_optional_argument_to_lexenv(XCAR(rem_opt), XCAR(args));
args = XCDR(args);
rem_opt = XCDR(rem_opt);
}
while (!NILP(rem_opt)) {
push_missing_optional_argument_to_lexenv(XCAR(rem_opt));
rem_opt = XCDR(rem_opt);
}
if (!NILP(fobj->args.rest)) {
new_lexical_variable(fobj->args.rest, args);
}
if (NILP(fobj->args.kw)) {
return !NILP(args) && NILP(fobj->args.rest) ? PROCESS_ARGS_TOO_MANY
: PROCESS_ARGS_OK;
}
LispVal *seen_kw = make_hash_table_no_gc(Qnil, Qnil);
while (!NILP(args)) {
if (NILP(XCDR(args))) {
return PROCESS_ARGS_NO_KEY_VALUE;
}
// has index in front
LispVal *i_spec = Fgethash(fobj->args.kw, XCAR(args), Qnil);
if (!NILP(i_spec)) {
Fputhash(seen_kw, XCAR(args), Qt);
push_optional_argument_to_lexenv(XCDR(i_spec), SECOND(args));
} else if (!fobj->args.allow_other_keys) {
return PROCESS_ARGS_BAD_KEY;
}
args = XCDR(XCDR(args));
}
HT_FOREACH_INDEX(fobj->args.kw, i) {
if (NILP(Fgethash(seen_kw, HASH_KEY(fobj->args.kw, i), Qnil))) {
push_missing_optional_argument_to_lexenv(
XCDR(HASH_VALUE(fobj->args.kw, i)));
}
}
return PROCESS_ARGS_OK;
}
static ALWAYS_INLINE LispVal *
call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) {
push_stack_frame(orig_func, fobj, args);
LispVal *evaled_args = evaluate_function_arguments(args);
set_stack_evaluated_args(evaled_args);
enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, args);
if (par != PROCESS_ARGS_OK) {
// TODO better error handling
fprintf(stderr, "Bad args to interp func: %s\n",
process_args_strerror(par));
abort();
}
LispVal *rval = Fprogn(fobj->impl.interp.body);
the_stack.nogc_retval = rval;
pop_stack_frame();
add_local_reference(rval);
return rval;
}
DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)",
"") {
CHECK_TYPE(func, TYPE_FUNCTION, TYPE_SYMBOL);
LispFunction *fobj = func;
if (SYMBOLP(func)) {
fobj = Fsymbol_function(func, Qt);
}
if (!FUNCTIONP(fobj)) {
// TODO error
abort();
}
if (!fobj->flags.no_eval_args) {
// TODO evaluate arguments
}
// include symbol here for the error message
CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL);
switch (fobj->flags.type) {
case FUNCTION_NATIVE:
return call_native(func, fobj, args);
case FUNCTION_INTERP:
case FUNCTION_BYTECOMP:
return call_interpreted(func, fobj, args);
default:
// TODO implement
abort();
}
}
static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) {
while (CONSP(body) && CONSP(XCAR(body)) && EQ(XCAR(XCAR(body)), Qdeclare)) {
LispVal *decls = XCDR(XCAR(body));
DOLIST(decl, decls) {
if (EQ(XCAR(decl), Qname)) {
CHECK_TYPE(SECOND(decl), TYPE_SYMBOL);
if (!list_length_eq(decl, 2)) {
// TODO better error
fprintf(stderr, "Invalid (declare (name ...)) form!\n");
abort();
}
fobj->name = SECOND(decl);
}
}
body = XCDR(body);
}
return body;
}
DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body),
"(args &rest body)", "") {
LambdaListParseResult llpr;
parse_lambda_list(&llpr, args);
if (llpr.status != LLPS_OK) {
// TODO better handling
fprintf(stderr,
"Lambda list parse error: %s: ", llps_strerror(llpr.status));
debug_print(stderr, args);
fputc('\n', stderr);
abort();
}
CHECK_LISTP(body);
LispFunction *fobj = lisp_alloc_object(sizeof(LispFunction), TYPE_FUNCTION);
fobj->name = Qnil;
fobj->args = llpr.lambda_list;
fobj->flags.type = FUNCTION_INTERP;
fobj->flags.no_eval_args = false;
if (STRINGP(XCAR(body))) {
fobj->docstr = XCAR(body);
if (CONSP(XCDR(body))) {
body = XCDR(body);
}
} else {
fobj->docstr = Qnil;
}
body = parse_lambda_declare_form(fobj, body);
fobj->impl.interp.body = body;
fobj->impl.interp.lexenv = PARENT_LEXENV();
return fobj;
}
DEFINE_SYMBOL(declare, "declare");
DEFINE_SYMBOL(name, "name");

12
src/function.h
View File

@ -30,10 +30,14 @@ union native_function {
LispVal *(*five)(LispVal *, LispVal *, LispVal *, LispVal *, LispVal *);
};
struct interp_function {
LispVal *body; // list of forms
LispVal *lexenv;
};
typedef enum {
FUNCTION_NATIVE,
FUNCTION_INTERP,
FUNCTION_BYTECOMP,
} LispFunctionType;
struct function_flags {
@ -48,6 +52,7 @@ DEFOBJTYPE(Function, FUNCTION, FUNCTIONP, {
LispVal *docstr;
union {
union native_function native;
struct interp_function interp;
} impl;
});
@ -89,4 +94,9 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(void),
DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args));
#define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__)))
DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body));
DECLARE_SYMBOL(declare);
DECLARE_SYMBOL(name);
#endif

3
src/gc.c
View File

@ -165,7 +165,8 @@ static inline void make_grey_if_while(LispVal *val) {
}
static void mark_object(LispVal *val) {
if (!OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
// check for null for newly constructed objects
if (!val || !OBJECTP(val) || OBJECT_GC_SET_P(val, GC_BLACK)) {
return;
}
switch (((LispObject *) val)->type) {

4
src/gen-init-globals.awk
View File

@ -6,6 +6,10 @@ BEGIN {
special_syms["unbound"] = 1
special_syms["hash_string"] = 1
special_syms["strings_equal"] = 1
special_syms["and_rest"] = 1
special_syms["and_key"] = 1
special_syms["and_optional"] = 1
special_syms["and_allow_other_keys"] = 1
FS = "[,(]"

71
src/lisp.c
View File

@ -10,6 +10,7 @@ static void construct_manual_symbols(void) {
// IMPORTANT: the symbols listed here need to also be set as special in
// gen-init-globals.awk
Qnil = Fmake_symbol(LISP_LITSTR("nil"));
((LispSymbol *) Qnil)->value = Qnil;
((LispSymbol *) Qnil)->function = Qnil;
((LispSymbol *) Qnil)->plist = Qnil;
lisp_gc_register_static_object(Qnil);
@ -18,7 +19,7 @@ static void construct_manual_symbols(void) {
lisp_gc_register_static_object(Qt);
Qunbound = Fmake_symbol(LISP_LITSTR("unbound"));
((LispSymbol *) Qunbound)->value = Qunbound;
((LispSymbol *) Qnil)->value = Qunbound;
((LispSymbol *) Qunbound)->value = Qunbound;
lisp_gc_register_static_object(Qunbound);
Qhash_string = Fmake_symbol(LISP_LITSTR("hash-string"));
@ -41,6 +42,13 @@ static void register_manual_symbols(void) {
void lisp_init(void) {
construct_manual_symbols();
obarray = Fmake_hash_table(Qhash_string, Qstrings_equal);
// Needed to register functions
REGISTER_GLOBAL_SYMBOL(and_allow_other_keys);
REGISTER_GLOBAL_SYMBOL(and_optional);
REGISTER_GLOBAL_SYMBOL(and_key);
REGISTER_GLOBAL_SYMBOL(and_rest);
// these call Fintern, so they need to have obarray constructed
((LispSymbol *) Qhash_string)->function = BUILTIN_FUNCTION_OBJ(hash_string);
((LispSymbol *) Qstrings_equal)->function =
@ -107,6 +115,32 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv),
}
}
DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
LispVal *rval = Qnil;
DOLIST(form, forms) {
rval = Feval(form, TOP_LEXENV());
}
return rval;
}
DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
"(bindings &rest body)", "") {
CHECK_LISTP(bindings);
copy_parent_lexenv();
DOLIST(binding, bindings) {
if (SYMBOLP(binding)) {
new_lexical_variable(binding, Qnil);
} else if (CONSP(binding) && list_length_eq(binding, 2)) {
new_lexical_variable(FIRST(binding),
Feval(SECOND(binding), TOP_LEXENV()));
} else {
// TODO better error
abort();
}
}
return Fprogn(body);
}
void debug_print(FILE *file, LispVal *obj) {
switch (TYPE_OF(obj)) {
case TYPE_FIXNUM:
@ -133,7 +167,14 @@ void debug_print(FILE *file, LispVal *obj) {
break;
}
case TYPE_FUNCTION: {
fprintf(file, "<function at 0x%jx>", (uintmax_t) obj);
LispFunction *fobj = obj;
if (NILP(fobj->name)) {
fprintf(file, "<lambda at 0x%jx>", (uintmax_t) obj);
} else {
fprintf(file, "<function ");
debug_print(file, fobj->name);
fprintf(file, " at 0x%jx>", (uintmax_t) obj);
}
break;
}
case TYPE_CONS: {
@ -169,32 +210,6 @@ void debug_print(FILE *file, LispVal *obj) {
}
}
DEFSPECIAL(progn, "progn", (LispVal * forms), "(&rest forms)", "") {
LispVal *rval = Qnil;
DOLIST(form, forms) {
rval = Feval(form, TOP_LEXENV());
}
return rval;
}
DEFSPECIAL(let, "let", (LispVal * bindings, LispVal *body),
"(bindings &rest body)", "") {
CHECK_LISTP(bindings);
copy_parent_lexenv();
DOLIST(binding, bindings) {
if (SYMBOLP(binding)) {
new_lexical_variable(binding, Qnil);
} else if (CONSP(binding) && list_length_eq(binding, 2)) {
new_lexical_variable(FIRST(binding),
Feval(SECOND(binding), TOP_LEXENV()));
} else {
// TODO better error
abort();
}
}
return Fprogn(body);
}
void debug_obj_info(FILE *file, LispVal *obj) {
fprintf(file, "%s -> ", LISP_TYPE_NAMES[TYPE_OF(obj)]);
debug_print(file, obj);

13
src/main.c
View File

@ -1,22 +1,31 @@
#include "lisp.h"
#include "read.h"
#include <stdio.h>
DEFUN(print, "print", (LispVal * v), "(v)", "") {
debug_obj_info(stdout, v);
return Qnil;
}
int main(int argc, const char **argv) {
FILE *in = fopen(argv[1], "r");
fseek(in, 0, SEEK_END);
off_t src_len = ftello(in);
char *src = malloc(src_len);
rewind(in);
fread(src, 1, src_len, in);
fclose(in);
lisp_init();
REGISTER_GLOBAL_FUNCTION(print);
push_stack_frame(Qnil, Qnil, Qnil);
ReadStream s;
const char BUF[] = "(let ((a 1)) (print a))";
read_stream_init(&s, BUF, sizeof(BUF) - 1);
read_stream_init(&s, src, src_len);
LispVal *l = read(&s);
Feval(l, Qnil);
lisp_gc_now(NULL);
pop_stack_frame();
lisp_shutdown();
free(src);
return 0;
}

14
src/stack.c
View File

@ -2,7 +2,6 @@
#include "function.h"
#include "hashtable.h"
#include "list.h"
#include "memory.h"
#include <assert.h>
@ -46,6 +45,7 @@ void push_stack_frame(LispVal *name, LispVal *fobj, LispVal *args) {
struct StackFrame *frame = &the_stack.frames[the_stack.depth++];
frame->name = name;
frame->fobj = fobj;
frame->evaled_args = false;
frame->args = args;
frame->lexenv = Qnil;
frame->local_refs.num_refs = 0;
@ -182,6 +182,12 @@ void add_local_reference(LispVal *obj) {
release_hash_table_no_gc(seen_objs);
}
void set_stack_evaluated_args(LispVal *args) {
assert(the_stack.depth > 0);
LISP_STACK_TOP()->evaled_args = true;
LISP_STACK_TOP()->args = args;
}
void compact_stack_frame(struct StackFrame *restrict frame) {
struct LocalReferences *restrict refs = &frame->local_refs;
for (size_t i = 1; i < refs->num_blocks; ++i) {
@ -206,12 +212,6 @@ bool set_lexical_variable(LispVal *name, LispVal *value,
return create_if_absent;
}
void new_lexical_variable(LispVal *name, LispVal *value) {
assert(the_stack.depth != 0);
LISP_STACK_TOP()->lexenv =
CONS(name, CONS(value, LISP_STACK_TOP()->lexenv));
}
void copy_parent_lexenv(void) {
assert(the_stack.depth != 0);
if (the_stack.depth > 1) {

12
src/stack.h
View File

@ -2,6 +2,7 @@
#define INCLUDED_STACK_H
#include "base.h"
#include "list.h"
#define DEFAULT_MAX_LISP_EVAL_DEPTH 1000
#define LOCAL_REFERENCES_BLOCK_LENGTH 64
@ -19,6 +20,7 @@ struct LocalReferences {
struct StackFrame {
LispVal *name; // name of function call
LispVal *fobj; // the function object
bool evaled_args; // whether args have been evaluated yet
LispVal *args; // arguments of the function call
LispVal *lexenv; // lexical environment (plist)
struct LocalReferences local_refs;
@ -56,10 +58,18 @@ void pop_stack_frame(void);
void add_local_reference_no_recurse(LispVal *obj);
void add_local_reference(LispVal *obj);
// replace the args in the top stack frame with ARGS and mark them as evaluted
// (this is for backtraces)
void set_stack_evaluated_args(LispVal *args);
// Return true if successful, false if not found and not created
bool set_lexical_variable(LispVal *name, LispVal *value, bool create_if_absent);
// Just add a new lexical variable without any checking
void new_lexical_variable(LispVal *name, LispVal *value);
static inline void new_lexical_variable(LispVal *name, LispVal *value) {
assert(the_stack.depth != 0);
LISP_STACK_TOP()->lexenv =
CONS(name, CONS(value, LISP_STACK_TOP()->lexenv));
}
// Copy the previous frame's lexenv to the top of the stack.
void copy_parent_lexenv(void);