From 64241f5b10852ef7d449c41b328170157296400f Mon Sep 17 00:00:00 2001 From: Benjamin Vedder Date: Fri, 29 Apr 2022 15:51:09 +0200 Subject: [PATCH] Squashed 'lispBM/lispBM/' changes from 729c0e51..c155cb49 c155cb49 remove printf 18fe416c fix assoc 74339abd added explicitly free for streams git-subtree-dir: lispBM/lispBM git-subtree-split: c155cb49b20e7a559031155f5a6b4e7b0707d790 --- include/eval_cps.h | 5 +++++ include/heap.h | 13 ++++++++++++- src/eval_cps.c | 16 ++++++++++++++++ src/fundamental.c | 24 ++++++++++++++++++++---- src/heap.c | 37 +++++++++++++++++++++++++++++++++++++ src/lbm_c_interop.c | 6 +++--- src/tokpar.c | 18 +++--------------- 7 files changed, 96 insertions(+), 23 deletions(-) diff --git a/include/eval_cps.h b/include/eval_cps.h index 8b1c632e..451274ac 100644 --- a/include/eval_cps.h +++ b/include/eval_cps.h @@ -227,6 +227,11 @@ extern void lbm_set_reader_done_callback(void (*fptr)(lbm_cid)); * \return token stream. */ extern lbm_value lbm_create_token_stream(lbm_tokenizer_char_stream_t *str); +/** Explicitly free a stream (if something breaks while creating it) + * The stream must not have been made available to the program + * \param stream The stream to free + */ +extern int lbm_explicit_free_token_stream(lbm_value stream); /** deliver a message * diff --git a/include/heap.h b/include/heap.h index 78c3ab73..a3153fa3 100644 --- a/include/heap.h +++ b/include/heap.h @@ -426,7 +426,7 @@ extern lbm_value lbm_cons(lbm_value car, lbm_value cdr); */ extern lbm_value lbm_car(lbm_value cons); /** Accesses the car of the cdr of an cons cell - * + * * \param c Value * \return the cdr field or type error. */ @@ -546,6 +546,11 @@ extern int lbm_gc_sweep_phase(void); * \return 1 for success of 0 for failure. */ extern int lbm_heap_allocate_array(lbm_value *res, lbm_uint size, lbm_type type); +/** Explicitly free an array. + * This function needs to be used with care and knowledge. + * \param arr Array value. + */ +extern int lbm_heap_explicit_free_array(lbm_value arr); /** Query the type information of a value. * @@ -800,6 +805,12 @@ static inline bool lbm_is_array(lbm_value x) { lbm_dec_sym(lbm_cdr(x)) == SYM_ARRAY_TYPE); } +static inline bool lbm_is_stream(lbm_value x) { + return (lbm_type_of(x) == LBM_TYPE_STREAM && + lbm_type_of(lbm_cdr(x)) == LBM_TYPE_SYMBOL && + lbm_dec_sym(lbm_cdr(x)) == SYM_STREAM_TYPE); +} + static inline bool lbm_is_char(lbm_value x) { lbm_uint t = lbm_type_of(x); return (t == LBM_TYPE_CHAR); diff --git a/src/eval_cps.c b/src/eval_cps.c index 672bf0b4..44f62bd8 100644 --- a/src/eval_cps.c +++ b/src/eval_cps.c @@ -380,6 +380,22 @@ lbm_value lbm_create_token_stream(lbm_tokenizer_char_stream_t *str) { return lbm_stream_create(stream); } +int lbm_explicit_free_token_stream(lbm_value stream) { + int r = 0; + if (lbm_is_stream(stream)) { + + lbm_stream_t *str = (lbm_stream_t*)lbm_car(stream); + + lbm_memory_free((lbm_uint*)str); + stream = lbm_set_ptr_type(stream, LBM_TYPE_CONS); + lbm_set_car(stream, lbm_enc_sym(SYM_NIL)); + lbm_set_cdr(stream, lbm_enc_sym(SYM_NIL)); + + r = 1; + } + return r; +} + lbm_value token_stream_from_string_value(lbm_value s) { char *str = lbm_dec_str(s); diff --git a/src/fundamental.c b/src/fundamental.c index efb71b3c..5a9bf114 100644 --- a/src/fundamental.c +++ b/src/fundamental.c @@ -637,6 +637,19 @@ lbm_value index_list(lbm_value l, unsigned int n) { } } +lbm_value assoc_lookup(lbm_value key, lbm_value assoc) { + lbm_value curr = assoc; + + while (lbm_type_of(curr) == LBM_TYPE_CONS) { + lbm_value c = lbm_ref_cell(curr)->car; + if (struct_eq(lbm_ref_cell(c)->car, key)) { + return lbm_ref_cell(c)->cdr; + } + curr = lbm_ref_cell(curr)->cdr; + } + return lbm_enc_sym(SYM_NOT_FOUND); +} + lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) { lbm_uint result = lbm_enc_sym(SYM_EERROR); @@ -854,11 +867,14 @@ lbm_value lbm_fundamental(lbm_value* args, lbm_uint nargs, lbm_value op) { }break; case SYM_ASSOC: { if (nargs == 2 && lbm_is_list(args[0])) { - lbm_value r = lbm_env_lookup(args[1], args[0]); + lbm_value r = assoc_lookup(args[1], args[0]); if (lbm_is_symbol(r) && - lbm_dec_sym(r) == SYM_NOT_FOUND) - r = lbm_enc_sym(SYM_NIL); - else result = r; + lbm_dec_sym(r) == SYM_NOT_FOUND) { + result = lbm_enc_sym(SYM_NIL); + } + else { + result = r; + } } } break; case SYM_ACONS: { diff --git a/src/heap.c b/src/heap.c index 17c942e5..d55f130e 100644 --- a/src/heap.c +++ b/src/heap.c @@ -787,3 +787,40 @@ int lbm_heap_allocate_array(lbm_value *res, lbm_uint size, lbm_type type){ return 1; } + + +/* Explicitly freeing an array. + + This is a highly unsafe operation and can only be safely + used if the heap cell that points to the array has not been made + accessible to the program. + + So This function can be used to free an array in case an array + is being constructed and some error case appears while doing so + If the array still have not become available it can safely be + "explicitly" freed. + + The problem is that if the "array" heap-cell is made available to + the program, this cell can easily be duplicated and we would have + to search the entire heap to find all cells pointing to the array + memory in question and "null"-them out before freeing the memory +*/ + +int lbm_heap_explicit_free_array(lbm_value arr) { + + int r = 0; + if (lbm_is_array(arr)) { + + lbm_array_header_t *header = (lbm_array_header_t*)lbm_car(arr); + + lbm_memory_free((lbm_uint*)header->data); + lbm_memory_free((lbm_uint*)header); + + arr = lbm_set_ptr_type(arr, LBM_TYPE_CONS); + lbm_set_car(arr, lbm_enc_sym(SYM_NIL)); + lbm_set_cdr(arr, lbm_enc_sym(SYM_NIL)); + r = 1; + } + + return r; +} diff --git a/src/lbm_c_interop.c b/src/lbm_c_interop.c index d3ca5a0c..25ea038d 100644 --- a/src/lbm_c_interop.c +++ b/src/lbm_c_interop.c @@ -44,7 +44,7 @@ lbm_cid eval_cps_load_and_eval(lbm_tokenizer_char_stream_t *tokenizer, bool prog if (lbm_type_of(launcher) != LBM_TYPE_CONS || lbm_type_of(evaluator) != LBM_TYPE_CONS || lbm_type_of(start_prg) != LBM_TYPE_CONS ) { - lbm_memory_free((lbm_uint*)stream); + lbm_explicit_free_token_stream(stream); return 0; } return lbm_create_ctx(start_prg, lbm_enc_sym(SYM_NIL), 256); @@ -62,7 +62,7 @@ lbm_cid eval_cps_load_and_define(lbm_tokenizer_char_stream_t *tokenizer, char *s if (!lbm_get_symbol_by_name(symbol, &sym_id)) { if (!lbm_add_symbol(symbol, &sym_id)) { - lbm_memory_free((lbm_uint*)stream); + lbm_explicit_free_token_stream(stream); return 0; } } @@ -80,7 +80,7 @@ lbm_cid eval_cps_load_and_define(lbm_tokenizer_char_stream_t *tokenizer, char *s if (lbm_type_of(launcher) != LBM_TYPE_CONS || lbm_type_of(binding) != LBM_TYPE_CONS || lbm_type_of(definer) != LBM_TYPE_CONS ) { - lbm_memory_free((lbm_uint*)stream); + lbm_explicit_free_token_stream(stream); return 0; } return lbm_create_ctx(definer, lbm_enc_sym(SYM_NIL), 256); diff --git a/src/tokpar.c b/src/tokpar.c index 7f7ae808..08648963 100644 --- a/src/tokpar.c +++ b/src/tokpar.c @@ -484,11 +484,7 @@ bool parse_array(lbm_tokenizer_char_stream_t *str, lbm_uint initial_size, lbm_va while (!done) { clean_whitespace(str); if (!more(str)) { - lbm_memory_free((lbm_uint*)arr->data); - lbm_memory_free((lbm_uint*)arr); - array = lbm_set_ptr_type(array, LBM_TYPE_CONS); - lbm_set_car(array, lbm_enc_sym(SYM_NIL)); - lbm_set_cdr(array, lbm_enc_sym(SYM_NIL)); + lbm_heap_explicit_free_array(array); return false; } @@ -499,11 +495,7 @@ bool parse_array(lbm_tokenizer_char_stream_t *str, lbm_uint initial_size, lbm_va case NOTOKEN: break; default: - lbm_memory_free((lbm_uint*)arr->data); - lbm_memory_free((lbm_uint*)arr); - array = lbm_set_ptr_type(array, LBM_TYPE_CONS); - lbm_set_car(array, lbm_enc_sym(SYM_NIL)); - lbm_set_cdr(array, lbm_enc_sym(SYM_NIL)); + lbm_heap_explicit_free_array(array); return false; } @@ -534,11 +526,7 @@ bool parse_array(lbm_tokenizer_char_stream_t *str, lbm_uint initial_size, lbm_va }break; } if (n == 0) { - lbm_memory_free((lbm_uint*)arr->data); - lbm_memory_free((lbm_uint*)arr); - array = lbm_set_ptr_type(array, LBM_TYPE_CONS); - lbm_set_car(array, lbm_enc_sym(SYM_NIL)); - lbm_set_cdr(array, lbm_enc_sym(SYM_NIL)); + lbm_heap_explicit_free_array(array); return false; } }