rusefi
/
bldc
mirror of https://github.com/rusefi/bldc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Added Joels changes (better to add his repo as submodule at some point)

This commit is contained in:
Benjamin Vedder 2022-01-17 00:00:38 +01:00
parent 9c484d01e4
commit d94a6d3953
13 changed files with 101 additions and 781 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lispBM/include/eval_cps.h
View File

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

3
lispBM/include/extensions.h
View File

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

3
lispBM/include/print.h
View File

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

4
lispBM/include/stack.h
View File

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

12
lispBM/include/symrepr.h
View File

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

1
lispBM/lispbm.mk
View File

@ -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 \

645
lispBM/src/ec_eval.c
View File

@ -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 <http://www.gnu.org/licenses/>.
*/
#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;
}

83
lispBM/src/eval_cps.c
View File

@ -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,7 +808,7 @@ 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,
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)));
@ -846,7 +843,7 @@ 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,
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;
@ -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,7 +1429,7 @@ 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,
CHECK_STACK(push_u32_4(&ctx->K,
ctx->curr_env,
enc_u(0),
cdr(ctx->curr_exp),
@ -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;

4
lispBM/src/extensions.c
View File

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

12
lispBM/src/lispbm.c
View File

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

40
lispBM/src/print.c
View File

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

46
lispBM/src/stack.c
View File

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

7
lispBM/src/symrepr.c
View File

@ -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},
@ -208,7 +208,7 @@ int symrepr_addsym(char *name, UINT* id) {
if (n % 4 == 0) {
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