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

Merge commit '219f29dd7a2215ce74919a8e5dcc45723ebddbed'

This commit is contained in:
Benjamin Vedder 2022-10-02 23:17:59 +02:00
parent e63e079035 219f29dd7a
commit f71eb07352
5 changed files with 311 additions and 297 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

210
lispBM/lispBM/include/heap.h
View File

@ -317,7 +317,7 @@ char *lbm_dec_str(lbm_value val);
*/
lbm_char_channel_t *lbm_dec_channel(lbm_value val);
/** Decode an lbm_value representing a custom type into a lbm_uint value.
*
*
* \param val Value.
* \return The custom type payload.
*/
@ -542,99 +542,41 @@ static inline lbm_value lbm_enc_u(lbm_uint x) {
return (x << LBM_VAL_SHIFT) | LBM_TYPE_U;
}
static inline lbm_value lbm_enc_i32(int32_t x) {
#ifndef LBM64
lbm_value i = lbm_cons((lbm_uint)x, lbm_enc_sym(SYM_RAW_I_TYPE));
if (lbm_type_of(i) == LBM_TYPE_SYMBOL) return i;
return lbm_set_ptr_type(i, LBM_TYPE_I32);
#else
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_I32;
#endif
}
/** Encode 32 bit integer into an lbm_value.
* \param x Value to encode.
* \return result encoded value.
*/
extern lbm_value lbm_enc_i32(int32_t x);
static inline lbm_value lbm_enc_u32(uint32_t x) {
#ifndef LBM64
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_U32);
#else
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_U32;
#endif
}
/** Encode 32 bit unsigned integer into an lbm_value.
* \param x Value to encode.
* \return result encoded value.
*/
extern lbm_value lbm_enc_u32(uint32_t x);
static inline lbm_value lbm_enc_float(float x) {
#ifndef LBM64
lbm_uint t;
memcpy(&t, &x, sizeof(lbm_float));
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE));
if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f;
return lbm_set_ptr_type(f, LBM_TYPE_FLOAT);
#else
uint32_t t;
memcpy(&t, &x, sizeof(float)); /*TODO: Assumes something about storage here ?*/
return (((lbm_uint)t) << LBM_VAL_SHIFT) | LBM_TYPE_FLOAT;
#endif
}
/** Encode a float into an lbm_value.
* \param x float value to encode.
* \return result encoded value.
*/
extern lbm_value lbm_enc_float(float x);
static inline lbm_value lbm_enc_i64(int64_t x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_I_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_I64);
}
}
return res;
#else
lbm_value u = lbm_cons((uint64_t)x, lbm_enc_sym(SYM_RAW_I_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_I64);
#endif
}
/** Encode a 64 bit integer into an lbm_value.
* \param x 64 bit integer to encode.
* \return result encoded value.
*/
extern lbm_value lbm_enc_i64(int64_t x);
static inline lbm_value lbm_enc_u64(uint64_t x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_U_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_U64);
}
}
return res;
#else
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_U64);
#endif
}
static inline lbm_value lbm_enc_double(double x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_F_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_DOUBLE);
}
}
return res;
#else
lbm_uint t;
memcpy(&t, &x, sizeof(lbm_float));
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE));
if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f;
return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE);
#endif
}
/** Encode a 64 bit unsigned integer into an lbm_value.
* \param x 64 bit unsigned integer to encode.
* \return result encoded value.
*/
extern lbm_value lbm_enc_u64(uint64_t x);
/** Encode a double into an lbm_value.
* \param x double to encode.
* \return result encoded value.
*/
extern lbm_value lbm_enc_double(double x);
static inline lbm_value lbm_enc_char(char x) {
return ((lbm_uint)x << LBM_VAL_SHIFT) | LBM_TYPE_CHAR;
@ -656,34 +598,18 @@ static inline lbm_uint lbm_dec_sym(lbm_value x) {
return x >> LBM_VAL_SHIFT;
}
static inline float lbm_dec_float(lbm_value x) {
#ifndef LBM64
float f_tmp;
lbm_uint tmp = lbm_car(x);
memcpy(&f_tmp, &tmp, sizeof(float));
return f_tmp;
#else
uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT);
float f_tmp;
memcpy(&f_tmp, &tmp, sizeof(float));
return f_tmp;
#endif
}
/** Decode an lbm_value representing a float.
* \param x Value to decode.
* \return decoded float.
*/
extern float lbm_dec_float(lbm_value x);
/** Decode an lbm_value representing a double.
* \param x Value to decode.
* \return decoded float.
*/
extern double lbm_dec_double(lbm_value x);
static inline double lbm_dec_double(lbm_value x) {
#ifndef LBM64
double d;
uint32_t *data = (uint32_t*)lbm_car(x);
if (data == NULL) return 0; // no good way to report error from here currently.
memcpy(&d, data, sizeof(double));
return d;
#else
double f_tmp;
lbm_uint tmp = lbm_car(x);
memcpy(&f_tmp, &tmp, sizeof(double));
return f_tmp;
#endif
}
static inline uint32_t lbm_dec_u32(lbm_value x) {
#ifndef LBM64
@ -693,17 +619,11 @@ static inline uint32_t lbm_dec_u32(lbm_value x) {
#endif
}
static inline uint64_t lbm_dec_u64(lbm_value x) {
#ifndef LBM64
uint64_t u;
uint32_t *data = (uint32_t*)lbm_car(x);
if (data == NULL) return 0;
memcpy(&u, data, 8);
return u;
#else
return (uint64_t)lbm_car(x);
#endif
}
/** Decode an lbm_value representing a 64 bit unsigned integer.
* \param x Value to decode.
* \return decoded uint64_t.
*/
extern uint64_t lbm_dec_u64(lbm_value x);
static inline int32_t lbm_dec_i32(lbm_value x) {
#ifndef LBM64
@ -713,18 +633,11 @@ static inline int32_t lbm_dec_i32(lbm_value x) {
#endif
}
static inline int64_t lbm_dec_i64(lbm_value x) {
#ifndef LBM64
int64_t i;
uint32_t *data = (uint32_t*)lbm_car(x);
if (data == NULL) return 0;
memcpy(&i, data, 8);
return i;
#else
return (int64_t)lbm_car(x);
#endif
}
/** Decode an lbm_value representing a 64 bit integert.
* \param x Value to decode.
* \return decoded int64_t.
*/
extern int64_t lbm_dec_i64(lbm_value x);
static inline lbm_value lbm_set_gc_mark(lbm_value x) {
return x | LBM_GC_MARKED;
@ -746,18 +659,11 @@ static inline bool lbm_is_list(lbm_value x) {
return (lbm_type_of(x) == LBM_TYPE_CONS);
}
static inline bool lbm_is_number(lbm_value x) {
lbm_uint t = lbm_type_of(x);
return ((t == LBM_TYPE_I) ||
(t == LBM_TYPE_U) ||
(t == LBM_TYPE_CHAR) ||
(t == LBM_TYPE_I32) ||
(t == LBM_TYPE_U32) ||
(t == LBM_TYPE_I64) ||
(t == LBM_TYPE_U64) ||
(t == LBM_TYPE_FLOAT) ||
(t == LBM_TYPE_DOUBLE));
}
/** Check if a value represents a number
* \param x Value to check.
* \return true is x represents a number and false otherwise.
*/
extern bool lbm_is_number(lbm_value x);
static inline bool lbm_is_array(lbm_value x) {
return (lbm_type_of(x) == LBM_TYPE_ARRAY &&
@ -811,7 +717,7 @@ static inline bool lbm_is_match_binder(lbm_value exp) {
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I32) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_U32) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_FLOAT) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I64) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_I64) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_U64) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_DOUBLE) ||
(lbm_dec_sym(lbm_car(exp)) == SYM_MATCH_CONS)));

14
lispBM/lispBM/include/lbm_defines.h
View File

@ -28,12 +28,12 @@
#define LBM_POINTER_TYPE_FIRST 0x10000000u
#define LBM_TYPE_CONS 0x10000000u
#define LBM_NON_CONS_POINTER_TYPE_FIRST 0x20000000u
#define LBM_TYPE_U32 0x20000000u
#define LBM_TYPE_I32 0x30000000u
#define LBM_TYPE_I64 0x40000000u
#define LBM_TYPE_U64 0x50000000u
#define LBM_TYPE_FLOAT 0x60000000u
#define LBM_TYPE_DOUBLE 0x70000000u
#define LBM_TYPE_U32 0x28000000u
#define LBM_TYPE_I32 0x38000000u
#define LBM_TYPE_I64 0x48000000u
#define LBM_TYPE_U64 0x58000000u
#define LBM_TYPE_FLOAT 0x68000000u
#define LBM_TYPE_DOUBLE 0x78000000u
#define LBM_TYPE_ARRAY 0x80000000u
#define LBM_TYPE_REF 0x90000000u
#define LBM_TYPE_CHANNEL 0xA0000000u
@ -94,7 +94,6 @@
#define SYM_NIL 0x0
#define SYM_TRUE 0x2
#define SYM_DONTCARE 0x9
#define SYM_MACRO_EXPAND 0xD
// Consecutive value symbols for lookup-application
#define APPLY_FUNS_START 0x10
@ -307,7 +306,6 @@
#define ENC_SYM_CONT ((SYM_CONT << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
#define ENC_SYM_CLOSURE ((SYM_CLOSURE << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
#define ENC_SYM_MACRO ((SYM_MACRO << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
#define ENC_SYM_MACRO_EXPAND ((SYM_MACRO_EXPAND << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
#define ENC_SYM_SETVAR ((SYM_SETVAR << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
#define ENC_SYM_EXIT_OK ((SYM_EXIT_OK << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
#define ENC_SYM_EXIT_ERROR ((SYM_EXIT_ERROR << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)

170
lispBM/lispBM/src/eval_cps.c
View File

@ -36,38 +36,37 @@
#include "heap_vis.h"
#endif
#define DONE ((0 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define SET_GLOBAL_ENV ((1 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define BIND_TO_KEY_REST ((2 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define IF ((3 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define PROGN_REST ((4 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define APPLICATION ((5 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define APPLICATION_ARGS ((6 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define AND ((7 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define OR ((8 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define WAIT ((9 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define MATCH ((10 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define MATCH_MANY ((11 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ ((12 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define APPLICATION_START ((13 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define EVAL_R ((14 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define SET_VARIABLE ((15 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define RESUME ((16 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define EXPAND_MACRO ((17 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define CLOSURE_ARGS ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define EXIT_ATOMIC ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_NEXT_TOKEN ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_APPEND_CONTINUE ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_EXPECT_CLOSEPAR ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_DOT_TERMINATE ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_DONE ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_QUOTE_RESULT ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_BACKQUOTE_RESULT ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_COMMAAT_RESULT ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_COMMA_RESULT ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_START_ARRAY ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_APPEND_ARRAY ((30 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define NUM_CONTINUATIONS 31
#define DONE ((0 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define SET_GLOBAL_ENV ((1 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define BIND_TO_KEY_REST ((2 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define IF ((3 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define PROGN_REST ((4 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define APPLICATION ((5 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define APPLICATION_ARGS ((6 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define AND ((7 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define OR ((8 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define WAIT ((9 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define MATCH ((10 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define MATCH_MANY ((11 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ ((12 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define APPLICATION_START ((13 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define EVAL_R ((14 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define SET_VARIABLE ((15 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define RESUME ((16 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define CLOSURE_ARGS ((17 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define EXIT_ATOMIC ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_NEXT_TOKEN ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_APPEND_CONTINUE ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_EXPECT_CLOSEPAR ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_DOT_TERMINATE ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_DONE ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_QUOTE_RESULT ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_BACKQUOTE_RESULT ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_COMMAAT_RESULT ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_COMMA_RESULT ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_START_ARRAY ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READ_APPEND_ARRAY ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define NUM_CONTINUATIONS 30
static const char* parse_error_eof = "End of parse stream";
static const char* parse_error_token = "Malformed token";
@ -101,7 +100,7 @@ static int gc(void);
static void error_ctx(lbm_value);
static eval_context_t *ctx_running = NULL;
static inline lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
lbm_value res = lbm_cons(head, tail);
if (lbm_is_symbol_merror(res)) {
lbm_gc_mark_phase(remember);
@ -1160,7 +1159,7 @@ int lbm_perform_gc(void) {
/****************************************************/
/* Evaluation functions */
static inline bool eval_symbol(eval_context_t *ctx, lbm_value *value) {
static bool eval_symbol(eval_context_t *ctx, lbm_value *value) {
lbm_uint s = lbm_dec_sym(ctx->curr_exp);
if (s < SPECIAL_SYMBOLS_END ||
@ -1183,7 +1182,7 @@ static inline bool eval_symbol(eval_context_t *ctx, lbm_value *value) {
}
}
static inline void dynamic_load(eval_context_t *ctx) {
static void dynamic_load(eval_context_t *ctx) {
const char *sym_str = lbm_get_name_by_symbol(lbm_dec_sym(ctx->curr_exp));
const char *code_str = NULL;
@ -1213,18 +1212,18 @@ static inline void dynamic_load(eval_context_t *ctx) {
}
static inline void eval_quote(eval_context_t *ctx) {
static void eval_quote(eval_context_t *ctx) {
ctx->r = lbm_cadr(ctx->curr_exp);
ctx->app_cont = true;
}
static inline void eval_selfevaluating(eval_context_t *ctx) {
static void eval_selfevaluating(eval_context_t *ctx) {
ctx->r = ctx->curr_exp;
ctx->app_cont = true;
}
static inline void eval_atomic(eval_context_t *ctx) {
static void eval_atomic(eval_context_t *ctx) {
if (is_atomic) {
lbm_set_error_reason("Atomic blocks cannot be nested!");
error_ctx(ENC_SYM_EERROR);
@ -1238,7 +1237,7 @@ static inline void eval_atomic(eval_context_t *ctx) {
}
static inline void eval_callcc(eval_context_t *ctx) {
static void eval_callcc(eval_context_t *ctx) {
lbm_value cont_array;
#ifndef LBM64
@ -1275,7 +1274,7 @@ static inline void eval_callcc(eval_context_t *ctx) {
ctx->app_cont = false;
}
static inline void eval_define(eval_context_t *ctx) {
static void eval_define(eval_context_t *ctx) {
lbm_value args = lbm_cdr(ctx->curr_exp);
lbm_value key = lbm_car(args);
lbm_value rest_args = lbm_cdr(args);
@ -1307,7 +1306,7 @@ static inline void eval_define(eval_context_t *ctx) {
return;
}
static inline void eval_progn(eval_context_t *ctx) {
static void eval_progn(eval_context_t *ctx) {
lbm_value exps = lbm_cdr(ctx->curr_exp);
lbm_value env = ctx->curr_env;
@ -1332,21 +1331,21 @@ static inline void eval_progn(eval_context_t *ctx) {
}
}
static inline lbm_value mk_closure(lbm_value env, lbm_value body, lbm_value params) {
static lbm_value mk_closure(lbm_value env, lbm_value body, lbm_value params) {
lbm_value env_end = cons_with_gc( env, ENC_SYM_NIL, env);
lbm_value exp = cons_with_gc(body, env_end, env_end);
lbm_value par = cons_with_gc(params, exp, exp);
return cons_with_gc(ENC_SYM_CLOSURE, par, par);
}
static inline void eval_lambda(eval_context_t *ctx) {
static void eval_lambda(eval_context_t *ctx) {
lbm_value closure = mk_closure(ctx->curr_env, lbm_cadr(lbm_cdr(ctx->curr_exp)), lbm_cadr(ctx->curr_exp));
ctx->app_cont = true;
ctx->r = closure;
return;
}
static inline void eval_if(eval_context_t *ctx) {
static void eval_if(eval_context_t *ctx) {
lbm_value cddr = lbm_cdr(lbm_cdr(ctx->curr_exp));
lbm_value then_branch = lbm_car(cddr);
@ -1364,7 +1363,7 @@ static inline void eval_if(eval_context_t *ctx) {
ctx->curr_exp = lbm_cadr(ctx->curr_exp);
}
static inline void eval_let(eval_context_t *ctx) {
static void eval_let(eval_context_t *ctx) {
lbm_value orig_env = ctx->curr_env;
lbm_value binds = lbm_cadr(ctx->curr_exp); // key value pairs.
lbm_value exp = lbm_cadr(lbm_cdr(ctx->curr_exp)); // exp to evaluate in the new env.
@ -1408,7 +1407,7 @@ static inline void eval_let(eval_context_t *ctx) {
return;
}
static inline void eval_and(eval_context_t *ctx) {
static void eval_and(eval_context_t *ctx) {
lbm_value rest = lbm_cdr(ctx->curr_exp);
if (lbm_is_symbol_nil(rest)) {
ctx->app_cont = true;
@ -1419,7 +1418,7 @@ static inline void eval_and(eval_context_t *ctx) {
}
}
static inline void eval_or(eval_context_t *ctx) {
static void eval_or(eval_context_t *ctx) {
lbm_value rest = lbm_cdr(ctx->curr_exp);
if (lbm_is_symbol_nil(rest)) {
ctx->app_cont = true;
@ -1435,7 +1434,7 @@ static inline void eval_or(eval_context_t *ctx) {
/* (match e (pattern body) */
/* (pattern body) */
/* ... ) */
static inline void eval_match(eval_context_t *ctx) {
static void eval_match(eval_context_t *ctx) {
lbm_value rest = lbm_cdr(ctx->curr_exp);
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
@ -1450,7 +1449,7 @@ static inline void eval_match(eval_context_t *ctx) {
}
}
static inline void eval_receive(eval_context_t *ctx) {
static void eval_receive(eval_context_t *ctx) {
if (is_atomic) {
lbm_set_error_reason("Cannot receive inside of an atomic block");
@ -1541,44 +1540,6 @@ static void cont_resume(eval_context_t *ctx) {
ctx->curr_exp = exp;
}
static void cont_expand_macro(eval_context_t *ctx) {
lbm_uint* sptr = lbm_get_stack_ptr(&ctx->K, 2);
if (!sptr) {
error_ctx(ENC_SYM_FATAL_ERROR);
return;
}
lbm_value env = (lbm_value)sptr[0];
lbm_value args = (lbm_value)sptr[1];
if (lbm_is_macro(ctx->r)) {
lbm_value m = ctx->r;
lbm_value curr_param = lbm_cadr(m);
lbm_value curr_arg = args;
lbm_value expand_env = env;
while (lbm_type_of(curr_param) == LBM_TYPE_CONS &&
lbm_type_of(curr_arg) == LBM_TYPE_CONS) {
lbm_value entry;
WITH_GC(entry,lbm_cons(lbm_car(curr_param),lbm_car(curr_arg)), expand_env,ENC_SYM_NIL);
lbm_value aug_env;
WITH_GC(aug_env,lbm_cons(entry, expand_env),expand_env,entry);
expand_env = aug_env;
curr_param = lbm_cdr(curr_param);
curr_arg = lbm_cdr(curr_arg);
}
lbm_stack_drop(&ctx->K, 2);
ctx->curr_exp = lbm_cadr(lbm_cdr(m));
ctx->curr_env = expand_env;
ctx->app_cont = false;
return;
}
error_ctx(ENC_SYM_EERROR);
}
static void cont_progn_rest(eval_context_t *ctx) {
lbm_value rest;
lbm_value env;
@ -1637,7 +1598,7 @@ static void cont_wait(eval_context_t *ctx) {
}
}
static inline void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
if (nargs == 2 && lbm_is_symbol(args[1])) {
lbm_uint s = lbm_dec_sym(args[1]);
if (s >= VARIABLE_SYMBOLS_START &&
@ -1678,7 +1639,7 @@ static inline void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t
ctx->app_cont = true;
}
static inline void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
if (nargs == 1) {
lbm_value chan = ENC_SYM_NIL;
if (lbm_type_of(args[1]) == LBM_TYPE_ARRAY) {
@ -1766,7 +1727,7 @@ static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ct
apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP);
}
static inline void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
if (is_atomic) {
lbm_set_error_reason("Cannot yield inside of an atomic block");
error_ctx(ENC_SYM_EERROR);
@ -1781,7 +1742,7 @@ static inline void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *
}
}
static inline void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
if (lbm_type_of(args[1]) == LBM_TYPE_I) {
lbm_cid cid = (lbm_cid)lbm_dec_i(args[1]);
lbm_stack_drop(&ctx->K, nargs+1);
@ -1794,12 +1755,12 @@ static inline void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *c
}
}
static inline void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
ctx->curr_exp = args[1];
lbm_stack_drop(&ctx->K, nargs+1);
}
static inline void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
lbm_value prg = args[1];
prg = lbm_list_append(prg, ctx->program);
@ -1815,7 +1776,7 @@ static inline void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_cont
ctx->curr_exp = lbm_car(prg);
}
static inline void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
lbm_value status = ENC_SYM_EERROR;
if (nargs == 2) {
@ -1832,7 +1793,7 @@ static inline void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *c
ctx->app_cont = true;
}
static inline void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
lbm_value ok_val = ENC_SYM_TRUE;
if (nargs >= 1) {
ok_val = args[1];
@ -1841,7 +1802,7 @@ static inline void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx
ok_ctx();
}
static inline void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
(void) ctx;
lbm_value err_val = ENC_SYM_EERROR;
if (nargs >= 1) {
@ -1850,7 +1811,7 @@ static inline void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *
error_ctx(err_val);
}
static inline void apply_extension(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
static void apply_extension(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
extension_fptr f = lbm_get_extension(lbm_dec_sym(args[0]));
if (f == NULL) {
error_ctx(ENC_SYM_EERROR);
@ -1968,6 +1929,8 @@ static void cont_application(eval_context_t *ctx) {
}
}
// Caveat: Application of a closure to 0 arguments if
// the same as applying it to NIL.
static void cont_closure_application_args(eval_context_t *ctx) {
lbm_uint* sptr = lbm_get_stack_ptr(&ctx->K, 5);
@ -2695,13 +2658,6 @@ static void cont_application_start(eval_context_t *ctx) {
if (lbm_type_of(ctx->r) == LBM_TYPE_CONS) {
switch (lbm_car(ctx->r)) {
case ENC_SYM_MACRO_EXPAND:
/* (macro-expand (args + (list 1 2 3))) */
sptr[1] = lbm_cdr(args);
CHECK_STACK(lbm_push(&ctx->K,
EXPAND_MACRO));
ctx->curr_exp = lbm_car(lbm_car(args));
break;
case ENC_SYM_MACRO:{
/*
* Perform macro expansion.
@ -2732,9 +2688,6 @@ static void cont_application_start(eval_context_t *ctx) {
* Second to evaluate the resulting program.
*/
sptr[1] = EVAL_R;
/* CHECK_STACK(lbm_push_u32_2(&ctx->K, */
/* env, */
/* EVAL_R)); */
lbm_value exp = lbm_cadr(lbm_cdr(ctx->r));
ctx->curr_exp = exp;
ctx->curr_env = expand_env;
@ -2777,7 +2730,7 @@ static void cont_application_start(eval_context_t *ctx) {
}
}
static inline void cont_eval_r(eval_context_t* ctx) {
static void cont_eval_r(eval_context_t* ctx) {
lbm_value env;
lbm_pop(&ctx->K, &env);
@ -2808,7 +2761,6 @@ static const cont_fun continuations[NUM_CONTINUATIONS] =
cont_eval_r,
cont_set_var,
cont_resume,
cont_expand_macro,
cont_closure_application_args,
cont_exit_atomic,
cont_read_next_token,

213
lispBM/lispBM/src/heap.c
View File

@ -33,6 +33,156 @@
lbm_heap_state_t lbm_heap_state;
/****************************************************/
/* ENCODERS DECODERS */
lbm_value lbm_enc_i32(int32_t x) {
#ifndef LBM64
lbm_value i = lbm_cons((lbm_uint)x, lbm_enc_sym(SYM_RAW_I_TYPE));
if (lbm_type_of(i) == LBM_TYPE_SYMBOL) return i;
return lbm_set_ptr_type(i, LBM_TYPE_I32);
#else
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_I32;
#endif
}
lbm_value lbm_enc_u32(uint32_t x) {
#ifndef LBM64
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_U32);
#else
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_U32;
#endif
}
lbm_value lbm_enc_float(float x) {
#ifndef LBM64
lbm_uint t;
memcpy(&t, &x, sizeof(lbm_float));
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE));
if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f;
return lbm_set_ptr_type(f, LBM_TYPE_FLOAT);
#else
uint32_t t;
memcpy(&t, &x, sizeof(float)); /*TODO: Assumes something about storage here ?*/
return (((lbm_uint)t) << LBM_VAL_SHIFT) | LBM_TYPE_FLOAT;
#endif
}
lbm_value lbm_enc_i64(int64_t x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_I_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_I64);
}
}
return res;
#else
lbm_value u = lbm_cons((uint64_t)x, lbm_enc_sym(SYM_RAW_I_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_I64);
#endif
}
lbm_value lbm_enc_u64(uint64_t x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_U_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_U64);
}
}
return res;
#else
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE));
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
return lbm_set_ptr_type(u, LBM_TYPE_U64);
#endif
}
lbm_value lbm_enc_double(double x) {
#ifndef LBM64
lbm_value res = lbm_enc_sym(SYM_MERROR);
lbm_uint* storage = lbm_memory_allocate(2);
if (storage) {
res = lbm_cons((lbm_uint)storage, lbm_enc_sym(SYM_IND_F_TYPE));
if (lbm_type_of(res) != LBM_TYPE_SYMBOL) {
memcpy(storage,&x, 8);
res = lbm_set_ptr_type(res, LBM_TYPE_DOUBLE);
}
}
return res;
#else
lbm_uint t;
memcpy(&t, &x, sizeof(lbm_float));
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE));
if (lbm_type_of(f) == LBM_TYPE_SYMBOL) return f;
return lbm_set_ptr_type(f, LBM_TYPE_DOUBLE);
#endif
}
float lbm_dec_float(lbm_value x) {
#ifndef LBM64
float f_tmp;
lbm_uint tmp = lbm_car(x);
memcpy(&f_tmp, &tmp, sizeof(float));
return f_tmp;
#else
uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT);
float f_tmp;
memcpy(&f_tmp, &tmp, sizeof(float));
return f_tmp;
#endif
}
double lbm_dec_double(lbm_value x) {
#ifndef LBM64
double d;
uint32_t *data = (uint32_t*)lbm_car(x);
if (data == NULL) return 0; // no good way to report error from here currently.
memcpy(&d, data, sizeof(double));
return d;
#else
double f_tmp;
lbm_uint tmp = lbm_car(x);
memcpy(&f_tmp, &tmp, sizeof(double));
return f_tmp;
#endif
}
uint64_t lbm_dec_u64(lbm_value x) {
#ifndef LBM64
uint64_t u;
uint32_t *data = (uint32_t*)lbm_car(x);
if (data == NULL) return 0;
memcpy(&u, data, 8);
return u;
#else
return (uint64_t)lbm_car(x);
#endif
}
int64_t lbm_dec_i64(lbm_value x) {
#ifndef LBM64
int64_t i;
uint32_t *data = (uint32_t*)lbm_car(x);
if (data == NULL) return 0;
memcpy(&i, data, 8);
return i;
#else
return (int64_t)lbm_car(x);
#endif
}
char *lbm_dec_str(lbm_value val) {
char *res = 0;
if (lbm_type_of(val) == LBM_TYPE_ARRAY) {
@ -230,35 +380,44 @@ double lbm_dec_as_double(lbm_value a) {
}
return 0;
}
/****************************************************/
/* IS */
static inline lbm_value read_car(lbm_cons_t *cell) {
return cell->car;
bool lbm_is_number(lbm_value x) {
lbm_uint t = lbm_type_of(x);
#ifndef LBM64
return (t & 0xC || t & 0x08000000);
#else
return ((t == LBM_TYPE_I) ||
(t == LBM_TYPE_U) ||
(t == LBM_TYPE_CHAR) ||
(t == LBM_TYPE_I32) ||
(t == LBM_TYPE_U32) ||
(t == LBM_TYPE_I64) ||
(t == LBM_TYPE_U64) ||
(t == LBM_TYPE_FLOAT) ||
(t == LBM_TYPE_DOUBLE));
#endif
}
static inline lbm_value read_cdr(lbm_cons_t *cell) {
return cell->cdr;
}
static inline void set_car_(lbm_cons_t *cell, lbm_value v) {
cell->car = v;
}
static inline void set_cdr_(lbm_cons_t *cell, lbm_value v) {
cell->cdr = v;
}
/****************************************************/
/* HEAP MANAGEMENT */
static inline void set_gc_mark(lbm_cons_t *cell) {
lbm_value cdr = read_cdr(cell);
set_cdr_(cell, lbm_set_gc_mark(cdr));
lbm_value cdr = cell->cdr;
cell->cdr = lbm_set_gc_mark(cdr);
}
static inline void clr_gc_mark(lbm_cons_t *cell) {
lbm_value cdr = read_cdr(cell);
set_cdr_(cell, lbm_clr_gc_mark(cdr));
lbm_value cdr = cell->cdr;
cell->cdr = lbm_clr_gc_mark(cdr);
}
static inline bool get_gc_mark(lbm_cons_t* cell) {
lbm_value cdr = read_cdr(cell);
lbm_value cdr = cell->cdr;
return lbm_get_gc_mark(cdr);
}
@ -274,13 +433,13 @@ static int generate_freelist(size_t num_cells) {
// Add all cells to free list
for (i = 1; i < num_cells; i ++) {
t = lbm_ref_cell(lbm_enc_cons_ptr(i-1));
set_car_(t, ENC_SYM_RECOVERED); // all cars in free list are "RECOVERED"
set_cdr_(t, lbm_enc_cons_ptr(i));
t->car = ENC_SYM_RECOVERED; // all cars in free list are "RECOVERED"
t->cdr = lbm_enc_cons_ptr(i);
}
// Replace the incorrect pointer at the last cell.
t = lbm_ref_cell(lbm_enc_cons_ptr(num_cells-1));
set_cdr_(t, ENC_SYM_NIL);
t->cdr = ENC_SYM_NIL;
return 1;
}
@ -367,8 +526,8 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) {
lbm_heap_state.num_alloc++;
// set some ok initial values (nil . nil)
set_car_(lbm_ref_cell(res), ENC_SYM_NIL);
set_cdr_(lbm_ref_cell(res), ENC_SYM_NIL);
lbm_ref_cell(res)->car = ENC_SYM_NIL;
lbm_ref_cell(res)->cdr = ENC_SYM_NIL;
// clear GC bit on allocated cell
clr_gc_mark(lbm_ref_cell(res));
@ -552,8 +711,8 @@ void lbm_gc_state_inc(void) {
lbm_value lbm_cons(lbm_value car, lbm_value cdr) {
lbm_value addr = lbm_heap_allocate_cell(LBM_TYPE_CONS);
if ( lbm_is_ptr(addr)) {
set_car_(lbm_ref_cell(addr), car);
set_cdr_(lbm_ref_cell(addr), cdr);
lbm_ref_cell(addr)->car = car;
lbm_ref_cell(addr)->cdr = cdr;
}
// heap_allocate_cell returns MERROR if out of heap.
@ -569,7 +728,7 @@ lbm_value lbm_car(lbm_value c){
if (lbm_is_ptr(c) ){
lbm_cons_t *cell = lbm_ref_cell(c);
return read_car(cell);
return cell->car;
}
return ENC_SYM_TERROR;
}
@ -601,7 +760,7 @@ lbm_value lbm_cdr(lbm_value c){
if (lbm_is_ptr(c)) {
lbm_cons_t *cell = lbm_ref_cell(c);
return read_cdr(cell);
return cell->cdr;
}
return ENC_SYM_TERROR;
}
@ -610,7 +769,7 @@ int lbm_set_car(lbm_value c, lbm_value v) {
int r = 0;
if (lbm_type_of(c) == LBM_TYPE_CONS) {
lbm_cons_t *cell = lbm_ref_cell(c);
set_car_(cell,v);
cell->car = v;
r = 1;
}
return r;
@ -620,7 +779,7 @@ int lbm_set_cdr(lbm_value c, lbm_value v) {
int r = 0;
if (lbm_type_of(c) == LBM_TYPE_CONS){
lbm_cons_t *cell = lbm_ref_cell(c);
set_cdr_(cell,v);
cell->cdr = v;
r = 1;
}
return r;

1
lispBM/lispBM/src/symrepr.c
View File

@ -53,7 +53,6 @@ special_sym const special_symbols[] = {
{"send" , SYM_SEND},
{"recv" , SYM_RECEIVE},
{"macro" , SYM_MACRO},
{"macro-expand" , SYM_MACRO_EXPAND},
{"call-cc" , SYM_CALLCC},
{"continuation" , SYM_CONT},