Merge commit '64241f5b10852ef7d449c41b328170157296400f'

lispBM/lispBM/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
  *

lispBM/lispBM/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);

lispBM/lispBM/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);
 

lispBM/lispBM/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: {

lispBM/lispBM/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;
+}

lispBM/lispBM/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);

lispBM/lispBM/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;
       }
     }