diff --git a/.clangd b/.clangd index 8441862..9a885a0 100644 --- a/.clangd +++ b/.clangd @@ -5,7 +5,7 @@ CompileFlags: -Wall, -Wpedantic, -xc, - -D_POSIX_C_SOURCE=199309L, + -D_POSIX_C_SOURCE=200112L, "-Isrc", "-I../", ] diff --git a/Makefile b/Makefile index 383301a..63f4c28 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ endif CC=gcc CFLAGS=$(DEBUG_CFLAGS) $(LLVM_SAN_FLAGS) -std=c11 -Wall -Wpedantic $\ - -D_POSIX_C_SOURCE=199309L + -D_POSIX_C_SOURCE=200112L LD=gcc LDFLAGS=$(LLVM_SAN_FLAGS) diff --git a/lisp/kernel.gl b/lisp/kernel.gl new file mode 100644 index 0000000..22a00df --- /dev/null +++ b/lisp/kernel.gl @@ -0,0 +1,4 @@ +;; -*- mode: lisp-data -*- + +(print (funcall (let ((te 'a)) + (lambda (b &optional (a te)) a)) 2)) diff --git a/src/base.c b/src/base.c index f8c8b6c..0788a77 100644 --- a/src/base.c +++ b/src/base.c @@ -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(); diff --git a/src/function.c b/src/function.c index 0074845..15b91d2 100644 --- a/src/function.c +++ b/src/function.c @@ -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"); diff --git a/src/function.h b/src/function.h index 2e5408b..ab70971 100644 --- a/src/function.h +++ b/src/function.h @@ -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 diff --git a/src/gc.c b/src/gc.c index 045ef59..d7268f3 100644 --- a/src/gc.c +++ b/src/gc.c @@ -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) { diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk index c381729..805ca1c 100644 --- a/src/gen-init-globals.awk +++ b/src/gen-init-globals.awk @@ -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 = "[,(]" diff --git a/src/lisp.c b/src/lisp.c index a42f8da..5ac486a 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -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, "", (uintmax_t) obj); + LispFunction *fobj = obj; + if (NILP(fobj->name)) { + fprintf(file, "", (uintmax_t) obj); + } else { + fprintf(file, "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); diff --git a/src/main.c b/src/main.c index 2703c85..99b53b3 100644 --- a/src/main.c +++ b/src/main.c @@ -1,22 +1,31 @@ #include "lisp.h" #include "read.h" +#include + 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; } diff --git a/src/stack.c b/src/stack.c index 1810674..0978505 100644 --- a/src/stack.c +++ b/src/stack.c @@ -2,7 +2,6 @@ #include "function.h" #include "hashtable.h" -#include "list.h" #include "memory.h" #include @@ -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) { diff --git a/src/stack.h b/src/stack.h index a007425..04f0870 100644 --- a/src/stack.h +++ b/src/stack.h @@ -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);