diff --git a/lispBM/include/eval_cps.h b/lispBM/include/eval_cps.h index 616558d7..31678b04 100644 --- a/lispBM/include/eval_cps.h +++ b/lispBM/include/eval_cps.h @@ -55,7 +55,7 @@ extern int eval_cps_init(void); extern bool eval_cps_remove_done_ctx(CID cid, VALUE *v); extern VALUE eval_cps_wait_ctx(CID cid); extern CID eval_cps_program(VALUE lisp); -extern CID eval_cps_program_ext(VALUE lisp, unsigned int stack_size, bool grow_stack); +extern CID eval_cps_program_ext(VALUE lisp, unsigned int stack_size); extern void eval_cps_run_eval(void); extern void eval_cps_pause_eval(void); @@ -79,7 +79,7 @@ extern void eval_cps_set_timestamp_us_callback(uint32_t (*fptr)(void)); extern void eval_cps_set_ctx_done_callback(void (*fptr)(eval_context_t *)); /* Non concurrent interface: */ -extern int eval_cps_init_nc(unsigned int stack_size, bool grow_stack); +extern int eval_cps_init_nc(unsigned int stack_size); extern void eval_cps_del_nc(void); extern VALUE eval_cps_program_nc(VALUE lisp); #endif diff --git a/lispBM/include/extensions.h b/lispBM/include/extensions.h index 05c82a08..8a135744 100644 --- a/lispBM/include/extensions.h +++ b/lispBM/include/extensions.h @@ -1,5 +1,6 @@ /* - Copyright 2019 Joel Svensson svenssonjoel@yahoo.se + Copyright 2019, 2022 Joel Svensson svenssonjoel@yahoo.se + 2022 Benjamin Vedder This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lispBM/include/print.h b/lispBM/include/print.h index 8b1b93be..0fb0cbf4 100644 --- a/lispBM/include/print.h +++ b/lispBM/include/print.h @@ -1,5 +1,6 @@ /* - Copyright 2018 Joel Svensson svenssonjoel@yahoo.se + Copyright 2018, 2022 Joel Svensson svenssonjoel@yahoo.se + 2022 Benjamin Vedder This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lispBM/include/stack.h b/lispBM/include/stack.h index 836821ed..b93b78d3 100644 --- a/lispBM/include/stack.h +++ b/lispBM/include/stack.h @@ -28,14 +28,12 @@ typedef struct { unsigned int sp; unsigned int size; unsigned int max_sp; - bool growable; } stack; -extern int stack_allocate(stack *s, unsigned int stack_size, bool growable); +extern int stack_allocate(stack *s, unsigned int stack_size); extern int stack_create(stack *s, UINT* data, unsigned int size); extern void stack_free(stack *s); extern int stack_clear(stack *s); -extern int stack_copy(stack *dest, stack *src); extern UINT *stack_ptr(stack *s, unsigned int n); extern int stack_drop(stack *s, unsigned int n); extern int push_u32(stack *s, UINT val); diff --git a/lispBM/include/symrepr.h b/lispBM/include/symrepr.h index 49669a25..0f177db6 100644 --- a/lispBM/include/symrepr.h +++ b/lispBM/include/symrepr.h @@ -1,5 +1,6 @@ /* - Copyright 2018 2021 Joel Svensson svenssonjoel@yahoo.se + Copyright 2018, 2021, 2022 Joel Svensson svenssonjoel@yahoo.se + 2022 Benjamin Vedder This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -37,9 +38,9 @@ #define SYM_MERROR 0xA #define SYM_DIVZERO 0xB #define SYM_FATAL_ERROR 0xC /* Runtime system is corrupt */ -#define SYM_DEFINE 0xD -#define SYM_PROGN 0xE -//#define SYM_BACKQUOTE 0xF +#define SYM_STACK_ERROR 0xD +#define SYM_DEFINE 0xE +#define SYM_PROGN 0xF #define SYM_COMMA 0x10 #define SYM_COMMAAT 0x11 #define SYM_DONTCARE 0x12 @@ -124,11 +125,10 @@ #define MAX_SPECIAL_SYMBOLS 4096 // 12bits (highest id allowed is 0xFFFF) extern int symrepr_addsym(char *, UINT*); -int symrepr_addsym_const(char *name, UINT* id); +extern int symrepr_addsym_const(char *, UINT*); extern bool symrepr_init(void); extern int symrepr_lookup(char *, UINT*); extern const char* symrepr_lookup_name(UINT); -extern void symrepr_del(void); extern unsigned int symrepr_size(void); diff --git a/lispBM/lispbm.mk b/lispBM/lispbm.mk index bf722bec..344fb805 100644 --- a/lispBM/lispbm.mk +++ b/lispBM/lispbm.mk @@ -9,7 +9,6 @@ LISPBMSRC = $(LISPBM)/src/env.c \ $(LISPBM)/src/stack.c \ $(LISPBM)/src/symrepr.c \ $(LISPBM)/src/tokpar.c \ - $(LISPBM)/src/compression.c \ $(LISPBM)/src/extensions.c \ $(LISPBM)/src/lispbm.c \ $(LISPBM)/src/eval_cps.c \ diff --git a/lispBM/src/ec_eval.c b/lispBM/src/ec_eval.c deleted file mode 100644 index 646b3540..00000000 --- a/lispBM/src/ec_eval.c +++ /dev/null @@ -1,645 +0,0 @@ -/* - Copyright 2020, 2021 Joel Svensson svenssonjoel@yahoo.se - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . -*/ - -#include "symrepr.h" -#include "heap.h" -#include "env.h" -#include "stack.h" -#include "fundamental.h" -#include "extensions.h" -#include "lispbm_types.h" -#include "ec_eval.h" -#include "exp_kind.h" -#include "print.h" - -typedef enum { - CONT_DONE, - CONT_ERROR, - CONT_DEFINE, - CONT_SETUP_NO_ARG_APPLY, - CONT_EVAL_ARGS, - CONT_ACCUMULATE_ARG, - CONT_ACCUMULATE_LAST_ARG, - CONT_BRANCH, - CONT_BIND_VAR, - CONT_END_LET, - CONT_SEQUENCE, - CONT_AND, - CONT_OR -} continuation; - -typedef enum { - EVAL_DISPATCH, - EVAL_CONTINUATION, - EVAL_APPLY_DISPATCH -} eval_state; - -/* Register machine: - * cont : Continuation register (what to do after evaluating a leaf) - * env : Local (let bound) environments - * unev : Hold something un-evaluated for a while - * prg : Keeps track of a list of expressions to evaluate (top-level) - * exp : Current expression - * argl : List of evaluated arguments to function - * val : Final or intermediate result - * fun : Evaluated function (for application) - */ - -typedef struct { - uint32_t cont; - VALUE env; - VALUE unev; - VALUE prg; - VALUE exp; - VALUE argl; - VALUE val; - VALUE fun; - - stack S; -} register_machine_t; - -register_machine_t rm_state; - -static char str[1024]; - -static int gc(VALUE env, - register_machine_t *rm) { - - gc_state_inc(); - gc_mark_freelist(); - gc_mark_phase(env); - - gc_mark_phase(rm->env); - gc_mark_phase(rm->unev); - gc_mark_phase(rm->prg); - gc_mark_phase(rm->exp); - gc_mark_phase(rm->argl); - gc_mark_phase(rm->val); - gc_mark_phase(rm->fun); - gc_mark_aux(rm->S.data, rm->S.sp); - - return gc_sweep_phase(); -} - -static inline bool last_operand(VALUE exp) { - return is_symbol_nil(cdr(exp)); -} - -static inline void eval_self_evaluating(eval_state *es) { - rm_state.val = rm_state.exp; - *es = EVAL_CONTINUATION; -} - -static inline void eval_variable(eval_state *es) { - if (is_special(rm_state.exp)) rm_state.val = rm_state.exp; - else if (is_extension(rm_state.exp)) rm_state.val = rm_state.exp; - else rm_state.val = env_lookup(rm_state.exp, rm_state.env); - - if (type_of(rm_state.val) == VAL_TYPE_SYMBOL && - dec_sym(rm_state.val) == SYM_NOT_FOUND) { - rm_state.val = env_lookup(rm_state.exp, *env_get_global_ptr()); - } - if (type_of(rm_state.val) == VAL_TYPE_SYMBOL && - dec_sym(rm_state.val) == SYM_NOT_FOUND) { - print_value(str, 1024, rm_state.exp); - rm_state.cont = enc_u(CONT_ERROR); - } - *es = EVAL_CONTINUATION; -} - -static inline void eval_quoted(eval_state *es) { - rm_state.val = car(cdr(rm_state.exp)); - *es = EVAL_CONTINUATION; -} - -static inline void eval_define(eval_state *es) { - rm_state.unev = car(cdr(rm_state.exp)); - rm_state.exp = car(cdr(cdr(rm_state.exp))); - push_u32_2(&rm_state.S, - rm_state.unev, - rm_state.cont); - rm_state.cont = enc_u(CONT_DEFINE); - *es = EVAL_DISPATCH; -} - -static inline void cont_define(eval_state *es) { - pop_u32_2(&rm_state.S, - &rm_state.cont, - &rm_state.unev); - VALUE new_env = env_set(*env_get_global_ptr(), - rm_state.unev, - rm_state.val); - if (is_symbol_merror(new_env)) { - gc(*env_get_global_ptr(), &rm_state); - new_env = env_set(*env_get_global_ptr(), - rm_state.unev, - rm_state.val); - } - if (is_symbol_merror(new_env)) { - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - return; - } - *env_get_global_ptr() = new_env; - rm_state.val = rm_state.unev; - *es = EVAL_CONTINUATION; -} - -static inline void eval_lambda(eval_state *es) { - - VALUE env_end = cons(rm_state.env, enc_sym(SYM_NIL)); - VALUE body = cons(car(cdr(cdr(rm_state.exp))), env_end); - VALUE params = cons(car(cdr(rm_state.exp)),body); - VALUE closure = cons(enc_sym(SYM_CLOSURE), params); - - if (is_symbol_merror(closure)) { - gc(*env_get_global_ptr(), &rm_state); - - env_end = cons(rm_state.env, enc_sym(SYM_NIL)); - body = cons(car(cdr(cdr(rm_state.exp))), env_end); - params = cons(car(cdr(rm_state.exp)),body); - closure = cons(enc_sym(SYM_CLOSURE), params); - } - - if (is_symbol_merror(closure)) { - // eval_lambda sets *es = EVAL_CONTINUATION - // this replaces the existing continuation with "done" - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - return; - } - rm_state.val = closure; - *es = EVAL_CONTINUATION; -} - -static inline void eval_no_args(eval_state *es) { - rm_state.exp = car(rm_state.exp); - push_u32(&rm_state.S, rm_state.cont); - rm_state.cont = enc_u(CONT_SETUP_NO_ARG_APPLY); - *es = EVAL_DISPATCH; -} - -static inline void cont_setup_no_arg_apply(eval_state *es) { - rm_state.fun = rm_state.val; - rm_state.argl = enc_sym(SYM_NIL); - *es = EVAL_APPLY_DISPATCH; -} - -static inline void eval_application(eval_state *es) { - rm_state.unev = cdr(rm_state.exp); - rm_state.exp = car(rm_state.exp); - push_u32_3(&rm_state.S, rm_state.cont, rm_state.env, rm_state.unev); - rm_state.cont = enc_u(CONT_EVAL_ARGS); - *es = EVAL_DISPATCH; -} - -static inline void eval_last_arg(eval_state *es) { - rm_state.cont = enc_u(CONT_ACCUMULATE_LAST_ARG); - *es = EVAL_DISPATCH; -} - -static inline void eval_arg_loop(eval_state *es) { - push_u32(&rm_state.S, rm_state.argl); - rm_state.exp = car(rm_state.unev); - if (last_operand(rm_state.unev)) { - eval_last_arg(es); - return; - } - push_u32_2(&rm_state.S, rm_state.env, rm_state.unev); - rm_state.cont = enc_u(CONT_ACCUMULATE_ARG); - *es = EVAL_DISPATCH; -} - -static inline void cont_eval_args(eval_state *es) { - pop_u32_2(&rm_state.S,&rm_state.unev, &rm_state.env); - rm_state.fun = rm_state.val; - push_u32(&rm_state.S,rm_state.fun); - rm_state.argl = enc_sym(SYM_NIL); - eval_arg_loop(es); -} - -static inline void cont_accumulate_arg(eval_state *es) { - pop_u32_3(&rm_state.S, &rm_state.unev, &rm_state.env, &rm_state.argl); - VALUE argl = cons(rm_state.val, rm_state.argl); - - if (is_symbol_merror(argl)) { - gc(*env_get_global_ptr(), &rm_state); - - argl = cons(rm_state.val, rm_state.argl); - } - if (is_symbol_merror(argl)) { - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - return; - } - - rm_state.argl = argl; - rm_state.unev = cdr(rm_state.unev); - eval_arg_loop(es); -} - -static inline void cont_accumulate_last_arg(eval_state *es) { - pop_u32(&rm_state.S, &rm_state.argl); - - VALUE argl = cons(rm_state.val, rm_state.argl); - - if (is_symbol_merror(argl)) { - gc(*env_get_global_ptr(), &rm_state); - argl = cons(rm_state.val, rm_state.argl); - } - if (is_symbol_merror(argl)) { - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - return; - } - rm_state.argl = argl; - - VALUE rev_args = reverse(rm_state.argl); - - if (is_symbol_merror(rev_args)) { - gc(*env_get_global_ptr(), &rm_state); - rev_args = reverse(rm_state.argl); - } - if (is_symbol_merror(rev_args)) { - rm_state.cont = CONT_ERROR; - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - } - - rm_state.argl = rev_args; - pop_u32(&rm_state.S, &rm_state.fun); - *es = EVAL_APPLY_DISPATCH; -} - -static inline void eval_apply_fundamental(eval_state *es) { - UINT count = 0; - VALUE args = rm_state.argl; - while (type_of(args) == PTR_TYPE_CONS) { - push_u32(&rm_state.S, car(args)); - count ++; - args = cdr(args); - } - UINT *fun_args = stack_ptr(&rm_state.S, count); - VALUE val = fundamental_exec(fun_args, count, rm_state.fun); - if (is_symbol_merror(val)) { - gc(*env_get_global_ptr(), &rm_state); - val = fundamental_exec(fun_args, count, rm_state.fun); - } - if (is_symbol_merror(val)) { - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - return; - } - - rm_state.val = val; - - stack_drop(&rm_state.S, count); - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_CONTINUATION; -} - -static inline void eval_apply_closure(eval_state *es) { - VALUE local_env = env_build_params_args(car(cdr(rm_state.fun)), - rm_state.argl, - car(cdr(cdr(cdr(rm_state.fun))))); - if (is_symbol_merror(local_env)) { - gc(*env_get_global_ptr(), &rm_state); - local_env = env_build_params_args(car(cdr(rm_state.fun)), - rm_state.argl, - car(cdr(cdr(cdr(rm_state.fun))))); - } - if (is_symbol_merror(local_env)) { - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - return; - } - - rm_state.env = local_env; - rm_state.exp = car(cdr(cdr(rm_state.fun))); - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_DISPATCH; -} - -static inline void eval_apply_extension(eval_state *es) { - extension_fptr f = extensions_lookup(dec_sym(rm_state.fun)); - if (!f) { - rm_state.cont = enc_u(CONT_ERROR); - *es = EVAL_CONTINUATION; - return; - } - UINT count = 0; - VALUE args = rm_state.argl; - UINT *fun_args = stack_ptr(&rm_state.S, count); - while (type_of(args) == PTR_TYPE_CONS) { - push_u32(&rm_state.S, car(args)); - count ++; - args = cdr(args); - } - rm_state.val = f(fun_args, count); - stack_drop(&rm_state.S, count); - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_CONTINUATION; -} - -static inline void eval_eval(eval_state *es) { - rm_state.exp = car(rm_state.argl); - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_DISPATCH; -} - -static inline void eval_apply_dispatch(eval_state *es) { - if (is_symbol_eval(rm_state.fun)) eval_eval(es); - else if (is_fundamental(rm_state.fun)) eval_apply_fundamental(es); - else if (is_closure(rm_state.fun)) eval_apply_closure(es); - else if (is_extension(rm_state.fun)) eval_apply_extension(es); - else { - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_EERROR); - print_value(str,1024, rm_state.fun); - *es = EVAL_CONTINUATION; - } -} - -static inline void eval_sequence(eval_state *es) { - - rm_state.exp = car(rm_state.unev); - pop_u32(&rm_state.S, &rm_state.env); - VALUE tmp = cdr(rm_state.unev); - if (type_of(tmp) == VAL_TYPE_SYMBOL && - dec_sym(tmp) == SYM_NIL) { - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_DISPATCH; - return; - } - push_u32_2(&rm_state.S, rm_state.env, rm_state.unev); - rm_state.cont = enc_u(CONT_SEQUENCE); - *es = EVAL_DISPATCH; -} - -static inline void cont_sequence(eval_state *es) { - pop_u32(&rm_state.S, &rm_state.unev); - rm_state.unev = cdr(rm_state.unev); - eval_sequence(es); -} - -static inline void eval_progn(eval_state *es) { - push_u32_2(&rm_state.S, rm_state.cont, rm_state.env); - rm_state.unev = cdr(rm_state.exp); - eval_sequence(es); -} - -static inline void eval_if(eval_state *es) { - rm_state.unev = cdr(cdr(rm_state.exp)); - rm_state.exp = car(cdr(rm_state.exp)); - push_u32_3(&rm_state.S, rm_state.cont, rm_state.env, rm_state.unev); - rm_state.cont = enc_u(CONT_BRANCH); - *es = EVAL_DISPATCH; -} - -static inline void cont_branch(eval_state *es) { - pop_u32_3(&rm_state.S, &rm_state.unev,&rm_state.env, &rm_state.cont); - if (is_symbol_nil(rm_state.val)) { - rm_state.exp = car(cdr(rm_state.unev)); - }else { - rm_state.exp = car(rm_state.unev); - } - *es = EVAL_DISPATCH; -} - -static inline void eval_let_loop(eval_state *es) { - if (is_symbol_nil(rm_state.unev)) { - pop_u32(&rm_state.S, &rm_state.exp); - rm_state.cont = enc_u(CONT_END_LET); - *es = EVAL_DISPATCH; - return; - } - rm_state.exp = car(cdr(car(rm_state.unev))); - - push_u32_2(&rm_state.S, rm_state.env, rm_state.unev); - rm_state.cont = enc_u(CONT_BIND_VAR); - *es = EVAL_DISPATCH; -} - -static inline void eval_let(eval_state *es) { - rm_state.unev = car(cdr(cdr(rm_state.exp))); - push_u32_3(&rm_state.S, rm_state.cont, rm_state.env, rm_state.unev); - - rm_state.unev = car(cdr(rm_state.exp)); - - // Preallocate bindings - VALUE curr = rm_state.unev; - VALUE new_env = rm_state.env; - while (!is_symbol_nil(curr)) { - VALUE key = car(car(curr)); - VALUE val = enc_u(SYM_NIL); - VALUE binding = cons(key, val); - VALUE tmp_env = cons(binding, new_env); - - if (is_symbol_merror(binding) || - is_symbol_merror(new_env)) { - gc(*env_get_global_ptr(), &rm_state); - binding = cons(key, val); - tmp_env = cons(binding, new_env); - } - if (is_symbol_merror(binding) || - is_symbol_merror(new_env)) { - rm_state.cont = enc_u(CONT_ERROR); - rm_state.val = enc_sym(SYM_MERROR); - *es = EVAL_CONTINUATION; - return; - } - new_env = tmp_env; - curr = cdr(curr); - } - - rm_state.env = new_env; - eval_let_loop(es); -} - -static inline void cont_bind_var(eval_state *es) { - pop_u32_2(&rm_state.S,&rm_state.unev, &rm_state.env); - env_modify_binding(rm_state.env, car(car(rm_state.unev)), rm_state.val); - rm_state.unev = cdr(rm_state.unev); - eval_let_loop(es); -} - -static inline void cont_end_let(eval_state *es) { - pop_u32_2(&rm_state.S, &rm_state.env, &rm_state.cont); - *es = EVAL_CONTINUATION; -} - -static inline void eval_and(eval_state *es) { - if (is_symbol_nil(cdr(rm_state.exp))) { - rm_state.val = enc_sym(SYM_TRUE); - *es = EVAL_CONTINUATION; - } - rm_state.unev = cdr(cdr(rm_state.exp)); - push_u32_3(&rm_state.S, rm_state.cont, rm_state.env, rm_state.unev); - rm_state.exp = car(cdr(rm_state.exp)); - rm_state.cont = enc_u(CONT_AND); - *es = EVAL_DISPATCH; -} - -static inline void cont_and(eval_state *es) { - pop_u32_2(&rm_state.S, &rm_state.unev, &rm_state.env); - if (is_symbol_nil(rm_state.val)) { - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_CONTINUATION; - return; - } - if (is_symbol_nil(rm_state.unev)) { - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_CONTINUATION; - return; - } - rm_state.exp = car(rm_state.unev); - rm_state.unev = cdr(rm_state.unev); - push_u32_2(&rm_state.S, rm_state.env, rm_state.unev); - rm_state.cont = enc_u(CONT_AND); - *es = EVAL_DISPATCH; -} - -static inline void eval_or(eval_state *es) { - if (is_symbol_nil(cdr(rm_state.exp))) { - rm_state.val = enc_sym(SYM_NIL); - *es = EVAL_CONTINUATION; - } - rm_state.unev = cdr(cdr(rm_state.exp)); - push_u32_3(&rm_state.S, rm_state.cont, rm_state.env, rm_state.unev); - rm_state.exp = car(cdr(rm_state.exp)); - rm_state.cont = enc_u(CONT_OR); - *es = EVAL_DISPATCH; -} - -static inline void cont_or(eval_state *es) { - pop_u32_2(&rm_state.S, &rm_state.unev, &rm_state.env); - if (!is_symbol_nil(rm_state.val)) { - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_CONTINUATION; - return; - } - if (is_symbol_nil(rm_state.unev)) { - pop_u32(&rm_state.S, &rm_state.cont); - *es = EVAL_CONTINUATION; - return; - } - rm_state.exp = car(rm_state.unev); - rm_state.unev = cdr(rm_state.unev); - push_u32_2(&rm_state.S, rm_state.env, rm_state.unev); - rm_state.cont = enc_u(CONT_OR); - *es = EVAL_DISPATCH; -} - -static inline void cont_done(eval_state *es, bool *done) { - if (type_of(rm_state.prg) != PTR_TYPE_CONS) { - *done = true; - return; - } - rm_state.exp = car(rm_state.prg); - rm_state.prg = cdr(rm_state.prg); - rm_state.cont = enc_u(CONT_DONE); - rm_state.env = enc_sym(SYM_NIL); - rm_state.argl = enc_sym(SYM_NIL); - rm_state.val = enc_sym(SYM_NIL); - rm_state.fun = enc_sym(SYM_NIL); - stack_clear(&rm_state.S); - *done = false; - *es = EVAL_DISPATCH; -} - -static inline void cont_error(eval_state *es, bool *done) { - rm_state.exp = enc_sym(SYM_NIL); - rm_state.prg = enc_sym(SYM_NIL); - rm_state.cont = enc_sym(SYM_NIL); - rm_state.env = enc_sym(SYM_NIL); - rm_state.argl = enc_sym(SYM_NIL); - rm_state.val = enc_sym(SYM_EERROR); - rm_state.fun = enc_sym(SYM_NIL); - stack_clear(&rm_state.S); - *done = true; - *es = EVAL_DISPATCH; -} - -void ec_eval(void) { - - eval_state es = EVAL_DISPATCH; - - bool done = false; - - while (!done) { - - switch(es) { - case EVAL_DISPATCH: - switch (exp_kind_of(rm_state.exp)) { - case EXP_SELF_EVALUATING: eval_self_evaluating(&es); break; - case EXP_VARIABLE: eval_variable(&es); break; - case EXP_QUOTED: eval_quoted(&es); break; - case EXP_DEFINE: eval_define(&es); break; - case EXP_NO_ARGS: eval_no_args(&es); break; - case EXP_APPLICATION: eval_application(&es); break; - case EXP_LAMBDA: eval_lambda(&es); break; - case EXP_PROGN: eval_progn(&es); break; - case EXP_IF: eval_if(&es); break; - case EXP_LET: eval_let(&es); break; - case EXP_AND: eval_and(&es); break; - case EXP_OR: eval_or(&es); break; - case EXP_KIND_ERROR: done = true; break; - } - break; - case EVAL_CONTINUATION: - switch (dec_u(rm_state.cont)) { - case CONT_DONE: cont_done(&es, &done); break; - case CONT_ERROR: cont_error(&es, &done); break; - case CONT_DEFINE: cont_define(&es); break; - case CONT_SETUP_NO_ARG_APPLY: cont_setup_no_arg_apply(&es); break; - case CONT_EVAL_ARGS: cont_eval_args(&es); break; - case CONT_ACCUMULATE_ARG: cont_accumulate_arg(&es); break; - case CONT_ACCUMULATE_LAST_ARG: cont_accumulate_last_arg(&es); break; - case CONT_BRANCH: cont_branch(&es); break; - case CONT_BIND_VAR: cont_bind_var(&es); break; - case CONT_END_LET: cont_end_let(&es); break; - case CONT_SEQUENCE: cont_sequence(&es); break; - case CONT_AND: cont_and(&es); break; - case CONT_OR: cont_or(&es); break; - } - break; - case EVAL_APPLY_DISPATCH: eval_apply_dispatch(&es); break; - } - } -} - -VALUE ec_eval_program(VALUE prg) { - - rm_state.prg = cdr(prg); - rm_state.exp = car(prg); - rm_state.cont = enc_u(CONT_DONE); - rm_state.env = enc_sym(SYM_NIL); - rm_state.argl = enc_sym(SYM_NIL); - rm_state.val = enc_sym(SYM_NIL); - rm_state.fun = enc_sym(SYM_NIL); - stack_allocate(&rm_state.S, 256, false); - ec_eval(); - - stack_free(&rm_state.S); - return rm_state.val; -} diff --git a/lispBM/src/eval_cps.c b/lispBM/src/eval_cps.c index 377169e2..e0d3407c 100644 --- a/lispBM/src/eval_cps.c +++ b/lispBM/src/eval_cps.c @@ -47,10 +47,11 @@ #define MATCH 12 #define MATCH_MANY 13 -#define FOF(done, x) \ +#define CHECK_STACK(x) \ if (!(x)) { \ - (done)=true; \ - ctx->r = enc_sym(SYM_FATAL_ERROR); \ + ctx->done=true; \ + ctx->r = enc_sym(SYM_STACK_ERROR); \ + finish_ctx(); \ return; \ } @@ -389,7 +390,7 @@ static void yield_ctx(uint32_t sleep_us) { ctx_running = NULL; } -static CID create_ctx(VALUE program, VALUE env, uint32_t stack_size, bool grow_stack) { +static CID create_ctx(VALUE program, VALUE env, uint32_t stack_size) { if (next_ctx_id == 0) return 0; // overflow of CIDs @@ -415,7 +416,7 @@ static CID create_ctx(VALUE program, VALUE env, uint32_t stack_size, bool grow_s } ctx->id = (uint16_t)next_ctx_id++; - if (!stack_allocate(&ctx->K, stack_size, grow_stack)) { + if (!stack_allocate(&ctx->K, stack_size)) { memory_free((uint32_t*)ctx); return 0; } @@ -447,8 +448,6 @@ static void advance_ctx(void) { } } - - static VALUE find_receiver_and_send(CID cid, VALUE msg) { eval_context_t *found = NULL; @@ -662,7 +661,6 @@ static int gc(VALUE remember1, VALUE remember2) { curr = curr->next; } - curr = blocked.first; while (curr) { gc_mark_phase(curr->curr_env); @@ -688,7 +686,6 @@ static int gc(VALUE remember1, VALUE remember2) { #endif return gc_sweep_phase(); - } @@ -738,7 +735,7 @@ static inline void eval_define(eval_context_t *ctx) { return; } - FOF(ctx->done, push_u32_2(&ctx->K, key, enc_u(SET_GLOBAL_ENV))); + CHECK_STACK(push_u32_2(&ctx->K, key, enc_u(SET_GLOBAL_ENV))); ctx->curr_exp = val_exp; } @@ -758,7 +755,7 @@ static inline void eval_progn(eval_context_t *ctx) { error_ctx(exps); return; } - FOF(ctx->done, push_u32_3(&ctx->K, env, cdr(exps), enc_u(PROGN_REST))); + CHECK_STACK(push_u32_3(&ctx->K, env, cdr(exps), enc_u(PROGN_REST))); ctx->curr_exp = car(exps); ctx->curr_env = env; } @@ -774,7 +771,7 @@ static inline void eval_spawn(eval_context_t *ctx) { } VALUE cid_list = NIL; - FOF(ctx->done, push_u32_3(&ctx->K, env, prgs, enc_u(SPAWN_ALL))); + CHECK_STACK(push_u32_3(&ctx->K, env, prgs, enc_u(SPAWN_ALL))); ctx->r = cid_list; ctx->app_cont = true; } @@ -811,10 +808,10 @@ static inline void eval_lambda(eval_context_t *ctx) { static inline void eval_if(eval_context_t *ctx) { - FOF(ctx->done, push_u32_3(&ctx->K, - car(cdr(cdr(cdr(ctx->curr_exp)))), // Else branch - car(cdr(cdr(ctx->curr_exp))), // Then branch - enc_u(IF))); + CHECK_STACK(push_u32_3(&ctx->K, + car(cdr(cdr(cdr(ctx->curr_exp)))), // Else branch + car(cdr(cdr(ctx->curr_exp))), // Then branch + enc_u(IF))); ctx->curr_exp = car(cdr(ctx->curr_exp)); } @@ -846,8 +843,8 @@ static inline void eval_let(eval_context_t *ctx) { VALUE key0 = car(car(binds)); VALUE val0_exp = car(cdr(car(binds))); - FOF(ctx->done, push_u32_5(&ctx->K, exp, cdr(binds), new_env, - key0, enc_u(BIND_TO_KEY_REST))); + CHECK_STACK(push_u32_5(&ctx->K, exp, cdr(binds), new_env, + key0, enc_u(BIND_TO_KEY_REST))); ctx->curr_exp = val0_exp; ctx->curr_env = new_env; return; @@ -860,7 +857,7 @@ static inline void eval_and(eval_context_t *ctx) { ctx->app_cont = true; ctx->r = enc_sym(SYM_TRUE); } else { - FOF(ctx->done, push_u32_2(&ctx->K, cdr(rest), enc_u(AND))); + CHECK_STACK(push_u32_2(&ctx->K, cdr(rest), enc_u(AND))); ctx->curr_exp = car(rest); } } @@ -873,7 +870,7 @@ static inline void eval_or(eval_context_t *ctx) { ctx->r = enc_sym(SYM_NIL); return; } else { - FOF(ctx->done, push_u32_2(&ctx->K, cdr(rest), enc_u(OR))); + CHECK_STACK(push_u32_2(&ctx->K, cdr(rest), enc_u(OR))); ctx->curr_exp = car(rest); } } @@ -893,7 +890,7 @@ static inline void eval_match(eval_context_t *ctx) { ctx->r = enc_sym(SYM_NIL); /* make up new specific symbol? */ return; } else { - FOF(ctx->done, push_u32_2(&ctx->K, cdr(rest), enc_u(MATCH))); + CHECK_STACK(push_u32_2(&ctx->K, cdr(rest), enc_u(MATCH))); ctx->curr_exp = car(rest); /* Evaluate e next*/ } } @@ -999,7 +996,7 @@ static inline void cont_progn_rest(eval_context_t *ctx) { return; } // Else create a continuation - FOF(ctx->done, push_u32_3(&ctx->K, env, cdr(rest), enc_u(PROGN_REST))); + CHECK_STACK(push_u32_3(&ctx->K, env, cdr(rest), enc_u(PROGN_REST))); ctx->curr_exp = car(rest); ctx->curr_env = env; } @@ -1019,12 +1016,11 @@ static inline void cont_spawn_all(eval_context_t *ctx) { CID cid = create_ctx(car(rest), env, - EVAL_CPS_DEFAULT_STACK_SIZE, - EVAL_CPS_DEFAULT_STACK_GROW_POLICY); + EVAL_CPS_DEFAULT_STACK_SIZE); if (!cid) { set_car(cid_list, enc_sym(SYM_NIL)); } - FOF(ctx->done, push_u32_3(&ctx->K, env, cdr(rest), enc_u(SPAWN_ALL))); + CHECK_STACK(push_u32_3(&ctx->K, env, cdr(rest), enc_u(SPAWN_ALL))); ctx->r = cid_list; ctx->app_cont = true; } @@ -1041,7 +1037,7 @@ static inline void cont_wait(eval_context_t *ctx) { ctx->r = r; ctx->app_cont = true; } else { - FOF(ctx->done, push_u32_2(&ctx->K, enc_u(cid), enc_u(WAIT))); + CHECK_STACK(push_u32_2(&ctx->K, enc_u(cid), enc_u(WAIT))); ctx->r = enc_sym(SYM_TRUE); ctx->app_cont = true; yield_ctx(50000); @@ -1094,7 +1090,6 @@ static inline void cont_application(eval_context_t *ctx) { I am very unsure about the correctness here. ************************************************************ */ - stack_drop(&ctx->K, dec_u(count)+1); ctx->curr_exp = exp; ctx->curr_env = local_env; @@ -1118,7 +1113,7 @@ static inline void cont_application(eval_context_t *ctx) { if (type_of(fun_args[1]) == VAL_TYPE_I) { CID cid = (CID)dec_u(fun_args[1]); stack_drop(&ctx->K, dec_u(count)+1); - FOF(ctx->done, push_u32_2(&ctx->K, enc_u(cid), enc_u(WAIT))); + CHECK_STACK(push_u32_2(&ctx->K, enc_u(cid), enc_u(WAIT))); ctx->r = enc_sym(SYM_TRUE); ctx->app_cont = true; yield_ctx(50000); @@ -1165,12 +1160,7 @@ static inline void cont_application(eval_context_t *ctx) { } } - // It may be an extension. Run GC first so that the extension has to worry less - // about running out of memory. - if (heap_size() - heap_num_allocated() < PRELIMINARY_GC_MEASURE) { - gc(NIL, NIL); - } - + // It may be an extension extension_fptr f = extensions_lookup(dec_sym(fun)); if (f == NULL) { ERROR @@ -1195,15 +1185,15 @@ static inline void cont_application_args(eval_context_t *ctx) { VALUE arg = ctx->r; pop_u32_3(&ctx->K, &rest, &count, &env); - FOF(ctx->done, push_u32(&ctx->K, arg)); + CHECK_STACK(push_u32(&ctx->K, arg)); /* Deal with general fundamentals */ if (type_of(rest) == VAL_TYPE_SYMBOL && rest == NIL) { // no arguments - FOF(ctx->done, push_u32_2(&ctx->K, count, enc_u(APPLICATION))); + CHECK_STACK(push_u32_2(&ctx->K, count, enc_u(APPLICATION))); ctx->app_cont = true; } else if (type_of(rest) == PTR_TYPE_CONS) { - FOF(ctx->done, push_u32_4(&ctx->K, env, enc_u(dec_u(count) + 1), cdr(rest), enc_u(APPLICATION_ARGS))); + CHECK_STACK(push_u32_4(&ctx->K, env, enc_u(dec_u(count) + 1), cdr(rest), enc_u(APPLICATION_ARGS))); ctx->curr_exp = car(rest); ctx->curr_env = env; } else { @@ -1226,7 +1216,7 @@ static inline void cont_and(eval_context_t *ctx) { rest == NIL) { ctx->app_cont = true; } else { - FOF(ctx->done, push_u32_2(&ctx->K, cdr(rest), enc_u(AND))); + CHECK_STACK(push_u32_2(&ctx->K, cdr(rest), enc_u(AND))); ctx->curr_exp = car(rest); } } @@ -1243,7 +1233,7 @@ static inline void cont_or(eval_context_t *ctx) { ctx->app_cont = true; ctx->r = enc_sym(SYM_NIL); } else { - FOF(ctx->done, push_u32_2(&ctx->K, cdr(rest), enc_u(OR))); + CHECK_STACK(push_u32_2(&ctx->K, cdr(rest), enc_u(OR))); ctx->curr_exp = car(rest); } } @@ -1261,7 +1251,7 @@ static inline void cont_bind_to_key_rest(eval_context_t *ctx) { VALUE keyn = car(car(rest)); VALUE valn_exp = car(cdr(car(rest))); - FOF(ctx->done, push_u32_4(&ctx->K, cdr(rest), env, keyn, enc_u(BIND_TO_KEY_REST))); + CHECK_STACK(push_u32_4(&ctx->K, cdr(rest), env, keyn, enc_u(BIND_TO_KEY_REST))); ctx->curr_exp = valn_exp; ctx->curr_env = env; @@ -1308,8 +1298,8 @@ static inline void cont_match_many(eval_context_t *ctx) { } else { /* try match the next one */ - FOF(ctx->done, push_u32_4(&ctx->K, exp, pats, cdr(rest_msgs), enc_u(MATCH_MANY))); - FOF(ctx->done, push_u32_2(&ctx->K, car(pats), enc_u(MATCH))); + CHECK_STACK(push_u32_4(&ctx->K, exp, pats, cdr(rest_msgs), enc_u(MATCH_MANY))); + CHECK_STACK(push_u32_2(&ctx->K, car(pats), enc_u(MATCH))); ctx->r = car(rest_msgs); ctx->app_cont = true; } @@ -1352,7 +1342,7 @@ static inline void cont_match(eval_context_t *ctx) { ctx->curr_exp = body; } else { /* set up for checking of next pattern */ - FOF(ctx->done, push_u32_2(&ctx->K, cdr(patterns), enc_u(MATCH))); + CHECK_STACK(push_u32_2(&ctx->K, cdr(patterns), enc_u(MATCH))); /* leave r unaltered */ ctx->app_cont = true; } @@ -1439,11 +1429,11 @@ static void evaluation_step(void){ default: break; /* May be general application form. Checked below*/ } } // If head is symbol - FOF(ctx->done, push_u32_4(&ctx->K, - ctx->curr_env, - enc_u(0), - cdr(ctx->curr_exp), - enc_u(APPLICATION_ARGS))); + CHECK_STACK(push_u32_4(&ctx->K, + ctx->curr_env, + enc_u(0), + cdr(ctx->curr_exp), + enc_u(APPLICATION_ARGS))); ctx->curr_exp = head; // evaluate the function return; @@ -1507,6 +1497,8 @@ void eval_cps_run_eval(void){ if (heap_size() - heap_num_allocated() < PRELIMINARY_GC_MEASURE) { gc(NIL, NIL); } + /* TODO: Logic for sleeping in case the evaluator has been using a lot of CPU + should go here */ if (!ctx_running) { uint32_t us; @@ -1518,6 +1510,7 @@ void eval_cps_run_eval(void){ continue; } } + evaluation_step(); } } @@ -1541,11 +1534,11 @@ VALUE evaluate_non_concurrent(void) { } CID eval_cps_program(VALUE lisp) { - return create_ctx(lisp, NIL, 256, false); + return create_ctx(lisp, NIL, 256); } -CID eval_cps_program_ext(VALUE lisp, unsigned int stack_size, bool grow_stack) { - return create_ctx(lisp, NIL, stack_size, grow_stack); +CID eval_cps_program_ext(VALUE lisp, unsigned int stack_size) { + return create_ctx(lisp, NIL, stack_size); } VALUE eval_cps_program_nc(VALUE lisp) { @@ -1571,7 +1564,7 @@ VALUE eval_cps_program_nc(VALUE lisp) { return evaluate_non_concurrent(); } -int eval_cps_init_nc(unsigned int stack_size, bool grow_stack) { +int eval_cps_init_nc(unsigned int stack_size) { NIL = enc_sym(SYM_NIL); NONSENSE = enc_sym(SYM_NONSENSE); @@ -1585,7 +1578,7 @@ int eval_cps_init_nc(unsigned int stack_size, bool grow_stack) { type_of(*env_get_global_ptr()) == VAL_TYPE_SYMBOL) return 0; - if (!stack_allocate(&ctx_non_concurrent.K, stack_size, grow_stack)) + if (!stack_allocate(&ctx_non_concurrent.K, stack_size)) return 0; return 1; diff --git a/lispBM/src/extensions.c b/lispBM/src/extensions.c index 3effb1ff..cb789751 100644 --- a/lispBM/src/extensions.c +++ b/lispBM/src/extensions.c @@ -1,5 +1,6 @@ /* - Copyright 2019, 2021 Joel Svensson svenssonjoel@yahoo.se + Copyright 2019, 2021, 2022 Joel Svensson svenssonjoel@yahoo.se + 2022 Benjamin Vedder This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -67,3 +68,4 @@ bool extensions_add(char *sym_str, extension_fptr ext) { extensions = m; return true; } + diff --git a/lispBM/src/lispbm.c b/lispBM/src/lispbm.c index d4432cd4..43b037c4 100644 --- a/lispBM/src/lispbm.c +++ b/lispBM/src/lispbm.c @@ -24,22 +24,22 @@ int lispbm_init(cons_t *heap_storage, uint32_t heap_size, if (memory_init(memory, memory_size, memory_bitmap, bitmap_size) == 0) - return -1; + return 0; if (symrepr_init() == 0) - return -2; + return 0; if (heap_init(heap_storage, heap_size) == 0) - return -3; + return 0; if (env_init() == 0) - return -4; + return 0; if (eval_cps_init() == 0) - return -5; + return 0; if (extensions_init() == 0) - return -6; + return 0; return 1; } diff --git a/lispBM/src/print.c b/lispBM/src/print.c index a450d2d2..328a00c3 100644 --- a/lispBM/src/print.c +++ b/lispBM/src/print.c @@ -1,5 +1,6 @@ /* - Copyright 2018, 2020, 2021 Joel Svensson svenssonjoel@yahoo.se + Copyright 2018, 2020, 2021, 2022 Joel Svensson svenssonjoel@yahoo.se + 2022 Benjamin Vedder This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -34,8 +35,11 @@ #define END_LIST 5 #define PRINT_DOT 6 +static VALUE stack_storage[PRINT_STACK_SIZE]; + +const char *failed_str = "Error: print failed\n"; + int print_value(char *buf,unsigned int len, VALUE t) { - VALUE stack_storage[PRINT_STACK_SIZE]; stack s; stack_create(&s, stack_storage, PRINT_STACK_SIZE); @@ -46,8 +50,6 @@ int print_value(char *buf,unsigned int len, VALUE t) { const char *str_ptr; int res; - const char *failed_str = "Error: print failed\n"; - push_u32_2(&s, t, PRINT); while (!stack_is_empty(&s) && offset <= len - 5) { @@ -66,7 +68,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r >= 0 ) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } @@ -113,7 +115,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -143,7 +145,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -154,7 +156,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } @@ -165,7 +167,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if (r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, "Error: PRINT_DOT failed\n"); + snprintf(buf, len, "%s", failed_str); return -1; } offset +=n; @@ -193,7 +195,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -207,7 +209,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -220,7 +222,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -233,7 +235,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -248,7 +250,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -266,7 +268,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -284,7 +286,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -295,7 +297,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -306,7 +308,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; @@ -317,7 +319,7 @@ int print_value(char *buf,unsigned int len, VALUE t) { if ( r > 0) { n = (unsigned int) r; } else { - snprintf(buf, len, failed_str); + snprintf(buf, len, "%s", failed_str); return -1; } offset += n; diff --git a/lispBM/src/stack.c b/lispBM/src/stack.c index 31b2c646..3d301512 100644 --- a/lispBM/src/stack.c +++ b/lispBM/src/stack.c @@ -22,11 +22,10 @@ #include "print.h" #include "lispbm_memory.h" -int stack_allocate(stack *s, unsigned int stack_size, bool growable) { +int stack_allocate(stack *s, unsigned int stack_size) { s->data = memory_allocate(stack_size); s->sp = 0; s->size = stack_size; - s->growable = growable; s->max_sp = 0; if (s->data) return 1; @@ -37,7 +36,6 @@ int stack_create(stack *s, UINT* data, unsigned int size) { s->data = data; s->sp = 0; s->size = size; - s->growable = false; s->max_sp = 0; return 1; } @@ -53,37 +51,6 @@ int stack_clear(stack *s) { return 1; } - -int stack_grow(stack *s) { - - if (!s->growable) return 0; - - unsigned int new_size = s->size * 2; - UINT *data = memory_allocate(new_size); - - if (data == NULL) return 0; - - memcpy(data, s->data, s->size*sizeof(UINT)); - memory_free(s->data); - s->data = data; - s->size = new_size; - return 1; -} - -int stack_copy(stack *dest, stack *src) { - - if (dest->growable) { - while (dest->size < src->sp) { - if (!stack_grow(dest)) return 0; - } - } - if (dest->size < src->size) return 0; - dest->sp = src->sp; - memcpy(dest->data, src->data, src->sp * sizeof(UINT)); - - return 1; -} - UINT *stack_ptr(stack *s, unsigned int n) { if (n > s->sp) return NULL; unsigned int index = s->sp - n; @@ -101,7 +68,7 @@ int stack_drop(stack *s, unsigned int n) { int push_u32(stack *s, UINT val) { int res = 1; if (s->sp == s->size) { - res = stack_grow(s); + return 0; } if (!res) return res; @@ -116,11 +83,14 @@ int push_u32(stack *s, UINT val) { int push_k(stack *s, VALUE (*k)(VALUE)) { int res = 1; + if ( s->sp == s->size) { + return 0; + } + + if (!res) return res; + s->data[s->sp] = (UINT)k; s->sp++; - if ( s->sp >= s->size) { - res = stack_grow(s); - } if (s->sp > s->max_sp) s->max_sp = s->sp; diff --git a/lispBM/src/symrepr.c b/lispBM/src/symrepr.c index 4e980276..a12a2526 100644 --- a/lispBM/src/symrepr.c +++ b/lispBM/src/symrepr.c @@ -24,7 +24,7 @@ #include "symrepr.h" #include "lispbm_memory.h" -#define NUM_SPECIAL_SYMBOLS 79 +#define NUM_SPECIAL_SYMBOLS 80 #define NAME 0 #define ID 1 @@ -45,7 +45,6 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = { {"let" , SYM_LET}, {"define" , SYM_DEFINE}, {"progn" , SYM_PROGN}, - //{"bquote" , SYM_BACKQUOTE}, {"comma" , SYM_COMMA}, {"splice" , SYM_COMMAAT}, {"match" , SYM_MATCH}, @@ -65,6 +64,7 @@ special_sym const special_symbols[NUM_SPECIAL_SYMBOLS] = { {"eval_error" , SYM_EERROR}, {"out_of_memory" , SYM_MERROR}, {"fatal_error" , SYM_FATAL_ERROR}, + {"out_of_stack" , SYM_STACK_ERROR}, {"division_by_zero" , SYM_DIVZERO}, {"sym_array" , SYM_ARRAY_TYPE}, {"sym_boxed_i" , SYM_BOXED_I_TYPE}, @@ -206,9 +206,9 @@ int symrepr_addsym(char *name, UINT* id) { char *symbol_name_storage = NULL;; if (n % 4 == 0) { - symbol_name_storage = (char *)memory_allocate(n / 4); + symbol_name_storage = (char *)memory_allocate(n/4); } else { - symbol_name_storage = (char *)memory_allocate(n / 4 + 1); + symbol_name_storage = (char *)memory_allocate((n/4) + 1); } if (symbol_name_storage == NULL) { @@ -232,7 +232,6 @@ int symrepr_addsym(char *name, UINT* id) { return 1; } -// Same as above, but assume that the name pointer stays valid int symrepr_addsym_const(char *name, UINT* id) { if (strlen(name) == 0) return 0; // failure if empty symbol