mirror of https://github.com/rusefi/bldc.git
Merge commit '219f29dd7a2215ce74919a8e5dcc45723ebddbed'
This commit is contained in:
commit
f71eb07352
|
@ -542,99 +542,41 @@ static inline lbm_value lbm_enc_u(lbm_uint x) {
|
||||||
return (x << LBM_VAL_SHIFT) | LBM_TYPE_U;
|
return (x << LBM_VAL_SHIFT) | LBM_TYPE_U;
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline lbm_value lbm_enc_i32(int32_t x) {
|
/** Encode 32 bit integer into an lbm_value.
|
||||||
#ifndef LBM64
|
* \param x Value to encode.
|
||||||
lbm_value i = lbm_cons((lbm_uint)x, lbm_enc_sym(SYM_RAW_I_TYPE));
|
* \return result encoded value.
|
||||||
if (lbm_type_of(i) == LBM_TYPE_SYMBOL) return i;
|
*/
|
||||||
return lbm_set_ptr_type(i, LBM_TYPE_I32);
|
extern lbm_value lbm_enc_i32(int32_t x);
|
||||||
#else
|
|
||||||
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_I32;
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline lbm_value lbm_enc_u32(uint32_t x) {
|
/** Encode 32 bit unsigned integer into an lbm_value.
|
||||||
#ifndef LBM64
|
* \param x Value to encode.
|
||||||
lbm_value u = lbm_cons(x, lbm_enc_sym(SYM_RAW_U_TYPE));
|
* \return result encoded value.
|
||||||
if (lbm_type_of(u) == LBM_TYPE_SYMBOL) return u;
|
*/
|
||||||
return lbm_set_ptr_type(u, LBM_TYPE_U32);
|
extern lbm_value lbm_enc_u32(uint32_t x);
|
||||||
#else
|
|
||||||
return (((lbm_uint)x) << LBM_VAL_SHIFT) | LBM_TYPE_U32;
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline lbm_value lbm_enc_float(float x) {
|
/** Encode a float into an lbm_value.
|
||||||
#ifndef LBM64
|
* \param x float value to encode.
|
||||||
lbm_uint t;
|
* \return result encoded value.
|
||||||
memcpy(&t, &x, sizeof(lbm_float));
|
*/
|
||||||
lbm_value f = lbm_cons(t, lbm_enc_sym(SYM_RAW_F_TYPE));
|
extern lbm_value lbm_enc_float(float x);
|
||||||
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
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline lbm_value lbm_enc_i64(int64_t x) {
|
/** Encode a 64 bit integer into an lbm_value.
|
||||||
#ifndef LBM64
|
* \param x 64 bit integer to encode.
|
||||||
lbm_value res = lbm_enc_sym(SYM_MERROR);
|
* \return result encoded value.
|
||||||
lbm_uint* storage = lbm_memory_allocate(2);
|
*/
|
||||||
if (storage) {
|
extern lbm_value lbm_enc_i64(int64_t x);
|
||||||
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
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline lbm_value lbm_enc_u64(uint64_t x) {
|
/** Encode a 64 bit unsigned integer into an lbm_value.
|
||||||
#ifndef LBM64
|
* \param x 64 bit unsigned integer to encode.
|
||||||
lbm_value res = lbm_enc_sym(SYM_MERROR);
|
* \return result encoded value.
|
||||||
lbm_uint* storage = lbm_memory_allocate(2);
|
*/
|
||||||
if (storage) {
|
extern lbm_value lbm_enc_u64(uint64_t x);
|
||||||
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 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) {
|
static inline lbm_value lbm_enc_char(char x) {
|
||||||
return ((lbm_uint)x << LBM_VAL_SHIFT) | LBM_TYPE_CHAR;
|
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;
|
return x >> LBM_VAL_SHIFT;
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline float lbm_dec_float(lbm_value x) {
|
/** Decode an lbm_value representing a float.
|
||||||
#ifndef LBM64
|
* \param x Value to decode.
|
||||||
float f_tmp;
|
* \return decoded float.
|
||||||
lbm_uint tmp = lbm_car(x);
|
*/
|
||||||
memcpy(&f_tmp, &tmp, sizeof(float));
|
extern float lbm_dec_float(lbm_value x);
|
||||||
return f_tmp;
|
|
||||||
#else
|
/** Decode an lbm_value representing a double.
|
||||||
uint32_t tmp = (uint32_t)(x >> LBM_VAL_SHIFT);
|
* \param x Value to decode.
|
||||||
float f_tmp;
|
* \return decoded float.
|
||||||
memcpy(&f_tmp, &tmp, sizeof(float));
|
*/
|
||||||
return f_tmp;
|
extern double lbm_dec_double(lbm_value x);
|
||||||
#endif
|
|
||||||
}
|
|
||||||
|
|
||||||
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) {
|
static inline uint32_t lbm_dec_u32(lbm_value x) {
|
||||||
#ifndef LBM64
|
#ifndef LBM64
|
||||||
|
@ -693,17 +619,11 @@ static inline uint32_t lbm_dec_u32(lbm_value x) {
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline uint64_t lbm_dec_u64(lbm_value x) {
|
/** Decode an lbm_value representing a 64 bit unsigned integer.
|
||||||
#ifndef LBM64
|
* \param x Value to decode.
|
||||||
uint64_t u;
|
* \return decoded uint64_t.
|
||||||
uint32_t *data = (uint32_t*)lbm_car(x);
|
*/
|
||||||
if (data == NULL) return 0;
|
extern uint64_t lbm_dec_u64(lbm_value x);
|
||||||
memcpy(&u, data, 8);
|
|
||||||
return u;
|
|
||||||
#else
|
|
||||||
return (uint64_t)lbm_car(x);
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline int32_t lbm_dec_i32(lbm_value x) {
|
static inline int32_t lbm_dec_i32(lbm_value x) {
|
||||||
#ifndef LBM64
|
#ifndef LBM64
|
||||||
|
@ -713,18 +633,11 @@ static inline int32_t lbm_dec_i32(lbm_value x) {
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline int64_t lbm_dec_i64(lbm_value x) {
|
/** Decode an lbm_value representing a 64 bit integert.
|
||||||
#ifndef LBM64
|
* \param x Value to decode.
|
||||||
int64_t i;
|
* \return decoded int64_t.
|
||||||
uint32_t *data = (uint32_t*)lbm_car(x);
|
*/
|
||||||
if (data == NULL) return 0;
|
extern int64_t lbm_dec_i64(lbm_value x);
|
||||||
memcpy(&i, data, 8);
|
|
||||||
return i;
|
|
||||||
#else
|
|
||||||
return (int64_t)lbm_car(x);
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
static inline lbm_value lbm_set_gc_mark(lbm_value x) {
|
static inline lbm_value lbm_set_gc_mark(lbm_value x) {
|
||||||
return x | LBM_GC_MARKED;
|
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);
|
return (lbm_type_of(x) == LBM_TYPE_CONS);
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline bool lbm_is_number(lbm_value x) {
|
/** Check if a value represents a number
|
||||||
lbm_uint t = lbm_type_of(x);
|
* \param x Value to check.
|
||||||
return ((t == LBM_TYPE_I) ||
|
* \return true is x represents a number and false otherwise.
|
||||||
(t == LBM_TYPE_U) ||
|
*/
|
||||||
(t == LBM_TYPE_CHAR) ||
|
extern bool lbm_is_number(lbm_value x);
|
||||||
(t == LBM_TYPE_I32) ||
|
|
||||||
(t == LBM_TYPE_U32) ||
|
|
||||||
(t == LBM_TYPE_I64) ||
|
|
||||||
(t == LBM_TYPE_U64) ||
|
|
||||||
(t == LBM_TYPE_FLOAT) ||
|
|
||||||
(t == LBM_TYPE_DOUBLE));
|
|
||||||
}
|
|
||||||
|
|
||||||
static inline bool lbm_is_array(lbm_value x) {
|
static inline bool lbm_is_array(lbm_value x) {
|
||||||
return (lbm_type_of(x) == LBM_TYPE_ARRAY &&
|
return (lbm_type_of(x) == LBM_TYPE_ARRAY &&
|
||||||
|
|
|
@ -28,12 +28,12 @@
|
||||||
#define LBM_POINTER_TYPE_FIRST 0x10000000u
|
#define LBM_POINTER_TYPE_FIRST 0x10000000u
|
||||||
#define LBM_TYPE_CONS 0x10000000u
|
#define LBM_TYPE_CONS 0x10000000u
|
||||||
#define LBM_NON_CONS_POINTER_TYPE_FIRST 0x20000000u
|
#define LBM_NON_CONS_POINTER_TYPE_FIRST 0x20000000u
|
||||||
#define LBM_TYPE_U32 0x20000000u
|
#define LBM_TYPE_U32 0x28000000u
|
||||||
#define LBM_TYPE_I32 0x30000000u
|
#define LBM_TYPE_I32 0x38000000u
|
||||||
#define LBM_TYPE_I64 0x40000000u
|
#define LBM_TYPE_I64 0x48000000u
|
||||||
#define LBM_TYPE_U64 0x50000000u
|
#define LBM_TYPE_U64 0x58000000u
|
||||||
#define LBM_TYPE_FLOAT 0x60000000u
|
#define LBM_TYPE_FLOAT 0x68000000u
|
||||||
#define LBM_TYPE_DOUBLE 0x70000000u
|
#define LBM_TYPE_DOUBLE 0x78000000u
|
||||||
#define LBM_TYPE_ARRAY 0x80000000u
|
#define LBM_TYPE_ARRAY 0x80000000u
|
||||||
#define LBM_TYPE_REF 0x90000000u
|
#define LBM_TYPE_REF 0x90000000u
|
||||||
#define LBM_TYPE_CHANNEL 0xA0000000u
|
#define LBM_TYPE_CHANNEL 0xA0000000u
|
||||||
|
@ -94,7 +94,6 @@
|
||||||
#define SYM_NIL 0x0
|
#define SYM_NIL 0x0
|
||||||
#define SYM_TRUE 0x2
|
#define SYM_TRUE 0x2
|
||||||
#define SYM_DONTCARE 0x9
|
#define SYM_DONTCARE 0x9
|
||||||
#define SYM_MACRO_EXPAND 0xD
|
|
||||||
|
|
||||||
// Consecutive value symbols for lookup-application
|
// Consecutive value symbols for lookup-application
|
||||||
#define APPLY_FUNS_START 0x10
|
#define APPLY_FUNS_START 0x10
|
||||||
|
@ -307,7 +306,6 @@
|
||||||
#define ENC_SYM_CONT ((SYM_CONT << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
|
#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_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 ((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_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_OK ((SYM_EXIT_OK << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
|
||||||
#define ENC_SYM_EXIT_ERROR ((SYM_EXIT_ERROR << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
|
#define ENC_SYM_EXIT_ERROR ((SYM_EXIT_ERROR << LBM_VAL_SHIFT) | LBM_TYPE_SYMBOL)
|
||||||
|
|
|
@ -53,21 +53,20 @@
|
||||||
#define EVAL_R ((14 << 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 SET_VARIABLE ((15 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define RESUME ((16 << 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 ((17 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define CLOSURE_ARGS ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define EXIT_ATOMIC ((18 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define EXIT_ATOMIC ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_NEXT_TOKEN ((19 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_NEXT_TOKEN ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_APPEND_CONTINUE ((20 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_APPEND_CONTINUE ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_EXPECT_CLOSEPAR ((21 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_EXPECT_CLOSEPAR ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_DOT_TERMINATE ((22 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_DOT_TERMINATE ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_DONE ((23 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_DONE ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_QUOTE_RESULT ((24 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_QUOTE_RESULT ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_BACKQUOTE_RESULT ((25 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_BACKQUOTE_RESULT ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_COMMAAT_RESULT ((26 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_COMMAAT_RESULT ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_COMMA_RESULT ((27 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_COMMA_RESULT ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_START_ARRAY ((28 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_START_ARRAY ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define READ_APPEND_ARRAY ((29 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
||||||
#define READ_APPEND_ARRAY ((30 << LBM_VAL_SHIFT) | LBM_TYPE_U)
|
#define NUM_CONTINUATIONS 30
|
||||||
#define NUM_CONTINUATIONS 31
|
|
||||||
|
|
||||||
static const char* parse_error_eof = "End of parse stream";
|
static const char* parse_error_eof = "End of parse stream";
|
||||||
static const char* parse_error_token = "Malformed token";
|
static const char* parse_error_token = "Malformed token";
|
||||||
|
@ -101,7 +100,7 @@ static int gc(void);
|
||||||
static void error_ctx(lbm_value);
|
static void error_ctx(lbm_value);
|
||||||
static eval_context_t *ctx_running = NULL;
|
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);
|
lbm_value res = lbm_cons(head, tail);
|
||||||
if (lbm_is_symbol_merror(res)) {
|
if (lbm_is_symbol_merror(res)) {
|
||||||
lbm_gc_mark_phase(remember);
|
lbm_gc_mark_phase(remember);
|
||||||
|
@ -1160,7 +1159,7 @@ int lbm_perform_gc(void) {
|
||||||
/****************************************************/
|
/****************************************************/
|
||||||
/* Evaluation functions */
|
/* 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);
|
lbm_uint s = lbm_dec_sym(ctx->curr_exp);
|
||||||
if (s < SPECIAL_SYMBOLS_END ||
|
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 *sym_str = lbm_get_name_by_symbol(lbm_dec_sym(ctx->curr_exp));
|
||||||
const char *code_str = NULL;
|
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->r = lbm_cadr(ctx->curr_exp);
|
||||||
ctx->app_cont = true;
|
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->r = ctx->curr_exp;
|
||||||
ctx->app_cont = true;
|
ctx->app_cont = true;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
static inline void eval_atomic(eval_context_t *ctx) {
|
static void eval_atomic(eval_context_t *ctx) {
|
||||||
if (is_atomic) {
|
if (is_atomic) {
|
||||||
lbm_set_error_reason("Atomic blocks cannot be nested!");
|
lbm_set_error_reason("Atomic blocks cannot be nested!");
|
||||||
error_ctx(ENC_SYM_EERROR);
|
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;
|
lbm_value cont_array;
|
||||||
#ifndef LBM64
|
#ifndef LBM64
|
||||||
|
@ -1275,7 +1274,7 @@ static inline void eval_callcc(eval_context_t *ctx) {
|
||||||
ctx->app_cont = false;
|
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 args = lbm_cdr(ctx->curr_exp);
|
||||||
lbm_value key = lbm_car(args);
|
lbm_value key = lbm_car(args);
|
||||||
lbm_value rest_args = lbm_cdr(args);
|
lbm_value rest_args = lbm_cdr(args);
|
||||||
|
@ -1307,7 +1306,7 @@ static inline void eval_define(eval_context_t *ctx) {
|
||||||
return;
|
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 exps = lbm_cdr(ctx->curr_exp);
|
||||||
lbm_value env = ctx->curr_env;
|
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 env_end = cons_with_gc( env, ENC_SYM_NIL, env);
|
||||||
lbm_value exp = cons_with_gc(body, env_end, env_end);
|
lbm_value exp = cons_with_gc(body, env_end, env_end);
|
||||||
lbm_value par = cons_with_gc(params, exp, exp);
|
lbm_value par = cons_with_gc(params, exp, exp);
|
||||||
return cons_with_gc(ENC_SYM_CLOSURE, par, par);
|
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));
|
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->app_cont = true;
|
||||||
ctx->r = closure;
|
ctx->r = closure;
|
||||||
return;
|
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 cddr = lbm_cdr(lbm_cdr(ctx->curr_exp));
|
||||||
lbm_value then_branch = lbm_car(cddr);
|
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);
|
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 orig_env = ctx->curr_env;
|
||||||
lbm_value binds = lbm_cadr(ctx->curr_exp); // key value pairs.
|
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.
|
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;
|
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);
|
lbm_value rest = lbm_cdr(ctx->curr_exp);
|
||||||
if (lbm_is_symbol_nil(rest)) {
|
if (lbm_is_symbol_nil(rest)) {
|
||||||
ctx->app_cont = true;
|
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);
|
lbm_value rest = lbm_cdr(ctx->curr_exp);
|
||||||
if (lbm_is_symbol_nil(rest)) {
|
if (lbm_is_symbol_nil(rest)) {
|
||||||
ctx->app_cont = true;
|
ctx->app_cont = true;
|
||||||
|
@ -1435,7 +1434,7 @@ static inline void eval_or(eval_context_t *ctx) {
|
||||||
/* (match e (pattern body) */
|
/* (match e (pattern body) */
|
||||||
/* (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);
|
lbm_value rest = lbm_cdr(ctx->curr_exp);
|
||||||
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
|
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) {
|
if (is_atomic) {
|
||||||
lbm_set_error_reason("Cannot receive inside of an atomic block");
|
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;
|
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) {
|
static void cont_progn_rest(eval_context_t *ctx) {
|
||||||
lbm_value rest;
|
lbm_value rest;
|
||||||
lbm_value env;
|
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])) {
|
if (nargs == 2 && lbm_is_symbol(args[1])) {
|
||||||
lbm_uint s = lbm_dec_sym(args[1]);
|
lbm_uint s = lbm_dec_sym(args[1]);
|
||||||
if (s >= VARIABLE_SYMBOLS_START &&
|
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;
|
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) {
|
if (nargs == 1) {
|
||||||
lbm_value chan = ENC_SYM_NIL;
|
lbm_value chan = ENC_SYM_NIL;
|
||||||
if (lbm_type_of(args[1]) == LBM_TYPE_ARRAY) {
|
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);
|
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) {
|
if (is_atomic) {
|
||||||
lbm_set_error_reason("Cannot yield inside of an atomic block");
|
lbm_set_error_reason("Cannot yield inside of an atomic block");
|
||||||
error_ctx(ENC_SYM_EERROR);
|
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) {
|
if (lbm_type_of(args[1]) == LBM_TYPE_I) {
|
||||||
lbm_cid cid = (lbm_cid)lbm_dec_i(args[1]);
|
lbm_cid cid = (lbm_cid)lbm_dec_i(args[1]);
|
||||||
lbm_stack_drop(&ctx->K, nargs+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];
|
ctx->curr_exp = args[1];
|
||||||
lbm_stack_drop(&ctx->K, nargs+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];
|
lbm_value prg = args[1];
|
||||||
prg = lbm_list_append(prg, ctx->program);
|
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);
|
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;
|
lbm_value status = ENC_SYM_EERROR;
|
||||||
if (nargs == 2) {
|
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;
|
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;
|
lbm_value ok_val = ENC_SYM_TRUE;
|
||||||
if (nargs >= 1) {
|
if (nargs >= 1) {
|
||||||
ok_val = args[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();
|
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;
|
(void) ctx;
|
||||||
lbm_value err_val = ENC_SYM_EERROR;
|
lbm_value err_val = ENC_SYM_EERROR;
|
||||||
if (nargs >= 1) {
|
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);
|
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]));
|
extension_fptr f = lbm_get_extension(lbm_dec_sym(args[0]));
|
||||||
if (f == NULL) {
|
if (f == NULL) {
|
||||||
error_ctx(ENC_SYM_EERROR);
|
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) {
|
static void cont_closure_application_args(eval_context_t *ctx) {
|
||||||
lbm_uint* sptr = lbm_get_stack_ptr(&ctx->K, 5);
|
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) {
|
if (lbm_type_of(ctx->r) == LBM_TYPE_CONS) {
|
||||||
switch (lbm_car(ctx->r)) {
|
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:{
|
case ENC_SYM_MACRO:{
|
||||||
/*
|
/*
|
||||||
* Perform macro expansion.
|
* Perform macro expansion.
|
||||||
|
@ -2732,9 +2688,6 @@ static void cont_application_start(eval_context_t *ctx) {
|
||||||
* Second to evaluate the resulting program.
|
* Second to evaluate the resulting program.
|
||||||
*/
|
*/
|
||||||
sptr[1] = EVAL_R;
|
sptr[1] = EVAL_R;
|
||||||
/* CHECK_STACK(lbm_push_u32_2(&ctx->K, */
|
|
||||||
/* env, */
|
|
||||||
/* EVAL_R)); */
|
|
||||||
lbm_value exp = lbm_cadr(lbm_cdr(ctx->r));
|
lbm_value exp = lbm_cadr(lbm_cdr(ctx->r));
|
||||||
ctx->curr_exp = exp;
|
ctx->curr_exp = exp;
|
||||||
ctx->curr_env = expand_env;
|
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_value env;
|
||||||
lbm_pop(&ctx->K, &env);
|
lbm_pop(&ctx->K, &env);
|
||||||
|
@ -2808,7 +2761,6 @@ static const cont_fun continuations[NUM_CONTINUATIONS] =
|
||||||
cont_eval_r,
|
cont_eval_r,
|
||||||
cont_set_var,
|
cont_set_var,
|
||||||
cont_resume,
|
cont_resume,
|
||||||
cont_expand_macro,
|
|
||||||
cont_closure_application_args,
|
cont_closure_application_args,
|
||||||
cont_exit_atomic,
|
cont_exit_atomic,
|
||||||
cont_read_next_token,
|
cont_read_next_token,
|
||||||
|
|
|
@ -33,6 +33,156 @@
|
||||||
|
|
||||||
lbm_heap_state_t lbm_heap_state;
|
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 *lbm_dec_str(lbm_value val) {
|
||||||
char *res = 0;
|
char *res = 0;
|
||||||
if (lbm_type_of(val) == LBM_TYPE_ARRAY) {
|
if (lbm_type_of(val) == LBM_TYPE_ARRAY) {
|
||||||
|
@ -230,35 +380,44 @@ double lbm_dec_as_double(lbm_value a) {
|
||||||
}
|
}
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
/****************************************************/
|
||||||
|
/* IS */
|
||||||
|
|
||||||
static inline lbm_value read_car(lbm_cons_t *cell) {
|
bool lbm_is_number(lbm_value x) {
|
||||||
return cell->car;
|
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) {
|
static inline void set_gc_mark(lbm_cons_t *cell) {
|
||||||
lbm_value cdr = read_cdr(cell);
|
lbm_value cdr = cell->cdr;
|
||||||
set_cdr_(cell, lbm_set_gc_mark(cdr));
|
cell->cdr = lbm_set_gc_mark(cdr);
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline void clr_gc_mark(lbm_cons_t *cell) {
|
static inline void clr_gc_mark(lbm_cons_t *cell) {
|
||||||
lbm_value cdr = read_cdr(cell);
|
lbm_value cdr = cell->cdr;
|
||||||
set_cdr_(cell, lbm_clr_gc_mark(cdr));
|
cell->cdr = lbm_clr_gc_mark(cdr);
|
||||||
}
|
}
|
||||||
|
|
||||||
static inline bool get_gc_mark(lbm_cons_t* cell) {
|
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);
|
return lbm_get_gc_mark(cdr);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -274,13 +433,13 @@ static int generate_freelist(size_t num_cells) {
|
||||||
// Add all cells to free list
|
// Add all cells to free list
|
||||||
for (i = 1; i < num_cells; i ++) {
|
for (i = 1; i < num_cells; i ++) {
|
||||||
t = lbm_ref_cell(lbm_enc_cons_ptr(i-1));
|
t = lbm_ref_cell(lbm_enc_cons_ptr(i-1));
|
||||||
set_car_(t, ENC_SYM_RECOVERED); // all cars in free list are "RECOVERED"
|
t->car = ENC_SYM_RECOVERED; // all cars in free list are "RECOVERED"
|
||||||
set_cdr_(t, lbm_enc_cons_ptr(i));
|
t->cdr = lbm_enc_cons_ptr(i);
|
||||||
}
|
}
|
||||||
|
|
||||||
// Replace the incorrect pointer at the last cell.
|
// Replace the incorrect pointer at the last cell.
|
||||||
t = lbm_ref_cell(lbm_enc_cons_ptr(num_cells-1));
|
t = lbm_ref_cell(lbm_enc_cons_ptr(num_cells-1));
|
||||||
set_cdr_(t, ENC_SYM_NIL);
|
t->cdr = ENC_SYM_NIL;
|
||||||
|
|
||||||
return 1;
|
return 1;
|
||||||
}
|
}
|
||||||
|
@ -367,8 +526,8 @@ lbm_value lbm_heap_allocate_cell(lbm_type ptr_type) {
|
||||||
lbm_heap_state.num_alloc++;
|
lbm_heap_state.num_alloc++;
|
||||||
|
|
||||||
// set some ok initial values (nil . nil)
|
// set some ok initial values (nil . nil)
|
||||||
set_car_(lbm_ref_cell(res), ENC_SYM_NIL);
|
lbm_ref_cell(res)->car = ENC_SYM_NIL;
|
||||||
set_cdr_(lbm_ref_cell(res), ENC_SYM_NIL);
|
lbm_ref_cell(res)->cdr = ENC_SYM_NIL;
|
||||||
|
|
||||||
// clear GC bit on allocated cell
|
// clear GC bit on allocated cell
|
||||||
clr_gc_mark(lbm_ref_cell(res));
|
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 lbm_cons(lbm_value car, lbm_value cdr) {
|
||||||
lbm_value addr = lbm_heap_allocate_cell(LBM_TYPE_CONS);
|
lbm_value addr = lbm_heap_allocate_cell(LBM_TYPE_CONS);
|
||||||
if ( lbm_is_ptr(addr)) {
|
if ( lbm_is_ptr(addr)) {
|
||||||
set_car_(lbm_ref_cell(addr), car);
|
lbm_ref_cell(addr)->car = car;
|
||||||
set_cdr_(lbm_ref_cell(addr), cdr);
|
lbm_ref_cell(addr)->cdr = cdr;
|
||||||
}
|
}
|
||||||
|
|
||||||
// heap_allocate_cell returns MERROR if out of heap.
|
// 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) ){
|
if (lbm_is_ptr(c) ){
|
||||||
lbm_cons_t *cell = lbm_ref_cell(c);
|
lbm_cons_t *cell = lbm_ref_cell(c);
|
||||||
return read_car(cell);
|
return cell->car;
|
||||||
}
|
}
|
||||||
return ENC_SYM_TERROR;
|
return ENC_SYM_TERROR;
|
||||||
}
|
}
|
||||||
|
@ -601,7 +760,7 @@ lbm_value lbm_cdr(lbm_value c){
|
||||||
|
|
||||||
if (lbm_is_ptr(c)) {
|
if (lbm_is_ptr(c)) {
|
||||||
lbm_cons_t *cell = lbm_ref_cell(c);
|
lbm_cons_t *cell = lbm_ref_cell(c);
|
||||||
return read_cdr(cell);
|
return cell->cdr;
|
||||||
}
|
}
|
||||||
return ENC_SYM_TERROR;
|
return ENC_SYM_TERROR;
|
||||||
}
|
}
|
||||||
|
@ -610,7 +769,7 @@ int lbm_set_car(lbm_value c, lbm_value v) {
|
||||||
int r = 0;
|
int r = 0;
|
||||||
if (lbm_type_of(c) == LBM_TYPE_CONS) {
|
if (lbm_type_of(c) == LBM_TYPE_CONS) {
|
||||||
lbm_cons_t *cell = lbm_ref_cell(c);
|
lbm_cons_t *cell = lbm_ref_cell(c);
|
||||||
set_car_(cell,v);
|
cell->car = v;
|
||||||
r = 1;
|
r = 1;
|
||||||
}
|
}
|
||||||
return r;
|
return r;
|
||||||
|
@ -620,7 +779,7 @@ int lbm_set_cdr(lbm_value c, lbm_value v) {
|
||||||
int r = 0;
|
int r = 0;
|
||||||
if (lbm_type_of(c) == LBM_TYPE_CONS){
|
if (lbm_type_of(c) == LBM_TYPE_CONS){
|
||||||
lbm_cons_t *cell = lbm_ref_cell(c);
|
lbm_cons_t *cell = lbm_ref_cell(c);
|
||||||
set_cdr_(cell,v);
|
cell->cdr = v;
|
||||||
r = 1;
|
r = 1;
|
||||||
}
|
}
|
||||||
return r;
|
return r;
|
||||||
|
|
|
@ -53,7 +53,6 @@ special_sym const special_symbols[] = {
|
||||||
{"send" , SYM_SEND},
|
{"send" , SYM_SEND},
|
||||||
{"recv" , SYM_RECEIVE},
|
{"recv" , SYM_RECEIVE},
|
||||||
{"macro" , SYM_MACRO},
|
{"macro" , SYM_MACRO},
|
||||||
{"macro-expand" , SYM_MACRO_EXPAND},
|
|
||||||
{"call-cc" , SYM_CALLCC},
|
{"call-cc" , SYM_CALLCC},
|
||||||
{"continuation" , SYM_CONT},
|
{"continuation" , SYM_CONT},
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue