mirror of https://github.com/rusefi/bldc.git
Squashed 'lispBM/lispBM/' changes from ae675bb2..5bc9cc72
5bc9cc72 update readme 20763667 added a number of GC tests. all of which pass under both garbage collection principles. 8f0f9f04 first attempt at pointer-reversal mark phase. This mark implementation is disabled per default and can be tried out by building with -DUSE_GC_PTR_REV 6f4b7899 refactor closure application and addition of several error-suspects in fundamental operations 34942ef9 undo some changes related to error_reason and some cleaning f046c967 added lbm_set_error_suspect to allow setting a more relevant expression likely to be guilty of an error to an error message git-subtree-dir: lispBM/lispBM git-subtree-split: 5bc9cc726803bc65c8853ccd1c99a44bc5de5063
This commit is contained in:
Benjamin Vedder
parent
27f5bb5b32
commit
9417ed7f38
49
README.md
49
README.md
|
|
@ -18,13 +18,23 @@ The LispBM mascot, Lispy the llama, was created by
|
|||
## Want to get involved and help out?
|
||||
|
||||
There are lots of interesting things to code on in and around the
|
||||
LispBM runtime system.
|
||||
LispBM runtime system. I would love to interact with people who are interested
|
||||
in high-level programming languages on microcontrollers (or elsewhere) so please
|
||||
do not be shy to make contact. Together we can make great stuff happen ;)
|
||||
|
||||
1. Are you interested in microcontrollers and programming languages?
|
||||
2. You find it fun to mess around in C code with close to zero comments?
|
||||
3. Then join in the fun. Lots to do, so little time!
|
||||
4. Poke me by mail bo(dot)joel(dot)svensson(whirly-a)gmail(dot)com.
|
||||
|
||||
There are also other areas that could use insights and help. Some I can
|
||||
think of are:
|
||||
|
||||
1. Running LispBM on system simulators.
|
||||
2. LispBM efficiency, compilation, byte-code and real time garbage collection.
|
||||
3. Documentation and testing.
|
||||
4. ...
|
||||
|
||||
## Getting started
|
||||
|
||||
The easiest way to get started with LispBM programming is to use
|
||||
|
|
@ -51,41 +61,18 @@ what we call "extensions" which are C functions that can be called from your Lis
|
|||
|
||||
### Compile a 64bit binary for linux
|
||||
|
||||
1. Build the repl: `cd repl` and then `make all64`
|
||||
To really experience LispBM one should use it on a microcontroller. The repl
|
||||
available for X86 is currently very limited and "hacky". I use this repl as an
|
||||
experiment platform while working on the LBM implementation. A more serious attempt
|
||||
at a useful desktop/laptop/rpi LispBM repl is work in progress.
|
||||
|
||||
1. Build the repl: `cd experiment_repl` and then `make all64`
|
||||
|
||||
2. Run the repl: `./repl`
|
||||
|
||||
## Compile a 32bit binary for linux (Requires 32bit libraries. May need something like "multilib" on a 64bit linux)
|
||||
|
||||
1. Build the repl: `cd repl` and then `make`
|
||||
1. Build the repl: `cd experiment_repl` and then `make`
|
||||
|
||||
2. Run the repl: `./repl`
|
||||
|
||||
### Compile on Raspberry Pi
|
||||
|
||||
To build the library exeute the following command in the lispbm folder:
|
||||
|
||||
```
|
||||
PLATFORM=pi make
|
||||
```
|
||||
|
||||
To build the `repl` example repl do:
|
||||
|
||||
```
|
||||
cd repl
|
||||
make pirepl
|
||||
```
|
||||
|
||||
Then start it up using `./repl`
|
||||
Building the library is not a prerequisite for building the repl anymore.
|
||||
|
||||
### SDL and LispBM
|
||||
|
||||
In the `sdlrepl` directory there is a start of a set of SDL bindings for LispBM.
|
||||
|
||||
To build this repl you need the following dependencies:
|
||||
|
||||
1. libsdl2-dev - `sudo apt-get install libsdl2-dev`
|
||||
2. libsdl2-image-dev - `sudo apt-get install libsdl2-image-dev`
|
||||
|
||||
Then compile the repl using the command `make`
|
||||
|
|
|
|||
|
|
@ -222,9 +222,13 @@ uint32_t lbm_get_eval_state(void);
|
|||
* and will in that case be freed when the context
|
||||
* that errored is removed.
|
||||
* \param error_str
|
||||
* \return 1 on success and 0 on failure.
|
||||
*/
|
||||
int lbm_set_error_reason(char *error_str);
|
||||
void lbm_set_error_reason(char *error_str);
|
||||
/** Provide the expression that is most suspicious
|
||||
* in relation to the error at hand.
|
||||
* \param lbm_value
|
||||
*/
|
||||
void lbm_set_error_suspect(lbm_value suspect);
|
||||
/** Terminate the runtime system in response to an
|
||||
* error that it is not possible to recover from.
|
||||
*/
|
||||
|
|
|
|||
|
|
@ -199,6 +199,7 @@ Aux bits could be used for storing vector size. Up to 30bits should be available
|
|||
#define LBM_PTR_BIT 0x00000001u
|
||||
#define LBM_PTR_VAL_MASK 0x03FFFFFCu
|
||||
#define LBM_PTR_TYPE_MASK 0xFC000000u
|
||||
#define LBM_PTR_NULL (0x03FFFFFCu >> 2)
|
||||
|
||||
// The address is an index into the const heap.
|
||||
#define LBM_PTR_TO_CONSTANT_BIT 0x04000000u
|
||||
|
|
@ -214,6 +215,7 @@ Aux bits could be used for storing vector size. Up to 30bits should be available
|
|||
#define LBM_PTR_BIT (lbm_uint)0x1
|
||||
#define LBM_PTR_VAL_MASK (lbm_uint)0x03FFFFFFFFFFFFFC
|
||||
#define LBM_PTR_TYPE_MASK (lbm_uint)0xF800000000000000
|
||||
#define LBM_PTR_NULL ((lbm_uint)0x03FFFFFFFFFFFFFC >> 2)
|
||||
|
||||
#define LBM_PTR_TO_CONSTANT_BIT (lbm_uint)0x0400000000000000
|
||||
#define LBM_PTR_TO_CONSTANT_MASK ~LBM_PTR_TO_CONSTANT_BIT
|
||||
|
|
@ -561,18 +563,22 @@ void lbm_nil_freelist(void);
|
|||
*/
|
||||
int lbm_gc_mark_freelist(void);
|
||||
/** Mark heap cells reachable from the lbm_value v.
|
||||
*
|
||||
* \return 1 on success and 0 if the stack used internally is full.
|
||||
* \param root
|
||||
*/
|
||||
int lbm_gc_mark_phase(void);
|
||||
void lbm_gc_mark_phase(lbm_value root);
|
||||
/** Performs lbm_gc_mark_phase on all the values of an array.
|
||||
*
|
||||
* This function is similar to lbm_gc_mark_roots but performs
|
||||
* extra checks to not traverse into non-standard values.
|
||||
* TODO: Check if this function is really needed.
|
||||
* \param data Array of roots to traverse from.
|
||||
* \param n Number of elements in roots-array.
|
||||
* \return 1 on success or 0 for failure.
|
||||
*/
|
||||
int lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
|
||||
|
||||
void lbm_gc_mark_aux(lbm_uint *data, lbm_uint n);
|
||||
/** Performs lbm_gc_mark_phase on all the values in the roots array.
|
||||
* \param roots pointer to array of roots.
|
||||
* \param num_roots size of array of roots.
|
||||
*/
|
||||
void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots);
|
||||
/** Sweep up all non marked heap cells and place them on the free list.
|
||||
*
|
||||
* \return 1
|
||||
|
|
|
|||
|
|
@ -27,13 +27,19 @@ extern "C" {
|
|||
/** LBM major version */
|
||||
#define LBM_MAJOR_VERSION 0
|
||||
/** LBM minor version */
|
||||
#define LBM_MINOR_VERSION 19
|
||||
#define LBM_MINOR_VERSION 20
|
||||
/** LBM patch revision */
|
||||
#define LBM_PATCH_VERSION 0
|
||||
|
||||
#define LBM_VERSION_STRING "0.19.0"
|
||||
#define LBM_VERSION_STRING "0.20.0"
|
||||
|
||||
/*! \page changelog Changelog
|
||||
NOV 1 2024: Version 0.20.0
|
||||
- Added lbm_set_error_suspect function to enable extension authors to point out in more detail what is wrong.
|
||||
- Improvement to error messages in some cases.
|
||||
- Changed behavior of set family on functions when variable is not already bound (now an error).
|
||||
- Fix of bug in flat_value handling.
|
||||
|
||||
OCT 8 2024: Version 0.19.0
|
||||
- Error message and callback on GC stack overflow.
|
||||
- Functions for gc stack size statistics added.
|
||||
|
|
|
|||
139
src/eval_cps.c
139
src/eval_cps.c
|
|
@ -120,6 +120,9 @@ const char* lbm_error_str_flash_error = "Error writing to flash.";
|
|||
const char* lbm_error_str_flash_full = "Flash memory is full.";
|
||||
const char* lbm_error_str_variable_not_bound = "Variable not bound.";
|
||||
|
||||
static lbm_value lbm_error_suspect;
|
||||
static bool lbm_error_has_suspect = false;
|
||||
|
||||
#define WITH_GC(y, x) \
|
||||
(y) = (x); \
|
||||
if (lbm_is_symbol_merror((y))) { \
|
||||
|
|
@ -133,8 +136,7 @@ const char* lbm_error_str_variable_not_bound = "Variable not bound.";
|
|||
#define WITH_GC_RMBR_1(y, x, r) \
|
||||
(y) = (x); \
|
||||
if (lbm_is_symbol_merror((y))) { \
|
||||
add_roots_1(r); \
|
||||
lbm_gc_mark_phase(); \
|
||||
lbm_gc_mark_phase(r); \
|
||||
gc(); \
|
||||
(y) = (x); \
|
||||
if (lbm_is_symbol_merror((y))) { \
|
||||
|
|
@ -373,26 +375,11 @@ eval_context_t *lbm_get_current_context(void) {
|
|||
/****************************************************/
|
||||
/* Utilities used locally in this file */
|
||||
|
||||
static void add_roots_1(lbm_value r1) {
|
||||
lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r1;
|
||||
}
|
||||
|
||||
static void add_roots_2(lbm_value r1, lbm_value r2) {
|
||||
lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r1;
|
||||
lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r2;
|
||||
}
|
||||
|
||||
static void add_roots_3(lbm_value r1, lbm_value r2, lbm_value r3) {
|
||||
lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r1;
|
||||
lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r2;
|
||||
lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = r3;
|
||||
}
|
||||
|
||||
static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
|
||||
lbm_value res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
|
||||
if (lbm_is_symbol_merror(res)) {
|
||||
add_roots_3(head, tail, remember);
|
||||
lbm_gc_mark_phase();
|
||||
lbm_value roots[3] = {head, tail, remember};
|
||||
lbm_gc_mark_roots(roots,3);
|
||||
gc();
|
||||
res = lbm_heap_allocate_cell(LBM_TYPE_CONS, head, tail);
|
||||
if (lbm_is_symbol_merror(res)) {
|
||||
|
|
@ -712,9 +699,15 @@ void print_error_message(lbm_value error, bool has_at, lbm_value at, unsigned in
|
|||
printf_callback( "*** Error: %s\n", buf);
|
||||
if (has_at) {
|
||||
lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, at);
|
||||
printf_callback("*** In: %s\n",buf);
|
||||
if (lbm_error_has_suspect) {
|
||||
lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, lbm_error_suspect);
|
||||
lbm_error_has_suspect = false;
|
||||
printf_callback("*** At: %s\n", buf);
|
||||
} else {
|
||||
lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->curr_exp);
|
||||
printf_callback("*** After: %s\n",buf);
|
||||
}
|
||||
} else {
|
||||
lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->curr_exp);
|
||||
printf_callback("*** Near: %s\n",buf);
|
||||
|
|
@ -945,13 +938,15 @@ bool lbm_wait_ctx(lbm_cid cid, lbm_uint timeout_ms) {
|
|||
return true;
|
||||
}
|
||||
|
||||
int lbm_set_error_reason(char *error_str) {
|
||||
int r = 0;
|
||||
if (ctx_running) {
|
||||
ctx_running->error_reason = error_str;
|
||||
r = 1;
|
||||
void lbm_set_error_suspect(lbm_value suspect) {
|
||||
lbm_error_suspect = suspect;
|
||||
lbm_error_has_suspect = true;
|
||||
}
|
||||
|
||||
void lbm_set_error_reason(char *error_str) {
|
||||
if (ctx_running != NULL) {
|
||||
ctx_running->error_reason = error_str;
|
||||
}
|
||||
return r;
|
||||
}
|
||||
|
||||
// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
|
||||
|
|
@ -1125,16 +1120,16 @@ static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint
|
|||
|
||||
ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
|
||||
if (ctx == NULL) {
|
||||
add_roots_2(program, env);
|
||||
lbm_gc_mark_phase();
|
||||
lbm_uint roots[2] = {program, env};
|
||||
lbm_gc_mark_roots(roots, 2);
|
||||
gc();
|
||||
ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
|
||||
}
|
||||
if (ctx == NULL) return -1;
|
||||
|
||||
if (!lbm_stack_allocate(&ctx->K, stack_size)) {
|
||||
add_roots_2(program, env);
|
||||
lbm_gc_mark_phase();
|
||||
lbm_uint roots[2] = {program, env};
|
||||
lbm_gc_mark_roots(roots, 2);
|
||||
gc();
|
||||
if (!lbm_stack_allocate(&ctx->K, stack_size)) {
|
||||
lbm_memory_free((lbm_uint*)ctx);
|
||||
|
|
@ -1145,8 +1140,8 @@ static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint
|
|||
lbm_value *mailbox = NULL;
|
||||
mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
|
||||
if (mailbox == NULL) {
|
||||
add_roots_2(program, env);
|
||||
lbm_gc_mark_phase();
|
||||
lbm_value roots[2] = {program, env};
|
||||
lbm_gc_mark_roots(roots,2);
|
||||
gc();
|
||||
mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
|
||||
}
|
||||
|
|
@ -1161,8 +1156,8 @@ static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint
|
|||
lbm_uint name_len = strlen(name) + 1;
|
||||
ctx->name = lbm_malloc(strlen(name) + 1);
|
||||
if (ctx->name == NULL) {
|
||||
add_roots_2(program, env);
|
||||
lbm_gc_mark_phase();
|
||||
lbm_value roots[2] = {program, env};
|
||||
lbm_gc_mark_roots(roots, 2);
|
||||
gc();
|
||||
ctx->name = lbm_malloc(strlen(name) + 1);
|
||||
}
|
||||
|
|
@ -1439,12 +1434,14 @@ static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
|
|||
// just return no_match.
|
||||
static int find_match(lbm_value plist, lbm_value *earr, lbm_uint num, lbm_value *e, lbm_value *env) {
|
||||
|
||||
// A pattern list is a list of pattern, expression lists.
|
||||
// ( (p1 e1) (p2 e2) ... (pn en))
|
||||
lbm_value curr_p = plist;
|
||||
int n = 0;
|
||||
bool gc = false;
|
||||
for (int i = 0; i < (int)num; i ++ ) {
|
||||
lbm_value curr_e = earr[i];
|
||||
while (lbm_is_cons(curr_p)) {
|
||||
while (!lbm_is_symbol_nil(curr_p)) {
|
||||
lbm_value me = get_car(curr_p);
|
||||
if (match(get_car(me), curr_e, env, &gc)) {
|
||||
if (gc) return FM_NEED_GC;
|
||||
|
|
@ -1471,8 +1468,8 @@ static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
|
|||
(void) arg1;
|
||||
(void) arg2;
|
||||
lbm_value roots[4] = { ctx->curr_env, ctx->curr_exp, ctx->program, ctx->r };
|
||||
lbm_gc_mark_aux(roots, 4);
|
||||
lbm_gc_mark_aux(ctx->mailbox, ctx->num_mail);
|
||||
lbm_gc_mark_roots(roots, 4);
|
||||
lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
|
||||
lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
|
||||
}
|
||||
|
||||
|
|
@ -1487,14 +1484,12 @@ static int gc(void) {
|
|||
lbm_value *variables = lbm_get_variable_table();
|
||||
if (variables) {
|
||||
for (int i = 0; i < lbm_get_num_variables(); i ++) {
|
||||
add_roots_1(variables[i]);
|
||||
lbm_gc_mark_phase();
|
||||
lbm_gc_mark_phase(variables[i]);
|
||||
}
|
||||
}
|
||||
// The freelist should generally be NIL when GC runs.
|
||||
lbm_nil_freelist();
|
||||
add_roots_1(lbm_get_env());
|
||||
lbm_gc_mark_phase();
|
||||
lbm_gc_mark_phase(lbm_get_env());
|
||||
|
||||
mutex_lock(&qmutex); // Lock the queues.
|
||||
// Any concurrent messing with the queues
|
||||
|
|
@ -1800,8 +1795,7 @@ static void eval_let(eval_context_t *ctx) {
|
|||
if (r < 0) {
|
||||
if (r == BL_NO_MEMORY) {
|
||||
new_env_tmp = new_env;
|
||||
add_roots_1(new_env);
|
||||
lbm_gc_mark_phase();
|
||||
lbm_gc_mark_phase(new_env);
|
||||
gc();
|
||||
r = create_binding_location(key, &new_env_tmp);
|
||||
}
|
||||
|
|
@ -1855,17 +1849,25 @@ static void eval_or(eval_context_t *ctx) {
|
|||
}
|
||||
}
|
||||
|
||||
/* pattern matching experiment */
|
||||
/* format: */
|
||||
/* (match e (pattern body) */
|
||||
/* (pattern body) */
|
||||
/* ... ) */
|
||||
// Pattern matching
|
||||
// format:
|
||||
// (match e (pattern body)
|
||||
// (pattern body)
|
||||
// ... )
|
||||
//
|
||||
// There can be an optional pattern guard:
|
||||
// (match e (pattern guard body)
|
||||
// ... )
|
||||
// a guard is a boolean expression.
|
||||
// Guards make match, pattern matching more complicated
|
||||
// than the recv pattern matching and requires staged execution
|
||||
// via the continuation system rather than a while loop over a list.
|
||||
static void eval_match(eval_context_t *ctx) {
|
||||
|
||||
lbm_value rest = get_cdr(ctx->curr_exp);
|
||||
if (lbm_type_of(rest) == LBM_TYPE_SYMBOL &&
|
||||
rest == ENC_SYM_NIL) {
|
||||
/* Someone wrote the program (match) */
|
||||
// Someone wrote the program (match)
|
||||
ctx->app_cont = true;
|
||||
ctx->r = ENC_SYM_NIL;
|
||||
} else {
|
||||
|
|
@ -1937,6 +1939,9 @@ static void eval_receive_timeout(eval_context_t *ctx) {
|
|||
receive_base(ctx, pats, timeout_time, true);
|
||||
}
|
||||
|
||||
// Receive
|
||||
// (recv (pattern expr)
|
||||
// (pattern expr))
|
||||
static void eval_receive(eval_context_t *ctx) {
|
||||
|
||||
if (is_atomic) {
|
||||
|
|
@ -2036,7 +2041,6 @@ static void cont_wait(eval_context_t *ctx) {
|
|||
}
|
||||
}
|
||||
|
||||
// Maybe do not create a global but instead raise an error.
|
||||
static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {
|
||||
|
||||
lbm_uint s = lbm_dec_sym(key);
|
||||
|
|
@ -2551,7 +2555,10 @@ static void cont_closure_application_args(eval_context_t *ctx) {
|
|||
bool a_nil = lbm_is_symbol_nil(args);
|
||||
bool p_nil = lbm_is_symbol_nil(cdr_params);
|
||||
|
||||
if (!a_nil && !p_nil) {
|
||||
int ap = (a_nil ? 1 : 0) | ((p_nil ? 1 : 0) << 1);
|
||||
|
||||
switch (ap) {
|
||||
case 0: {
|
||||
// evaluate the next argument.
|
||||
lbm_value car_args, cdr_args;
|
||||
get_car_and_cdr(args, &car_args, &cdr_args);
|
||||
|
|
@ -2561,22 +2568,29 @@ static void cont_closure_application_args(eval_context_t *ctx) {
|
|||
stack_push(&ctx->K, CLOSURE_ARGS);
|
||||
ctx->curr_exp = car_args;
|
||||
ctx->curr_env = arg_env;
|
||||
} else if (a_nil && p_nil) {
|
||||
// Arguments and parameters match up in number
|
||||
lbm_stack_drop(&ctx->K, 5);
|
||||
ctx->curr_env = clo_env;
|
||||
ctx->curr_exp = exp;
|
||||
} else if (!a_nil && p_nil) {
|
||||
// Application with extra arguments
|
||||
lbm_set_error_reason((char*)lbm_error_str_num_args);
|
||||
error_ctx(ENC_SYM_EERROR);
|
||||
} else {
|
||||
// Ran out of arguments, but there are still parameters.
|
||||
} break;
|
||||
case 1: {
|
||||
lbm_value new_env = lbm_list_append(arg_env,clo_env);
|
||||
sptr[0] = new_env; // keep safe from GC. Overwriting arg_env (safe as subset).
|
||||
ctx->r = allocate_closure(cdr_params, exp, new_env);
|
||||
lbm_stack_drop(&ctx->K, 5);
|
||||
ctx->app_cont = true;
|
||||
} break;
|
||||
case 2:
|
||||
// Application with extra arguments
|
||||
lbm_set_error_reason((char*)lbm_error_str_num_args);
|
||||
error_ctx(ENC_SYM_EERROR);
|
||||
// Ran out of arguments, but there are still parameters.
|
||||
break;
|
||||
case 3:
|
||||
// Arguments and parameters match up in number
|
||||
lbm_stack_drop(&ctx->K, 5);
|
||||
ctx->curr_env = clo_env;
|
||||
ctx->curr_exp = exp;
|
||||
break;
|
||||
default:
|
||||
// impossible:
|
||||
error_ctx(ENC_SYM_FATAL_ERROR);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -2723,7 +2737,8 @@ static void cont_match(eval_context_t *ctx) {
|
|||
|
||||
bool is_match = match(pattern, e, &new_env, &do_gc);
|
||||
if (do_gc) {
|
||||
add_roots_3(orig_env, patterns, e);
|
||||
lbm_uint roots[3] = {orig_env, patterns, e};
|
||||
lbm_gc_mark_roots(roots, 3);
|
||||
gc();
|
||||
do_gc = false;
|
||||
new_env = orig_env;
|
||||
|
|
|
|||
|
|
@ -33,6 +33,7 @@ static lbm_uint add2(lbm_uint a, lbm_uint b) {
|
|||
lbm_uint retval = ENC_SYM_TERROR;
|
||||
|
||||
if (!(lbm_is_number(a) && lbm_is_number(b))) {
|
||||
lbm_set_error_suspect(lbm_is_number(a) ? b : a);
|
||||
return retval;
|
||||
}
|
||||
|
||||
|
|
@ -55,6 +56,7 @@ static lbm_uint mul2(lbm_uint a, lbm_uint b) {
|
|||
lbm_uint retval = ENC_SYM_TERROR;
|
||||
|
||||
if (!(lbm_is_number(a) && lbm_is_number(b))) {
|
||||
lbm_set_error_suspect(lbm_is_number(a) ? b : a);
|
||||
return retval;
|
||||
}
|
||||
|
||||
|
|
@ -77,6 +79,7 @@ static lbm_uint div2(lbm_uint a, lbm_uint b) {
|
|||
lbm_uint retval = ENC_SYM_TERROR;
|
||||
|
||||
if (!(lbm_is_number(a) && lbm_is_number(b))) {
|
||||
lbm_set_error_suspect(lbm_is_number(a) ? b : a);
|
||||
return retval;
|
||||
}
|
||||
|
||||
|
|
@ -99,6 +102,7 @@ static lbm_uint mod2(lbm_uint a, lbm_uint b) {
|
|||
lbm_uint retval = ENC_SYM_TERROR;
|
||||
|
||||
if (!(lbm_is_number(a) && lbm_is_number(b))) {
|
||||
lbm_set_error_suspect(lbm_is_number(a) ? b : a);
|
||||
return retval;
|
||||
}
|
||||
|
||||
|
|
@ -120,6 +124,11 @@ static lbm_uint negate(lbm_uint a) {
|
|||
|
||||
lbm_uint retval = ENC_SYM_TERROR;
|
||||
|
||||
if (!lbm_is_number(a)) {
|
||||
lbm_set_error_suspect(a);
|
||||
return retval;
|
||||
}
|
||||
|
||||
if (lbm_type_of_functional(a) > LBM_TYPE_CHAR) {
|
||||
switch (lbm_type_of_functional(a)) {
|
||||
case LBM_TYPE_I: retval = lbm_enc_i(- lbm_dec_i(a)); break;
|
||||
|
|
@ -140,6 +149,7 @@ static lbm_uint sub2(lbm_uint a, lbm_uint b) {
|
|||
lbm_uint retval = ENC_SYM_TERROR;
|
||||
|
||||
if (!(lbm_is_number(a) && lbm_is_number(b))) {
|
||||
lbm_set_error_suspect(lbm_is_number(a) ? b : a);
|
||||
return retval;
|
||||
}
|
||||
|
||||
|
|
@ -215,7 +225,8 @@ static int compare(lbm_uint a, lbm_uint b) {
|
|||
int retval = 0;
|
||||
|
||||
if (!(lbm_is_number(a) && lbm_is_number(b))) {
|
||||
return retval; // result is nonsense if arguments are not numbers.
|
||||
lbm_set_error_suspect(lbm_is_number(a) ? b : a);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
|
||||
lbm_uint t = (lbm_type_of_functional(a) < lbm_type_of_functional(b)) ? lbm_type_of_functional(b) : lbm_type_of_functional(a);
|
||||
|
|
@ -463,6 +474,7 @@ static lbm_value fundamental_lt(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
bool ok = true;
|
||||
|
||||
if (!lbm_is_number(a)) {
|
||||
lbm_set_error_suspect(a);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
for (lbm_uint i = 1; i < nargs; i ++) {
|
||||
|
|
@ -480,6 +492,7 @@ static lbm_value fundamental_lt(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
return ENC_SYM_NIL;
|
||||
}
|
||||
}
|
||||
lbm_set_error_suspect(b);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
|
||||
|
|
@ -492,6 +505,7 @@ static lbm_value fundamental_gt(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
bool ok = true;
|
||||
|
||||
if (!lbm_is_number(a)) {
|
||||
lbm_set_error_suspect(a);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
for (lbm_uint i = 1; i < nargs; i ++) {
|
||||
|
|
@ -509,6 +523,7 @@ static lbm_value fundamental_gt(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
return ENC_SYM_NIL;
|
||||
}
|
||||
}
|
||||
lbm_set_error_suspect(b);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
|
||||
|
|
@ -521,6 +536,7 @@ static lbm_value fundamental_leq(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
bool ok = true;
|
||||
|
||||
if (!lbm_is_number(a)) {
|
||||
lbm_set_error_suspect(a);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
for (lbm_uint i = 1; i < nargs; i ++) {
|
||||
|
|
@ -538,6 +554,7 @@ static lbm_value fundamental_leq(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
return ENC_SYM_NIL;
|
||||
}
|
||||
}
|
||||
lbm_set_error_suspect(b);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
|
||||
|
|
@ -550,6 +567,7 @@ static lbm_value fundamental_geq(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
bool ok = true;
|
||||
|
||||
if (!lbm_is_number(a)) {
|
||||
lbm_set_error_suspect(a);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
for (lbm_uint i = 1; i < nargs; i ++) {
|
||||
|
|
@ -567,6 +585,7 @@ static lbm_value fundamental_geq(lbm_value *args, lbm_uint nargs, eval_context_t
|
|||
return ENC_SYM_NIL;
|
||||
}
|
||||
}
|
||||
lbm_set_error_suspect(b);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
|
||||
|
|
@ -654,12 +673,17 @@ static lbm_value fundamental_list(lbm_value *args, lbm_uint nargs, eval_context_
|
|||
static lbm_value fundamental_append(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
|
||||
(void) ctx;
|
||||
if (nargs == 0) return ENC_SYM_NIL;
|
||||
if (nargs == 1 && !lbm_is_list(args[0])) return ENC_SYM_TERROR;
|
||||
|
||||
if (nargs == 1 && !lbm_is_list(args[0])) {
|
||||
lbm_set_error_suspect(args[0]);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
lbm_value res = args[nargs-1];
|
||||
for (int i = (int)nargs -2; i >= 0; i --) {
|
||||
lbm_value curr = args[i];
|
||||
if (!lbm_is_list(curr)) return ENC_SYM_TERROR;
|
||||
if (!lbm_is_list(curr)) {
|
||||
lbm_set_error_suspect(curr);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
int n = 0;
|
||||
while (lbm_type_of_functional(curr) == LBM_TYPE_CONS) {
|
||||
n++;
|
||||
|
|
@ -752,7 +776,8 @@ static lbm_value fundamental_symbol_to_uint(lbm_value *args, lbm_uint nargs, eva
|
|||
lbm_value s = args[0];
|
||||
if (lbm_type_of_functional(s) == LBM_TYPE_SYMBOL)
|
||||
return lbm_enc_u(lbm_dec_sym(s));
|
||||
else
|
||||
|
||||
lbm_set_error_suspect(s);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
|
||||
|
|
@ -762,7 +787,8 @@ static lbm_value fundamental_uint_to_symbol(lbm_value *args, lbm_uint nargs, eva
|
|||
lbm_value s = args[0];
|
||||
if (lbm_type_of_functional(s) == LBM_TYPE_U)
|
||||
return lbm_enc_sym(lbm_dec_u(s));
|
||||
else
|
||||
|
||||
lbm_set_error_suspect(s);
|
||||
return ENC_SYM_TERROR;
|
||||
}
|
||||
|
||||
|
|
|
|||
99
src/heap.c
99
src/heap.c
|
|
@ -47,6 +47,20 @@ static inline bool lbm_get_gc_mark(lbm_value x) {
|
|||
return x & LBM_GC_MASK;
|
||||
}
|
||||
|
||||
// flag is the same bit as mark, but in car
|
||||
static inline bool lbm_get_gc_flag(lbm_value x) {
|
||||
return x & LBM_GC_MARKED;
|
||||
}
|
||||
|
||||
static inline lbm_value lbm_set_gc_flag(lbm_value x) {
|
||||
return x | LBM_GC_MARKED;
|
||||
}
|
||||
|
||||
static inline lbm_value lbm_clr_gc_flag(lbm_value x) {
|
||||
return x & ~LBM_GC_MASK;
|
||||
}
|
||||
|
||||
|
||||
lbm_heap_state_t lbm_heap_state;
|
||||
|
||||
lbm_const_heap_t *lbm_const_heap_state;
|
||||
|
|
@ -598,10 +612,73 @@ lbm_uint lbm_get_gc_stack_size(void) {
|
|||
return lbm_heap_state.gc_stack.size;
|
||||
}
|
||||
|
||||
int lbm_gc_mark_phase() {
|
||||
#ifdef USE_GC_PTR_REV
|
||||
void value_assign(lbm_value *a, lbm_value b) {
|
||||
lbm_value a_old = *a & LBM_GC_MASK;
|
||||
*a = a_old | (b & ~LBM_GC_MASK);
|
||||
}
|
||||
|
||||
void lbm_gc_mark_phase(lbm_value root) {
|
||||
bool work_to_do = true;
|
||||
|
||||
if (!lbm_is_ptr(root)) return;
|
||||
|
||||
lbm_value curr = root;
|
||||
lbm_value prev = lbm_enc_cons_ptr(LBM_PTR_NULL);
|
||||
|
||||
while (work_to_do) {
|
||||
// follow leftwards pointers
|
||||
while (lbm_is_ptr(curr) &&
|
||||
(lbm_dec_ptr(curr) != LBM_PTR_NULL) &&
|
||||
((curr & LBM_PTR_TO_CONSTANT_BIT) == 0) &&
|
||||
!lbm_get_gc_mark(lbm_cdr(curr))) {
|
||||
// Mark the cell if not a constant cell
|
||||
lbm_cons_t *cell = lbm_ref_cell(curr);
|
||||
cell->cdr = lbm_set_gc_mark(cell->cdr);
|
||||
if (lbm_is_cons_rw(curr)) {
|
||||
lbm_value next = 0;
|
||||
value_assign(&next, cell->car);
|
||||
value_assign(&cell->car, prev);
|
||||
value_assign(&prev,curr);
|
||||
value_assign(&curr, next);
|
||||
}
|
||||
// Will jump out next iteration as gc mark is set in curr.
|
||||
}
|
||||
while (lbm_is_ptr(prev) &&
|
||||
(lbm_dec_ptr(prev) != LBM_PTR_NULL) &&
|
||||
lbm_get_gc_flag(lbm_car(prev)) ) {
|
||||
// clear the flag
|
||||
lbm_cons_t *cell = lbm_ref_cell(prev);
|
||||
cell->car = lbm_clr_gc_flag(cell->car);
|
||||
lbm_value next = 0;
|
||||
value_assign(&next, cell->cdr);
|
||||
value_assign(&cell->cdr, curr);
|
||||
value_assign(&curr, prev);
|
||||
value_assign(&prev, next);
|
||||
}
|
||||
if (lbm_is_ptr(prev) &&
|
||||
lbm_dec_ptr(prev) == LBM_PTR_NULL) {
|
||||
work_to_do = false;
|
||||
} else if (lbm_is_ptr(prev)) {
|
||||
// set the flag
|
||||
lbm_cons_t *cell = lbm_ref_cell(prev);
|
||||
cell->car = lbm_set_gc_flag(cell->car);
|
||||
lbm_value next = 0;
|
||||
value_assign(&next, cell->car);
|
||||
value_assign(&cell->car, curr);
|
||||
value_assign(&curr, cell->cdr);
|
||||
value_assign(&cell->cdr, next);
|
||||
} else {
|
||||
// This should not really happen..
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#else
|
||||
void lbm_gc_mark_phase(lbm_value root) {
|
||||
|
||||
lbm_stack_t *s = &lbm_heap_state.gc_stack;
|
||||
int res = 1;
|
||||
s->data[s->sp++] = root;
|
||||
|
||||
while (!lbm_stack_is_empty(s)) {
|
||||
lbm_value curr;
|
||||
|
|
@ -630,17 +707,16 @@ int lbm_gc_mark_phase() {
|
|||
t_ptr <= LBM_NON_CONS_POINTER_TYPE_LAST) continue;
|
||||
|
||||
if (lbm_is_ptr(cell->cdr)) {
|
||||
res &= lbm_push(s, cell->cdr);
|
||||
}
|
||||
if (!res) {
|
||||
if (!lbm_push(s, cell->cdr)) {
|
||||
lbm_critical_error();
|
||||
break;
|
||||
}
|
||||
}
|
||||
curr = cell->car;
|
||||
goto mark_shortcut; // Skip a push/pop
|
||||
}
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
|
||||
// The free list should be a "proper list"
|
||||
// Using a while loop to traverse over the cdrs
|
||||
|
|
@ -671,7 +747,7 @@ int lbm_gc_mark_freelist() {
|
|||
return 1;
|
||||
}
|
||||
|
||||
int lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) {
|
||||
void lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) {
|
||||
for (lbm_uint i = 0; i < aux_size; i ++) {
|
||||
if (lbm_is_ptr(aux_data[i])) {
|
||||
lbm_type pt_t = lbm_type_of(aux_data[i]);
|
||||
|
|
@ -679,14 +755,17 @@ int lbm_gc_mark_aux(lbm_uint *aux_data, lbm_uint aux_size) {
|
|||
if( pt_t >= LBM_POINTER_TYPE_FIRST &&
|
||||
pt_t <= LBM_POINTER_TYPE_LAST &&
|
||||
pt_v < lbm_heap_state.heap_size) {
|
||||
lbm_heap_state.gc_stack.data[lbm_heap_state.gc_stack.sp ++] = aux_data[i];
|
||||
lbm_gc_mark_phase();
|
||||
lbm_gc_mark_phase(aux_data[i]);
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
void lbm_gc_mark_roots(lbm_uint *roots, lbm_uint num_roots) {
|
||||
for (lbm_uint i = 0; i < num_roots; i ++) {
|
||||
lbm_gc_mark_phase(roots[i]);
|
||||
}
|
||||
}
|
||||
|
||||
// Sweep moves non-marked heap objects to the free list.
|
||||
int lbm_gc_sweep_phase(void) {
|
||||
|
|
|
|||
19
src/tokpar.c
19
src/tokpar.c
|
|
@ -108,9 +108,19 @@ int tok_syntax(lbm_char_channel_t *chan, uint32_t *res) {
|
|||
return tok_match_fixed_size_tokens(chan, fixed_size_tokens, 0, NUM_FIXED_SIZE_TOKENS, res);
|
||||
}
|
||||
|
||||
bool symchar0(char c) {
|
||||
const char *allowed = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ+-*/=<>#!";
|
||||
static bool alpha_char(char c) {
|
||||
return ((c >= 'a' && c <= 'z') ||
|
||||
(c >= 'A' && c <= 'Z'));
|
||||
}
|
||||
|
||||
static bool num_char(char c) {
|
||||
return (c >= '0' && c <= '9');
|
||||
}
|
||||
|
||||
static bool symchar0(char c) {
|
||||
const char *allowed = "+-*/=<>#!";
|
||||
|
||||
if (alpha_char(c)) return true;
|
||||
int i = 0;
|
||||
while (allowed[i] != 0) {
|
||||
if (c == allowed[i]) return true;
|
||||
|
|
@ -119,9 +129,10 @@ bool symchar0(char c) {
|
|||
return false;
|
||||
}
|
||||
|
||||
bool symchar(char c) {
|
||||
const char *allowed = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-*/=<>!?_";
|
||||
static bool symchar(char c) {
|
||||
const char *allowed = "+-*/=<>!?_";
|
||||
|
||||
if (alpha_char(c) || num_char(c)) return true;
|
||||
int i = 0;
|
||||
while (allowed[i] != 0) {
|
||||
if (c == allowed[i]) return true;
|
||||
|
|
|
|||
|
|
@ -28,6 +28,9 @@ all64: $(EXECS)
|
|||
# mv test_lisp_code_cps_nc.exe test_lisp_code_cps_nc
|
||||
|
||||
|
||||
allrev: CCFLAGS += -DUSE_GC_PTR_REV -m32
|
||||
allrev: $(EXECS)
|
||||
mv test_lisp_code_cps.exe test_lisp_code_cps
|
||||
|
||||
%.exe: %.c $(LISPBM_DEPS)
|
||||
$(CC) $(CCFLAGS) $(LISPBM_SRC) $(PLATFORM_SRC) $(LISPBM_FLAGS) $< -o $@ -I$(LISPBM)include $(PLATFORM_INCLUDE) -lpthread
|
||||
|
|
|
|||
|
|
@ -0,0 +1,147 @@
|
|||
#!/bin/bash
|
||||
|
||||
echo "BUILDING"
|
||||
|
||||
make clean
|
||||
make allrev
|
||||
|
||||
echo "PERFORMING TESTS:"
|
||||
|
||||
expected_fails=("test_lisp_code_cps -h 1024 test_take_iota_0.lisp"
|
||||
"test_lisp_code_cps -s -h 1024 test_take_iota_0.lisp"
|
||||
"test_lisp_code_cps -h 512 test_take_iota_0.lisp"
|
||||
"test_lisp_code_cps -s -h 512 test_take_iota_0.lisp"
|
||||
"test_lisp_code_cps -i -h 1024 test_take_iota_0.lisp"
|
||||
"test_lisp_code_cps -i -s -h 1024 test_take_iota_0.lisp"
|
||||
"test_lisp_code_cps -i -h 512 test_take_iota_0.lisp"
|
||||
"test_lisp_code_cps -i -s -h 512 test_take_iota_0.lisp"
|
||||
)
|
||||
|
||||
|
||||
success_count=0
|
||||
fail_count=0
|
||||
failing_tests=()
|
||||
result=0
|
||||
|
||||
for exe in *.exe; do
|
||||
|
||||
if [ "$exe" = "test_gensym.exe" ]; then
|
||||
continue
|
||||
fi
|
||||
|
||||
./$exe
|
||||
|
||||
result=$?
|
||||
|
||||
echo "------------------------------------------------------------"
|
||||
if [ $result -eq 1 ]
|
||||
then
|
||||
success_count=$((success_count+1))
|
||||
echo $exe SUCCESS
|
||||
else
|
||||
|
||||
fail_count=$((fail_count+1))
|
||||
echo $exe FAILED
|
||||
fi
|
||||
echo "------------------------------------------------------------"
|
||||
done
|
||||
|
||||
test_config=("-h 32768"
|
||||
"-i -h 32768"
|
||||
"-s -h 32768"
|
||||
"-i -s -h 32768"
|
||||
"-h 16384"
|
||||
"-i -h 16384"
|
||||
"-s -h 16384"
|
||||
"-i -s -h 16384"
|
||||
"-h 8192"
|
||||
"-i -h 8192"
|
||||
"-s -h 8192"
|
||||
"-i -s -h 8192"
|
||||
"-h 4096"
|
||||
"-i -h 4096"
|
||||
"-s -h 4096"
|
||||
"-i -s -h 4096"
|
||||
"-h 2048"
|
||||
"-i -h 2048"
|
||||
"-s -h 2048"
|
||||
"-i -s -h 2048"
|
||||
"-h 1024"
|
||||
"-i -h 1024"
|
||||
"-s -h 1024"
|
||||
"-i -s -h 1024"
|
||||
"-h 512"
|
||||
"-i -h 512"
|
||||
"-s -h 512"
|
||||
"-i -s -h 512")
|
||||
|
||||
#"test_lisp_code_cps_nc"
|
||||
for prg in "test_lisp_code_cps" ; do
|
||||
for arg in "${test_config[@]}"; do
|
||||
for lisp in *.lisp; do
|
||||
|
||||
./$prg $arg $lisp
|
||||
|
||||
result=$?
|
||||
|
||||
echo "------------------------------------------------------------"
|
||||
#echo $arg
|
||||
if [ $result -eq 1 ]
|
||||
then
|
||||
success_count=$((success_count+1))
|
||||
echo $lisp SUCCESS
|
||||
else
|
||||
|
||||
#!/bin/bash
|
||||
# foo=('foo bar' 'foo baz' 'bar baz')
|
||||
# bar=$(printf ",%s" "${foo[@]}")
|
||||
# bar=${bar:1}
|
||||
|
||||
# echo $bar
|
||||
str=$(printf "%s " "$prg $arg $lisp")
|
||||
#echo $str
|
||||
|
||||
failing_tests+=("$prg $arg $lisp")
|
||||
fail_count=$((fail_count+1))
|
||||
#echo $failing_tests
|
||||
|
||||
echo $lisp FAILED
|
||||
fi
|
||||
echo "------------------------------------------------------------"
|
||||
done
|
||||
done
|
||||
done
|
||||
|
||||
# echo -e $failing_tests
|
||||
|
||||
expected_count=0
|
||||
|
||||
for (( i = 0; i < ${#failing_tests[@]}; i++ ))
|
||||
do
|
||||
expected=false
|
||||
for (( j = 0; j < ${#expected_fails[@]}; j++))
|
||||
do
|
||||
|
||||
if [[ "${failing_tests[$i]}" == "${expected_fails[$j]}" ]] ;
|
||||
then
|
||||
expected=true
|
||||
fi
|
||||
done
|
||||
if $expected ; then
|
||||
expected_count=$((expected_count+1))
|
||||
echo "(OK - expected to fail)" ${failing_tests[$i]}
|
||||
else
|
||||
echo "(FAILURE)" ${failing_tests[$i]}
|
||||
fi
|
||||
done
|
||||
|
||||
|
||||
echo Tests passed: $success_count
|
||||
echo Tests failed: $fail_count
|
||||
echo Expected fails: $expected_count
|
||||
echo Actual fails: $((fail_count - expected_count))
|
||||
|
||||
if [ $((fail_count - expected_count)) -gt 0 ]
|
||||
then
|
||||
exit 1
|
||||
fi
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
|
||||
(define a (list 1 2 3 4))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (eq a (list 1 2 3 4)))
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
|
||||
(define f1 3.14)
|
||||
|
||||
(gc)
|
||||
|
||||
(check (= f1 3.14))
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
|
||||
(define a (list 1 2 3 4))
|
||||
(define b (list a 'x 'y 'z))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (and
|
||||
(eq a (list 1 2 3 4))
|
||||
(eq b (list (list 1 2 3 4) 'x 'y 'z))))
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(define a (list 1 2 3 4))
|
||||
(define b (list a 'x 'y 'z))
|
||||
(define c (list b 'x1 'y1 'z1))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (and
|
||||
(eq a (list 1 2 3 4))
|
||||
(eq b (list (list 1 2 3 4) 'x 'y 'z))
|
||||
(eq c (list (list (list 1 2 3 4) 'x 'y 'z) 'x1 'y1 'z1))))
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
|
||||
(define a (cons 1 2))
|
||||
(define b (cons 3 4))
|
||||
|
||||
(define tree (cons a b))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (eq tree '( (1 . 2) . (3 . 4) )))
|
||||
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
|
||||
(define tree '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (eq tree '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 )))))
|
||||
|
|
@ -0,0 +1,11 @@
|
|||
|
||||
(define tree '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(define tree2 (cons tree tree))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (and
|
||||
(eq tree '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (car tree2) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (cdr tree2) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))))
|
||||
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
|
||||
(define tree '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(define tree2 (cons tree tree))
|
||||
(define tree3 (cons tree2 tree2))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (and
|
||||
(eq tree '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (car tree2) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (cdr tree2) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (car (car tree3)) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (car (cdr tree3)) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (cdr (car tree3)) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))
|
||||
(eq (cdr (cdr tree3)) '(((1 . 2) . (3 . 4)) . ((5 . 6) . (7 . 8 ))))))
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
|
||||
(define arr1 [1 2 3 4])
|
||||
(define arr2 [5 6 7 8])
|
||||
(define tree (cons arr1 arr2))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (eq tree '([1 2 3 4] . [5 6 7 8])))
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
(define arr1 [1 2 3 4])
|
||||
(define arr2 [5 6 7 8])
|
||||
(define tree (cons arr1 arr2))
|
||||
(define tree1 (cons tree tree))
|
||||
|
||||
(gc)
|
||||
|
||||
(check (and
|
||||
(eq tree '([1 2 3 4] . [5 6 7 8]))
|
||||
(eq (car tree1) '([1 2 3 4] . [5 6 7 8]))
|
||||
(eq (cdr tree1) '([1 2 3 4] . [5 6 7 8]))))
|
||||
|
||||
Loading…
Reference in New Issue