Head

GCC Code Coverage Report
Directory:	../src/		Exec	Total	Coverage
File:	/home/joels/Current/lispbm/src/eval_cps.c	Lines:	2798	3242	86.3 %
Date:	2024-12-05 14:36:58	Branches:	874	1328	65.8 %

/*
    Copyright 2018, 2020 - 2024 Joel Svensson    svenssonjoel@yahoo.se

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
*/

#include <lbm_memory.h>
#include <lbm_types.h>
#include "symrepr.h"
#include "heap.h"
#include "env.h"
#include "eval_cps.h"
#include "stack.h"
#include "fundamental.h"
#include "extensions.h"
#include "tokpar.h"
#include "lbm_channel.h"
#include "print.h"
#include "platform_mutex.h"
#include "lbm_flat_value.h"
#include "lbm_flags.h"

#ifdef VISUALIZE_HEAP
#include "heap_vis.h"
#endif

#include <setjmp.h>
#include <stdarg.h>

static jmp_buf error_jmp_buf;
static jmp_buf critical_error_jmp_buf;

#define S_TO_US(X) (lbm_uint)((X) * 1000000)

#define DEC_CONTINUATION(x) (((x) & ~LBM_CONTINUATION_INTERNAL) >> LBM_ADDRESS_SHIFT)
#define IS_CONTINUATION(x) (((x) & LBM_CONTINUATION_INTERNAL) == LBM_CONTINUATION_INTERNAL)
#define CONTINUATION(x) (((x) << LBM_ADDRESS_SHIFT) | LBM_CONTINUATION_INTERNAL)

#define DONE                  CONTINUATION(0)
#define SET_GLOBAL_ENV        CONTINUATION(1)
#define BIND_TO_KEY_REST      CONTINUATION(2)
#define IF                    CONTINUATION(3)
#define PROGN_REST            CONTINUATION(4)
#define APPLICATION_ARGS      CONTINUATION(5)
#define AND                   CONTINUATION(6)
#define OR                    CONTINUATION(7)
#define WAIT                  CONTINUATION(8)
#define MATCH                 CONTINUATION(9)
#define APPLICATION_START     CONTINUATION(10)
#define EVAL_R                CONTINUATION(11)
#define RESUME                CONTINUATION(12)
#define CLOSURE_ARGS          CONTINUATION(13)
#define EXIT_ATOMIC           CONTINUATION(14)
#define READ_NEXT_TOKEN       CONTINUATION(15)
#define READ_APPEND_CONTINUE  CONTINUATION(16)
#define READ_EVAL_CONTINUE    CONTINUATION(17)
#define READ_EXPECT_CLOSEPAR  CONTINUATION(18)
#define READ_DOT_TERMINATE    CONTINUATION(19)
#define READ_DONE             CONTINUATION(20)
#define READ_START_ARRAY      CONTINUATION(21)
#define READ_APPEND_ARRAY     CONTINUATION(22)
#define MAP                   CONTINUATION(23)
#define MATCH_GUARD           CONTINUATION(24)
#define TERMINATE             CONTINUATION(25)
#define PROGN_VAR             CONTINUATION(26)
#define SETQ                  CONTINUATION(27)
#define MOVE_TO_FLASH         CONTINUATION(28)
#define MOVE_VAL_TO_FLASH_DISPATCH CONTINUATION(29)
#define MOVE_LIST_TO_FLASH    CONTINUATION(30)
#define CLOSE_LIST_IN_FLASH   CONTINUATION(31)
#define QQ_EXPAND_START       CONTINUATION(32)
#define QQ_EXPAND             CONTINUATION(33)
#define QQ_APPEND             CONTINUATION(34)
#define QQ_EXPAND_LIST        CONTINUATION(35)
#define QQ_LIST               CONTINUATION(36)
#define KILL                  CONTINUATION(37)
#define LOOP                  CONTINUATION(38)
#define LOOP_CONDITION        CONTINUATION(39)
#define MERGE_REST            CONTINUATION(40)
#define MERGE_LAYER           CONTINUATION(41)
#define CLOSURE_ARGS_REST     CONTINUATION(42)
#define MOVE_ARRAY_ELTS_TO_FLASH CONTINUATION(43)
#define POP_READER_FLAGS      CONTINUATION(44)
#define EXCEPTION_HANDLER     CONTINUATION(45)
#define RECV_TO               CONTINUATION(46)
#define WRAP_RESULT           CONTINUATION(47)
#define RECV_TO_RETRY         CONTINUATION(48)
#define NUM_CONTINUATIONS     49

#define FM_NEED_GC       -1
#define FM_NO_MATCH      -2
#define FM_PATTERN_ERROR -3

typedef enum {
  BL_OK = 0,
  BL_NO_MEMORY,
  BL_INCORRECT_KEY
} binding_location_status;

#define FB_OK             0
#define FB_TYPE_ERROR    -1

const char* lbm_error_str_parse_eof = "End of parse stream.";
const char* lbm_error_str_parse_dot = "Incorrect usage of '.'.";
const char* lbm_error_str_parse_close = "Expected closing parenthesis.";
const char* lbm_error_str_num_args = "Incorrect number of arguments.";
const char* lbm_error_str_forbidden_in_atomic = "Operation is forbidden in an atomic block.";
const char* lbm_error_str_no_number = "Argument(s) must be a number.";
const char* lbm_error_str_not_a_boolean = "Argument must be t or nil (true or false).";
const char* lbm_error_str_incorrect_arg = "Incorrect argument.";
const char* lbm_error_str_var_outside_progn = "Usage of var outside of progn.";
const char* lbm_error_str_flash_not_possible = "Value cannot be written to flash.";
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.";
const char* lbm_error_str_read_no_mem = "Out of memory while reading.";

static lbm_value lbm_error_suspect;
static bool lbm_error_has_suspect = false;
#ifdef LBM_ALWAYS_GC

#define WITH_GC(y, x)                           \
  gc();                                         \
  (y) = (x);                                    \
  if (lbm_is_symbol_merror((y))) {              \
    error_ctx(ENC_SYM_MERROR);                  \
  }

#define WITH_GC_RMBR_1(y, x, r)                 \
  lbm_gc_mark_phase(r);                         \
  gc();                                         \
  (y) = (x);                                    \
  if (lbm_is_symbol_merror((y))) {              \
    error_ctx(ENC_SYM_MERROR);                  \
  }

#else

#define WITH_GC(y, x)                           \
  (y) = (x);                                    \
  if (lbm_is_symbol_merror((y))) {              \
    gc();                                       \
    (y) = (x);                                  \
    if (lbm_is_symbol_merror((y))) {            \
      error_ctx(ENC_SYM_MERROR);                \
    }                                           \
    /* continue executing statements below */   \
  }
#define WITH_GC_RMBR_1(y, x, r)                 \
  (y) = (x);                                    \
  if (lbm_is_symbol_merror((y))) {              \
    lbm_gc_mark_phase(r);                       \
    gc();                                       \
    (y) = (x);                                  \
    if (lbm_is_symbol_merror((y))) {            \
      error_ctx(ENC_SYM_MERROR);                \
    }                                           \
    /* continue executing statements below */   \
  }

#endif

/**************************************************************/
/* */
typedef struct {
  eval_context_t *first;
  eval_context_t *last;
} eval_context_queue_t;

#ifdef CLEAN_UP_CLOSURES
static lbm_value clean_cl_env_symbol = ENC_SYM_NIL;
#endif

static int gc(void);
static void error_ctx(lbm_value);
static void error_at_ctx(lbm_value err_val, lbm_value at);
static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx);
static bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail);

// The currently executing context.
eval_context_t *ctx_running = NULL;
volatile bool  lbm_system_sleeping = false;

static volatile bool gc_requested = false;
void lbm_request_gc(void) {
  gc_requested = true;
}

/*
   On ChibiOs the CH_CFG_ST_FREQUENCY setting in chconf.h sets the
   resolution of the timer used for sleep operations.  If this is set
   to 10KHz the resolution is 100us.

   The CH_CFG_ST_TIMEDELTA specifies the minimum number of ticks that
   can be safely specified in a timeout directive (wonder if that
   means sleep-period). The timedelta is set to 2.

   If I have understood these correctly it means that the minimum
   sleep duration possible is 2 * 100us = 200us.
*/

#define EVAL_CPS_DEFAULT_STACK_SIZE 256
#define EVAL_CPS_MIN_SLEEP 200
#define EVAL_STEPS_QUOTA   10

static volatile uint32_t eval_steps_refill = EVAL_STEPS_QUOTA;
static uint32_t eval_steps_quota = EVAL_STEPS_QUOTA;

void lbm_set_eval_step_quota(uint32_t quota) {
  eval_steps_refill = quota;
}

static uint32_t          eval_cps_run_state = EVAL_CPS_STATE_DEAD;
static volatile uint32_t eval_cps_next_state = EVAL_CPS_STATE_NONE;
static volatile uint32_t eval_cps_next_state_arg = 0;
static volatile bool     eval_cps_state_changed = false;

static void usleep_nonsense(uint32_t us) {
  (void) us;
}

static bool dynamic_load_nonsense(const char *sym, const char **code) {
  (void) sym;
  (void) code;
  return false;
}

static uint32_t timestamp_nonsense(void) {
  return 0;
}

static int printf_nonsense(const char *fmt, ...) {
  (void) fmt;
  return 0;
}

static void ctx_done_nonsense(eval_context_t *ctx) {
  (void) ctx;
}

static void critical_nonsense(void) {
  return;
}

static void user_callback_nonsense(void *arg) {
  (void) arg;
  return;
}

static void (*critical_error_callback)(void) = critical_nonsense;
static void (*usleep_callback)(uint32_t) = usleep_nonsense;
static uint32_t (*timestamp_us_callback)(void) = timestamp_nonsense;
static void (*ctx_done_callback)(eval_context_t *) = ctx_done_nonsense;
static int (*printf_callback)(const char *, ...) = printf_nonsense;
static bool (*dynamic_load_callback)(const char *, const char **) = dynamic_load_nonsense;
static void (*user_callback)(void *) = user_callback_nonsense;

void lbm_set_user_callback(void (*fptr)(void *)) {
  if (fptr == NULL) user_callback = user_callback_nonsense;
  else user_callback = fptr;
}

void lbm_set_critical_error_callback(void (*fptr)(void)) {
  if (fptr == NULL) critical_error_callback = critical_nonsense;
  else critical_error_callback = fptr;
}

void lbm_set_usleep_callback(void (*fptr)(uint32_t)) {
  if (fptr == NULL) usleep_callback = usleep_nonsense;
  else usleep_callback = fptr;
}

void lbm_set_timestamp_us_callback(uint32_t (*fptr)(void)) {
  if (fptr == NULL) timestamp_us_callback = timestamp_nonsense;
  else timestamp_us_callback = fptr;
}

void lbm_set_ctx_done_callback(void (*fptr)(eval_context_t *)) {
  if (fptr == NULL) ctx_done_callback = ctx_done_nonsense;
  else ctx_done_callback = fptr;
}

void lbm_set_printf_callback(int (*fptr)(const char*, ...)){
  if (fptr == NULL) printf_callback = printf_nonsense;
  else printf_callback = fptr;
}

void lbm_set_dynamic_load_callback(bool (*fptr)(const char *, const char **)) {
  if (fptr == NULL) dynamic_load_callback = dynamic_load_nonsense;
  else  dynamic_load_callback = fptr;
}

static volatile lbm_event_t *lbm_events = NULL;
static unsigned int lbm_events_head = 0;
static unsigned int lbm_events_tail = 0;
static unsigned int lbm_events_max  = 0;
static bool         lbm_events_full = false;
static mutex_t      lbm_events_mutex;
static bool         lbm_events_mutex_initialized = false;
static volatile lbm_cid  lbm_event_handler_pid = -1;

lbm_cid lbm_get_event_handler_pid(void) {
  return lbm_event_handler_pid;
}

void lbm_set_event_handler_pid(lbm_cid pid) {
  lbm_event_handler_pid = pid;
}

bool lbm_event_handler_exists(void) {
  return(lbm_event_handler_pid > 0);
}


static bool event_internal(lbm_event_type_t event_type, lbm_uint parameter, lbm_uint buf_ptr, lbm_uint buf_len) {
  bool r = false;
  if (lbm_events) {
    mutex_lock(&lbm_events_mutex);
    if (!lbm_events_full) {
      lbm_event_t event;
      event.type = event_type;
      event.parameter = parameter;
      event.buf_ptr = buf_ptr;
      event.buf_len = buf_len;
      lbm_events[lbm_events_head] = event;
      lbm_events_head = (lbm_events_head + 1) % lbm_events_max;
      lbm_events_full = lbm_events_head == lbm_events_tail;
      r = true;
    }
    mutex_unlock(&lbm_events_mutex);
  }
  return r;
}

bool lbm_event_define(lbm_value key, lbm_flat_value_t *fv) {
  return event_internal(LBM_EVENT_DEFINE, key, (lbm_uint)fv->buf, fv->buf_size);
}

bool lbm_event_run_user_callback(void *arg) {
  return event_internal(LBM_EVENT_RUN_USER_CALLBACK, (lbm_uint)arg, 0, 0);
}

bool lbm_event_unboxed(lbm_value unboxed) {
  lbm_uint t = lbm_type_of(unboxed);
  if (t == LBM_TYPE_SYMBOL ||
      t == LBM_TYPE_I ||
      t == LBM_TYPE_U ||
      t == LBM_TYPE_CHAR) {
    if (lbm_event_handler_pid > 0) {
      return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)unboxed, 0);
    }
  }
  return false;
}

bool lbm_event(lbm_flat_value_t *fv) {
  if (lbm_event_handler_pid > 0) {
    return event_internal(LBM_EVENT_FOR_HANDLER, 0, (lbm_uint)fv->buf, fv->buf_size);
  }
  return false;
}

static bool lbm_event_pop(lbm_event_t *event) {
  mutex_lock(&lbm_events_mutex);
  if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
    mutex_unlock(&lbm_events_mutex);
    return false;
  }
  *event = lbm_events[lbm_events_tail];
  lbm_events_tail = (lbm_events_tail + 1) % lbm_events_max;
  lbm_events_full = false;
  mutex_unlock(&lbm_events_mutex);
  return true;
}

bool lbm_event_queue_is_empty(void) {
  mutex_lock(&lbm_events_mutex);
  bool empty = false;
  if (lbm_events_head == lbm_events_tail && !lbm_events_full) {
    empty = true;
  }
  mutex_unlock(&lbm_events_mutex);
  return empty;
}

static bool              eval_running = false;
static volatile bool     blocking_extension = false;
static mutex_t           blocking_extension_mutex;
static bool              blocking_extension_mutex_initialized = false;
static lbm_uint          blocking_extension_timeout_us = 0;
static bool              blocking_extension_timeout = false;

static bool              is_atomic = false;

/* Process queues */
static eval_context_queue_t blocked  = {NULL, NULL};
static eval_context_queue_t queue    = {NULL, NULL};

/* one mutex for all queue operations */
mutex_t qmutex;
bool    qmutex_initialized = false;


// MODES
static volatile bool lbm_verbose = false;

void lbm_toggle_verbose(void) {
  lbm_verbose = !lbm_verbose;
}

void lbm_set_verbose(bool verbose) {
  lbm_verbose = verbose;
}

lbm_cid lbm_get_current_cid(void) {
  if (ctx_running)
    return ctx_running->id;
  else
    return -1;
}

eval_context_t *lbm_get_current_context(void) {
  return ctx_running;
}

/****************************************************/
/* Utilities used locally in this file              */

static inline lbm_array_header_t *assume_array(lbm_value a){
  return (lbm_array_header_t*)lbm_ref_cell(a)->car;
}

static lbm_value cons_with_gc(lbm_value head, lbm_value tail, lbm_value remember) {
#ifdef LBM_ALWAYS_GC
  lbm_value always_gc_roots[3] = {head, tail, remember};
  lbm_gc_mark_roots(always_gc_roots,3);
  gc();
#endif
  lbm_value res = lbm_heap_state.freelist;
  if (lbm_is_symbol_nil(res)) {
    lbm_value roots[3] = {head, tail, remember};
    lbm_gc_mark_roots(roots,3);
    gc();
    res = lbm_heap_state.freelist;
    if (lbm_is_symbol_nil(res)) {
      error_ctx(ENC_SYM_MERROR);
    }
  }
  lbm_uint heap_ix = lbm_dec_ptr(res);
  lbm_heap_state.freelist = lbm_heap_state.heap[heap_ix].cdr;
  lbm_heap_state.num_alloc++;
  lbm_heap_state.heap[heap_ix].car = head;
  lbm_heap_state.heap[heap_ix].cdr = tail;
  res = lbm_set_ptr_type(res, LBM_TYPE_CONS);
  return res;
}

static lbm_uint *get_stack_ptr(eval_context_t *ctx, unsigned int n) {
  if (n <= ctx->K.sp) {
    lbm_uint index = ctx->K.sp - n;
    return &ctx->K.data[index];
  }
  error_ctx(ENC_SYM_STACK_ERROR);
  return 0; // dead code cannot be reached, but C compiler doesn't realise.
}

// pop_stack_ptr is safe when no GC is performed and
// the values of the stack will be dropped.
static lbm_uint *pop_stack_ptr(eval_context_t *ctx, unsigned int n) {
  if (n <= ctx->K.sp) {
    ctx->K.sp -= n;
    return &ctx->K.data[ctx->K.sp];
  }
  error_ctx(ENC_SYM_STACK_ERROR);
  return 0; // dead code cannot be reached, but C compiler doesn't realise.
}

static inline lbm_uint *stack_reserve(eval_context_t *ctx, unsigned int n) {
  if (ctx->K.sp + n < ctx->K.size) {
    lbm_uint *ptr = &ctx->K.data[ctx->K.sp];
    ctx->K.sp += n;
    return ptr;
  }
  error_ctx(ENC_SYM_STACK_ERROR);
  return 0; // dead code cannot be reached, but C compiler doesn't realise.
}

static void handle_flash_status(lbm_flash_status s) {
  if ( s == LBM_FLASH_FULL) {
    lbm_set_error_reason((char*)lbm_error_str_flash_full);
    error_ctx(ENC_SYM_EERROR);
  }
  if (s == LBM_FLASH_WRITE_ERROR) {
    lbm_set_error_reason((char*)lbm_error_str_flash_error);
    error_ctx(ENC_SYM_FATAL_ERROR);
  }
}

static void lift_array_flash(lbm_value flash_cell, bool bytearray,  char *data, lbm_uint num_elt) {

  lbm_array_header_t flash_array_header;
  flash_array_header.size = num_elt;
  flash_array_header.data = (lbm_uint*)data;
  lbm_uint flash_array_header_ptr = 0;
  handle_flash_status(lbm_write_const_raw((lbm_uint*)&flash_array_header,
                                          sizeof(lbm_array_header_t) / sizeof(lbm_uint),
                                          &flash_array_header_ptr));
  handle_flash_status(write_const_car(flash_cell, flash_array_header_ptr));
  lbm_uint t = bytearray ? ENC_SYM_ARRAY_TYPE : ENC_SYM_LISPARRAY_TYPE;
  handle_flash_status(write_const_cdr(flash_cell, t));
}

static void get_car_and_cdr(lbm_value a, lbm_value *a_car, lbm_value *a_cdr) {
  if (lbm_is_ptr(a)) {
    lbm_cons_t *cell = lbm_ref_cell(a);
    *a_car = cell->car;
    *a_cdr = cell->cdr;
  } else if (lbm_is_symbol_nil(a)) {
    *a_car = *a_cdr = ENC_SYM_NIL;
  } else {
    *a_car = *a_cdr = ENC_SYM_NIL;
    error_ctx(ENC_SYM_TERROR);
  }
}

/* car cdr caar cadr replacements that are evaluator safe. */
static lbm_value get_car(lbm_value a) {
  if (lbm_is_ptr(a)) {
    lbm_cons_t *cell = lbm_ref_cell(a);
    return cell->car;
  } else if (lbm_is_symbol_nil(a)) {
    return a;
  }
  error_ctx(ENC_SYM_TERROR);
  return(ENC_SYM_TERROR);
}

static lbm_value get_cdr(lbm_value a) {
  if (lbm_is_ptr(a)) {
    lbm_cons_t *cell = lbm_ref_cell(a);
    return cell->cdr;
  } else if (lbm_is_symbol_nil(a)) {
    return a;
  }
  error_ctx(ENC_SYM_TERROR);
  return(ENC_SYM_TERROR);
}

static lbm_value get_cadr(lbm_value a) {
  if (lbm_is_ptr(a)) {
    lbm_cons_t *cell = lbm_ref_cell(a);
    lbm_value tmp = cell->cdr;
    if (lbm_is_ptr(tmp)) {
      return lbm_ref_cell(tmp)->car;
    } else if (lbm_is_symbol_nil(tmp)) {
      return tmp;
    }
  } else if (lbm_is_symbol_nil(a)) {
    return a;
  }
  error_ctx(ENC_SYM_TERROR);
  return(ENC_SYM_TERROR);
}

static lbm_value allocate_closure(lbm_value params, lbm_value body, lbm_value env) {

#ifdef LBM_ALWAYS_GC
  gc();
  if (lbm_heap_num_free() < 4) {
    error_ctx(ENC_SYM_MERROR);
  }
#else
  if (lbm_heap_num_free() < 4) {
    gc();
    if (lbm_heap_num_free() < 4) {
      error_ctx(ENC_SYM_MERROR);
    }
  }
#endif
  // The freelist will always contain just plain heap-cells.
  // So dec_ptr is sufficient.
  lbm_value res = lbm_heap_state.freelist;
  if (lbm_type_of(res) == LBM_TYPE_CONS) {
    lbm_cons_t *heap = lbm_heap_state.heap;
    lbm_uint ix = lbm_dec_ptr(res);
    heap[ix].car = ENC_SYM_CLOSURE;
    ix = lbm_dec_ptr(heap[ix].cdr);
    heap[ix].car = params;
    ix = lbm_dec_ptr(heap[ix].cdr);
    heap[ix].car = body;
    ix = lbm_dec_ptr(heap[ix].cdr);
    heap[ix].car = env;
    lbm_heap_state.freelist = heap[ix].cdr;
    heap[ix].cdr = ENC_SYM_NIL;
    lbm_heap_state.num_alloc+=4;
  } else {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }
  return res;
}

// Allocate a binding and attach it to a list (if so desired)
static lbm_value allocate_binding(lbm_value key, lbm_value val, lbm_value the_cdr) {
#ifdef LBM_ALWAYS_GC
  lbm_gc_mark_phase(key);
  lbm_gc_mark_phase(val);
  lbm_gc_mark_phase(the_cdr);
  gc();
  if (lbm_heap_num_free() < 2) {
    error_ctx(ENC_SYM_MERROR);
  }
#else
  if (lbm_heap_num_free() < 2) {
    lbm_gc_mark_phase(key);
    lbm_gc_mark_phase(val);
    lbm_gc_mark_phase(the_cdr);
    gc();
    if (lbm_heap_num_free() < 2) {
      error_ctx(ENC_SYM_MERROR);
    }
  }
#endif
  lbm_cons_t* heap = lbm_heap_state.heap;
  lbm_value binding_cell = lbm_heap_state.freelist;
  lbm_uint binding_cell_ix = lbm_dec_ptr(binding_cell);
  lbm_value list_cell = heap[binding_cell_ix].cdr;
  lbm_uint list_cell_ix = lbm_dec_ptr(list_cell);
  lbm_heap_state.freelist = heap[list_cell_ix].cdr;
  lbm_heap_state.num_alloc += 2;
  heap[binding_cell_ix].car = key;
  heap[binding_cell_ix].cdr = val;
  heap[list_cell_ix].car = binding_cell;
  heap[list_cell_ix].cdr = the_cdr;
  return list_cell;
}

#define CLO_PARAMS 0
#define CLO_BODY   1
#define CLO_ENV    2
#define LOOP_BINDS 0
#define LOOP_COND  1
#define LOOP_BODY  2

// (a b c) -> [a b c]
static lbm_value extract_n(lbm_value curr, lbm_value *res, unsigned int n) {
  for (unsigned int i = 0; i < n; i ++) {
    if (lbm_is_ptr(curr)) {
      lbm_cons_t *cell = lbm_ref_cell(curr);
      res[i] = cell->car;
      curr = cell->cdr;
    } else {
      res[i] = ENC_SYM_NIL;
    }
  }
  return curr; // Rest of list is returned here.
}

static void call_fundamental(lbm_uint fundamental, lbm_value *args, lbm_uint arg_count, eval_context_t *ctx) {
  lbm_value res;
#ifdef LBM_ALWAYS_GC
  gc();
#endif
  res = fundamental_table[fundamental](args, arg_count, ctx);
  if (lbm_is_error(res)) {
    if (lbm_is_symbol_merror(res)) {
      gc();
      res = fundamental_table[fundamental](args, arg_count, ctx);
    }
    if (lbm_is_error(res)) {
      error_at_ctx(res, lbm_enc_sym(FUNDAMENTAL_SYMBOLS_START | fundamental));
    }
  }
  lbm_stack_drop(&ctx->K, arg_count+1);
  ctx->app_cont = true;
  ctx->r = res;
}

static void atomic_error(void) {
  is_atomic = false;
  lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
  error_ctx(ENC_SYM_EERROR);
}

// block_current_ctx blocks a context until it is
// woken up externally or a timeout period of time passes.
// Blocking while in an atomic block would have bad consequences.
static void block_current_ctx(uint32_t state, lbm_uint sleep_us,  bool do_cont) {
  if (is_atomic) atomic_error();
  ctx_running->timestamp = timestamp_us_callback();
  ctx_running->sleep_us = sleep_us;
  ctx_running->state  = state;
  ctx_running->app_cont = do_cont;
  enqueue_ctx(&blocked, ctx_running);
  ctx_running = NULL;
}

lbm_flash_status lbm_write_const_array_padded(uint8_t *data, lbm_uint n, lbm_uint *res) {
  lbm_uint full_words = n / sizeof(lbm_uint);
  lbm_uint n_mod = n % sizeof(lbm_uint);

  if (n_mod == 0) { // perfect fit.
    return lbm_write_const_raw((lbm_uint*)data, full_words, res);
  } else {
    lbm_uint last_word = 0;
    memcpy(&last_word, &data[full_words * sizeof(lbm_uint)], n_mod);
    if (full_words >= 1) {
      lbm_flash_status s = lbm_write_const_raw((lbm_uint*)data, full_words, res);
      if ( s == LBM_FLASH_WRITE_OK) {
        lbm_uint dummy;
        s = lbm_write_const_raw(&last_word, 1, &dummy);
      }
      return s;
    } else {
      return lbm_write_const_raw(&last_word, 1, res);
    }
  }
}

/****************************************************/
/* Error message creation                           */

#define ERROR_MESSAGE_BUFFER_SIZE_BYTES 256

void print_environments(char *buf, unsigned int size) {

  lbm_value curr_l = ctx_running->curr_env;
  printf_callback("\tCurrent local environment:\n");
  while (lbm_type_of(curr_l) == LBM_TYPE_CONS) {
    lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_l));
    lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_l)));
    printf_callback("\t%s = %s\n", buf, buf+(size/2));
    curr_l = lbm_cdr(curr_l);
  }
  printf_callback("\n\n");
  printf_callback("\tCurrent global environment:\n");
  lbm_value *glob_env = lbm_get_global_env();

  for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
    lbm_value curr_g = glob_env[i];;
    while (lbm_type_of(curr_g) == LBM_TYPE_CONS) {

      lbm_print_value(buf, (size/2) - 1, lbm_caar(curr_g));
      lbm_print_value(buf + (size/2),size/2, lbm_cdr(lbm_car(curr_g)));
      printf_callback("\t%s = %s\n", buf, buf+(size/2));
      curr_g = lbm_cdr(curr_g);
    }
  }
}

void print_error_value(char *buf, lbm_uint bufsize, char *pre, lbm_value v, bool lookup) {

  lbm_print_value(buf, bufsize, v);
  printf_callback("%s %s\n",pre, buf);
  if (lookup) {
    if (lbm_is_symbol(v)) {
      if (lbm_dec_sym(v) >= RUNTIME_SYMBOLS_START) {
	lbm_value res = ENC_SYM_NIL;
	if (lbm_env_lookup_b(&res, v, ctx_running->curr_env) ||
	    lbm_global_env_lookup(&res, v)) {
	  lbm_print_value(buf, bufsize, res);
	  printf_callback("      bound to: %s\n", buf);
	} else {
	  printf_callback("      UNDEFINED\n");
	}
      }
    }
  }
}

void print_error_message(lbm_value error,
                         bool has_at,
                         lbm_value at,
                         unsigned int row,
                         unsigned int col,
                         lbm_int row0,
                         lbm_int row1,
                         lbm_int cid,
                         char *name) {
  /* try to allocate a lbm_print_value buffer on the lbm_memory */
  char *buf = lbm_malloc_reserve(ERROR_MESSAGE_BUFFER_SIZE_BYTES);
  if (!buf) {
    printf_callback("Error: Not enough free memory to create a human readable error message\n");
    return;
  }

  print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES,"   Error:", error, false);
  if (name) {
    printf_callback(  "   CTX: %d \"%s\"\n", cid, name);
  } else {
    printf_callback(  "   CTX: %d\n", cid);
  }
  print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES,"   Current:", ctx_running->curr_exp, true);
  if (lbm_error_has_suspect) {
      print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES,"   At:", lbm_error_suspect, true);
      lbm_error_has_suspect = false;
  } else if (has_at) {
    print_error_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES,"   In:", at, true);
  }

  printf_callback("\n");

  if (lbm_is_symbol(error) &&
      error == ENC_SYM_RERROR) {
    printf_callback("   Line:   %u\n", row);
    printf_callback("   Column: %u\n", col);
  } else if (row0 >= 0) {
    if (row1 < 0) printf_callback("   Starting at row: %d\n", row0);
    else printf_callback("   Between row %d and %d\n", row0, row1);
  }

  printf_callback("\n");

  if (ctx_running->error_reason) {
    printf_callback("   Reason: %s\n\n", ctx_running->error_reason);
  }
  if (lbm_verbose) {
    lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->r);
    printf_callback("   Current intermediate result: %s\n\n", buf);

    print_environments(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES);
    printf_callback("\n\n");

    printf_callback("   Stack:\n");
    for (unsigned int i = 0; i < ctx_running->K.sp; i ++) {
      lbm_print_value(buf, ERROR_MESSAGE_BUFFER_SIZE_BYTES, ctx_running->K.data[i]);
      printf_callback("     %s\n", buf);
    }
  }
  lbm_free(buf);
}

/****************************************************/
/* Tokenizing and parsing                           */

bool create_string_channel(char *str, lbm_value *res, lbm_value dep) {

  lbm_char_channel_t *chan = NULL;
  lbm_string_channel_state_t *st = NULL;

  st = (lbm_string_channel_state_t*)lbm_malloc(sizeof(lbm_string_channel_state_t));
  if (st == NULL) {
    return false;
  }
  chan = (lbm_char_channel_t*)lbm_malloc(sizeof(lbm_char_channel_t));
  if (chan == NULL) {
    lbm_free(st);
    return false;
  }

  lbm_create_string_char_channel(st, chan, str);
  lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE);
  if (cell == ENC_SYM_MERROR) {
    lbm_free(st);
    lbm_free(chan);
    return false;
  }

  lbm_char_channel_set_dependency(chan, dep);

  *res = cell;
  return true;
}

bool lift_char_channel(lbm_char_channel_t *chan , lbm_value *res) {
  lbm_value cell = lbm_heap_allocate_cell(LBM_TYPE_CHANNEL, (lbm_uint) chan, ENC_SYM_CHANNEL_TYPE);
  if (cell == ENC_SYM_MERROR) {
    return false;
  }
  *res = cell;
  return true;
}


/****************************************************/
/* Queue functions                                  */

static void queue_iterator_nm(eval_context_queue_t *q, ctx_fun f, void *arg1, void *arg2) {
  eval_context_t *curr;
  curr = q->first;

  while (curr != NULL) {
    f(curr, arg1, arg2);
    curr = curr->next;
  }
}

void lbm_all_ctxs_iterator(ctx_fun f, void *arg1, void *arg2) {
  mutex_lock(&qmutex);
  queue_iterator_nm(&blocked, f, arg1, arg2);
  queue_iterator_nm(&queue, f, arg1, arg2);
  if (ctx_running) f(ctx_running, arg1, arg2);
  mutex_unlock(&qmutex);
}

void lbm_running_iterator(ctx_fun f, void *arg1, void *arg2){
  mutex_lock(&qmutex);
  queue_iterator_nm(&queue, f, arg1, arg2);
  mutex_unlock(&qmutex);
}

void lbm_blocked_iterator(ctx_fun f, void *arg1, void *arg2){
  mutex_lock(&qmutex);
  queue_iterator_nm(&blocked, f, arg1, arg2);
  mutex_unlock(&qmutex);
}

static void enqueue_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {
  if (q->last == NULL) {
    ctx->prev = NULL;
    ctx->next = NULL;
    q->first = ctx;
    q->last  = ctx;
  } else {
    ctx->prev = q->last;
    ctx->next = NULL;
    q->last->next = ctx;
    q->last = ctx;
  }
}

static void enqueue_ctx(eval_context_queue_t *q, eval_context_t *ctx) {
  mutex_lock(&qmutex);
  enqueue_ctx_nm(q,ctx);
  mutex_unlock(&qmutex);
}

static eval_context_t *lookup_ctx_nm(eval_context_queue_t *q, lbm_cid cid) {
  eval_context_t *curr;
  curr = q->first;
  while (curr != NULL) {
    if (curr->id == cid) {
      return curr;
    }
    curr = curr->next;
  }
  return NULL;
}

static bool drop_ctx_nm(eval_context_queue_t *q, eval_context_t *ctx) {

  bool res = false;
  if (q->first == NULL || q->last == NULL) {
    if (!(q->last == NULL && q->first == NULL)) {
      /* error state that should not happen */
      return res;
    }
    /* Queue is empty */
    return res;
  }

  eval_context_t *curr = q->first;
  while (curr) {
    if (curr->id == ctx->id) {
      res = true;
      eval_context_t *tmp = curr->next;
      if (curr->prev == NULL) {
        if (curr->next == NULL) {
          q->last = NULL;
          q->first = NULL;
        } else {
          q->first = tmp;
          tmp->prev = NULL;
        }
      } else { /* curr->prev != NULL */
        if (curr->next == NULL) {
          q->last = curr->prev;
          q->last->next = NULL;
        } else {
          curr->prev->next = tmp;
          tmp->prev = curr->prev;
        }
      }
      break;
    }
    curr = curr->next;
  }
  return res;
}

/* End execution of the running context. */
static void finish_ctx(void) {

  if (!ctx_running) {
    return;
  }
  /* Drop the continuation stack immediately to free up lbm_memory */
  lbm_stack_free(&ctx_running->K);
  ctx_done_callback(ctx_running);

  lbm_free(ctx_running->name); //free name if in LBM_MEM
  lbm_memory_free((lbm_uint*)ctx_running->error_reason); //free error_reason if in LBM_MEM

  lbm_memory_free((lbm_uint*)ctx_running->mailbox);
  lbm_memory_free((lbm_uint*)ctx_running);
  ctx_running = NULL;
}

static void context_exists(eval_context_t *ctx, void *cid, void *b) {
  if (ctx->id == *(lbm_cid*)cid) {
    *(bool*)b = true;
  }
}

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

// Not possible to CONS_WITH_GC in error_ctx_base (potential loop)
static void error_ctx_base(lbm_value err_val, bool has_at, lbm_value at, unsigned int row, unsigned int column) {

  if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
    if (lbm_heap_num_free() < 3) {
      gc();
    }

    if (lbm_heap_num_free() >= 3) {
      lbm_value msg = lbm_cons(err_val, ENC_SYM_NIL);
      msg = lbm_cons(lbm_enc_i(ctx_running->id), msg);
      msg = lbm_cons(ENC_SYM_EXIT_ERROR, msg);
      if (!lbm_is_symbol_merror(msg)) {
        lbm_find_receiver_and_send(ctx_running->parent, msg);
        goto error_ctx_base_done;
      }
    }
  }
  if ((ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN) &&
      (err_val != ENC_SYM_FATAL_ERROR)) {
    lbm_uint v;
    while (ctx_running->K.sp > 0) {
      lbm_pop(&ctx_running->K, &v);
      if (v == EXCEPTION_HANDLER) {
        lbm_value *sptr = get_stack_ptr(ctx_running, 2);
        lbm_set_car(sptr[0], ENC_SYM_EXIT_ERROR);
        stack_reserve(ctx_running, 1)[0] = EXCEPTION_HANDLER;
        ctx_running->app_cont = true;
        ctx_running->r = err_val;
        longjmp(error_jmp_buf, 1);
      }
    }
    err_val = ENC_SYM_FATAL_ERROR;
  }
  print_error_message(err_val,
                      has_at,
                      at,
                      row,
                      column,
                      ctx_running->row0,
                      ctx_running->row1,
                      ctx_running->id,
                      ctx_running->name);
 error_ctx_base_done:
  ctx_running->r = err_val;
  finish_ctx();
  longjmp(error_jmp_buf, 1);
}

static void error_at_ctx(lbm_value err_val, lbm_value at) {
  error_ctx_base(err_val, true, at, 0, 0);
}

static void error_ctx(lbm_value err_val) {
  error_ctx_base(err_val, false, 0, 0, 0);
}

static void read_error_ctx(unsigned int row, unsigned int column) {
  error_ctx_base(ENC_SYM_RERROR, false, 0, row, column);
}

void lbm_critical_error(void) {
  longjmp(critical_error_jmp_buf, 1);
}

// successfully finish a context
static void ok_ctx(void) {
  if (ctx_running->flags & EVAL_CPS_CONTEXT_FLAG_TRAP) {
    lbm_value msg;
    WITH_GC(msg, lbm_heap_allocate_list_init(3,
                                             ENC_SYM_EXIT_OK,
                                             lbm_enc_i(ctx_running->id),
                                             ctx_running->r));
    lbm_find_receiver_and_send(ctx_running->parent, msg);
  }
  finish_ctx();
}

static eval_context_t *dequeue_ctx_nm(eval_context_queue_t *q) {
  if (q->last == NULL) {
    return NULL;
  }
  // q->first should only be NULL if q->last is.
  eval_context_t *res = q->first;

  if (q->first == q->last) { // One thing in queue
    q->first = NULL;
    q->last  = NULL;
   } else {
    q->first = q->first->next;
    q->first->prev = NULL;
  }
  res->prev = NULL;
  res->next = NULL;
  return res;
}

static void wake_up_ctxs_nm(void) {
  lbm_uint t_now;

  if (timestamp_us_callback) {
    t_now = timestamp_us_callback();
  } else {
    t_now = 0;
  }

  eval_context_queue_t *q = &blocked;
  eval_context_t *curr = q->first;

  while (curr != NULL) {
    lbm_uint t_diff;
    eval_context_t *next = curr->next;
    if (LBM_IS_STATE_WAKE_UP_WAKABLE(curr->state)) {
      if ( curr->timestamp > t_now) {
        /* There was an overflow on the counter */
#ifndef LBM64
        t_diff = (0xFFFFFFFF - curr->timestamp) + t_now;
#else
        t_diff = (0xFFFFFFFFFFFFFFFF - curr->timestamp) + t_now;
#endif
      } else {
        t_diff = t_now - curr->timestamp;
      }

      if (t_diff >= curr->sleep_us) {
        eval_context_t *wake_ctx = curr;
        if (curr == q->last) {
          if (curr->prev) {
            q->last = curr->prev;
            q->last->next = NULL;
          } else {
            q->first = NULL;
            q->last = NULL;
          }
        } else if (curr->prev == NULL) {
          q->first = curr->next;
          q->first->prev = NULL;
        } else {
          curr->prev->next = curr->next;
          if (curr->next) {
            curr->next->prev = curr->prev;
          }
        }
        wake_ctx->next = NULL;
        wake_ctx->prev = NULL;
        if (LBM_IS_STATE_TIMEOUT(curr->state)) {
          mailbox_add_mail(wake_ctx, ENC_SYM_TIMEOUT);
          wake_ctx->r = ENC_SYM_TIMEOUT;
        }
        wake_ctx->state = LBM_THREAD_STATE_READY;
        enqueue_ctx_nm(&queue, wake_ctx);
      }
    }
    curr = next;
  }
}

static void yield_ctx(lbm_uint sleep_us) {
  if (is_atomic) atomic_error();
  if (timestamp_us_callback) {
    ctx_running->timestamp = timestamp_us_callback();
    ctx_running->sleep_us = sleep_us;
    ctx_running->state = LBM_THREAD_STATE_SLEEPING;
  } else {
    ctx_running->timestamp = 0;
    ctx_running->sleep_us = 0;
    ctx_running->state = LBM_THREAD_STATE_SLEEPING;
  }
  ctx_running->r = ENC_SYM_TRUE;
  ctx_running->app_cont = true;
  enqueue_ctx(&blocked,ctx_running);
  ctx_running = NULL;
}

static lbm_cid lbm_create_ctx_parent(lbm_value program, lbm_value env, lbm_uint stack_size, lbm_cid parent, uint32_t context_flags, char *name) {

  if (!lbm_is_cons(program)) return -1;

  eval_context_t *ctx = NULL;
#ifdef LBM_ALWAYS_GC
  {
    lbm_uint roots[2] = {program, env};
    lbm_gc_mark_roots(roots, 2);
    gc();
  }
#endif
  ctx = (eval_context_t*)lbm_malloc(sizeof(eval_context_t));
  if (ctx == NULL) {
    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;
#ifdef LBM_ALWAYS_GC
  {
    lbm_uint roots[2] = {program, env};
    lbm_gc_mark_roots(roots, 2);
    gc();
  }
#endif
  if (!lbm_stack_allocate(&ctx->K, stack_size)) {
    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);
      return -1;
    }
  }

  lbm_value *mailbox = NULL;
#ifdef LBM_ALWAYS_GC
  {
    lbm_uint roots[2] = {program, env};
    lbm_gc_mark_roots(roots, 2);
    gc();
  }
#endif
  mailbox = (lbm_value*)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
  if (mailbox == NULL) {
    lbm_value roots[2] = {program, env};
    lbm_gc_mark_roots(roots,2);
    gc();
    mailbox = (lbm_value *)lbm_memory_allocate(EVAL_CPS_DEFAULT_MAILBOX_SIZE);
  }
  if (mailbox == NULL) {
    lbm_stack_free(&ctx->K);
    lbm_memory_free((lbm_uint*)ctx);
    return -1;
  }

  // TODO: Limit names to 19 chars + 1 char for 0? (or something similar).
  if (name) {
    lbm_uint name_len = strlen(name) + 1;
#ifdef LBM_ALWAYS_GC
    {
      lbm_uint roots[2] = {program, env};
      lbm_gc_mark_roots(roots, 2);
      gc();
    }
#endif
    ctx->name = lbm_malloc(name_len);
    if (ctx->name == NULL) {
      lbm_value roots[2] = {program, env};
      lbm_gc_mark_roots(roots, 2);
      gc();
      ctx->name = lbm_malloc(name_len);
    }
    if (ctx->name == NULL) {
      lbm_stack_free(&ctx->K);
      lbm_memory_free((lbm_uint*)mailbox);
      lbm_memory_free((lbm_uint*)ctx);
      return -1;
    }
    memcpy(ctx->name, name, name_len);
  } else {
     ctx->name = NULL;
  }

  lbm_int cid = lbm_memory_address_to_ix((lbm_uint*)ctx);

  ctx->program = lbm_cdr(program);
  ctx->curr_exp = lbm_car(program);
  ctx->curr_env = env;
  ctx->r = ENC_SYM_NIL;
  ctx->error_reason = NULL;
  ctx->mailbox = mailbox;
  ctx->mailbox_size = EVAL_CPS_DEFAULT_MAILBOX_SIZE;
  ctx->flags = context_flags;
  ctx->num_mail = 0;
  ctx->app_cont = false;
  ctx->timestamp = 0;
  ctx->sleep_us = 0;
  ctx->state = LBM_THREAD_STATE_READY;
  ctx->prev = NULL;
  ctx->next = NULL;

  ctx->row0 = -1;
  ctx->row1 = -1;

  ctx->id = cid;
  ctx->parent = parent;

  if (!lbm_push(&ctx->K, DONE)) {
    lbm_memory_free((lbm_uint*)ctx->mailbox);
    lbm_stack_free(&ctx->K);
    lbm_memory_free((lbm_uint*)ctx);
    return -1;
  }

  enqueue_ctx(&queue,ctx);

  return ctx->id;
}

lbm_cid lbm_create_ctx(lbm_value program, lbm_value env, lbm_uint stack_size, char *name) {
  // Creates a parentless context.
  return lbm_create_ctx_parent(program,
                               env,
                               stack_size,
                               -1,
                               EVAL_CPS_CONTEXT_FLAG_NOTHING,
                               name);
}

bool lbm_mailbox_change_size(eval_context_t *ctx, lbm_uint new_size) {

  lbm_value *mailbox = NULL;
#ifdef LBM_ALWAYS_GC
  gc();
#endif
  mailbox = (lbm_value*)lbm_memory_allocate(new_size);
  if (mailbox == NULL) {
    gc();
    mailbox = (lbm_value *)lbm_memory_allocate(new_size);
  }
  if (mailbox == NULL) {
    return false;
  }

  for (lbm_uint i = 0; i < ctx->num_mail; i ++ ) {
    mailbox[i] = ctx->mailbox[i];
  }
  lbm_memory_free(ctx->mailbox);
  ctx->mailbox = mailbox;
  ctx->mailbox_size = (uint32_t)new_size;
  return true;
}

static void mailbox_remove_mail(eval_context_t *ctx, lbm_uint ix) {

  for (lbm_uint i = ix; i < ctx->num_mail-1; i ++) {
    ctx->mailbox[i] = ctx->mailbox[i+1];
  }
  ctx->num_mail --;
}

static bool mailbox_add_mail(eval_context_t *ctx, lbm_value mail) {

  if (ctx->num_mail >= ctx->mailbox_size) {
    mailbox_remove_mail(ctx, 0);
  }

  ctx->mailbox[ctx->num_mail] = mail;
  ctx->num_mail ++;
  return true;
}

/**************************************************************
 * Advance execution to the next expression in the program.
 * Assumes programs are not malformed. Apply_eval_program
 * ensures programs are lists ending in nil. The reader
 * ensures this likewise.
 *************************************************************/
static void advance_ctx(eval_context_t *ctx) {
  if (ctx->program) { // fast not-nil check,  assume cons if not nil.
    stack_reserve(ctx, 1)[0] = DONE;
    lbm_cons_t *cell = lbm_ref_cell(ctx->program);
    ctx->curr_exp = cell->car;
    ctx->program = cell->cdr;
    ctx->curr_env = ENC_SYM_NIL;
  } else {
    if (ctx_running == ctx) {  // This should always be the case because of odd historical reasons.
      ok_ctx();
    }
  }
}

bool lbm_unblock_ctx(lbm_cid cid, lbm_flat_value_t *fv) {
  return event_internal(LBM_EVENT_UNBLOCK_CTX, (lbm_uint)cid, (lbm_uint)fv->buf, fv->buf_size);
}

bool lbm_unblock_ctx_r(lbm_cid cid) {
  mutex_lock(&blocking_extension_mutex);
  bool r = false;
  eval_context_t *found = NULL;
  mutex_lock(&qmutex);
  found = lookup_ctx_nm(&blocked, cid);
  if (found && (LBM_IS_STATE_UNBLOCKABLE(found->state))) {
    drop_ctx_nm(&blocked,found);
    found->state = LBM_THREAD_STATE_READY;
    enqueue_ctx_nm(&queue,found);
    r = true;
  }
  mutex_unlock(&qmutex);
  mutex_unlock(&blocking_extension_mutex);
  return r;
}

// unblock unboxed is also safe for rmbr:ed things.
bool lbm_unblock_ctx_unboxed(lbm_cid cid, lbm_value unboxed) {
  mutex_lock(&blocking_extension_mutex);
  bool r = false;
  eval_context_t *found = NULL;
  mutex_lock(&qmutex);
  found = lookup_ctx_nm(&blocked, cid);
  if (found && (LBM_IS_STATE_UNBLOCKABLE(found->state))) {
    drop_ctx_nm(&blocked,found);
    found->r = unboxed;
    if (lbm_is_error(unboxed)) {
      get_stack_ptr(found, 1)[0] = TERMINATE; // replace TOS
      found->app_cont = true;
    }
    found->state = LBM_THREAD_STATE_READY;
    enqueue_ctx_nm(&queue,found);
    r = true;
  }
  mutex_unlock(&qmutex);
  mutex_unlock(&blocking_extension_mutex);
  return r;
}

static bool lbm_block_ctx_base(bool timeout, float t_s) {
  mutex_lock(&blocking_extension_mutex);
  blocking_extension = true;
  if (timeout) {
    blocking_extension_timeout_us = S_TO_US(t_s);
    blocking_extension_timeout = true;
  } else {
    blocking_extension_timeout = false;
  }
  return true;
}

void lbm_block_ctx_from_extension_timeout(float s) {
  lbm_block_ctx_base(true, s);
}

void lbm_block_ctx_from_extension(void) {
  lbm_block_ctx_base(false, 0);
}

// todo: May need to pop rmbrs from stack, if present.
// Suspect that the letting the discard cont run is really not a problem.
// Either way will be quite confusing what happens to allocated things when undoing block.
void lbm_undo_block_ctx_from_extension(void) {
  blocking_extension = false;
  blocking_extension_timeout_us = 0;
  blocking_extension_timeout = false;
  mutex_unlock(&blocking_extension_mutex);
}

#define LBM_RECEIVER_FOUND 0
#define LBM_RECEIVER_FOUND_MAIL_DELIVERY_FAILED -1
#define LBM_RECEIVER_NOT_FOUND -2

int lbm_find_receiver_and_send(lbm_cid cid, lbm_value msg) {
  mutex_lock(&qmutex);
  eval_context_t *found = NULL;

  found = lookup_ctx_nm(&blocked, cid);
  if (found) {
    if (LBM_IS_STATE_RECV(found->state)) { // only if unblock receivers here.
      drop_ctx_nm(&blocked,found);
      found->state = LBM_THREAD_STATE_READY;
      enqueue_ctx_nm(&queue,found);
    }
    if (!mailbox_add_mail(found, msg)) {
      mutex_unlock(&qmutex);
      return LBM_RECEIVER_FOUND_MAIL_DELIVERY_FAILED;
    }
    mutex_unlock(&qmutex);
    return LBM_RECEIVER_FOUND;
  }

  found = lookup_ctx_nm(&queue, cid);
  if (found) {
    if (!mailbox_add_mail(found, msg)) {
      mutex_unlock(&qmutex);
      return LBM_RECEIVER_FOUND_MAIL_DELIVERY_FAILED;
    }
    mutex_unlock(&qmutex);
    return LBM_RECEIVER_FOUND;
  }

  /* check the current context */
  if (ctx_running && ctx_running->id == cid) {
    if (!mailbox_add_mail(ctx_running, msg)) {
      mutex_unlock(&qmutex);
      return LBM_RECEIVER_FOUND_MAIL_DELIVERY_FAILED;
    }
    mutex_unlock(&qmutex);
    return LBM_RECEIVER_FOUND;
  }
  mutex_unlock(&qmutex);
  return LBM_RECEIVER_NOT_FOUND;
}

// a match binder looks like (? x) or (? _) for example.
// It is a list of two elements where the first is a ? and the second is a symbol.
static inline lbm_value get_match_binder_variable(lbm_value exp) {
  lbm_value var = ENC_SYM_NIL; // 0 false
  if (lbm_is_cons(exp)) {
    lbm_cons_t *e_cell = lbm_ref_cell(exp);
    lbm_value bt = e_cell->car;
    if (bt == ENC_SYM_MATCH_ANY && lbm_is_cons(e_cell->cdr)) {
      var = lbm_ref_cell(e_cell->cdr)->car;
    }
  }
  return var;
}

/* Pattern matching is currently implemented as a recursive
   function and make use of stack relative to the size of
   expressions that are being matched. */
static bool match(lbm_value p, lbm_value e, lbm_value *env, bool *gc) {
  bool r = false;
  lbm_value var = get_match_binder_variable(p);
  if (var) {
    lbm_value binding = lbm_cons(var, e);
    if (lbm_is_cons(binding)) {
      lbm_value new_env = lbm_cons(binding, *env);
      if (lbm_is_cons(new_env)) {
        *env = new_env;
        r = true;
      }
    }
    *gc = !r;
  } else  if (lbm_is_symbol(p)) {
    if (p == ENC_SYM_DONTCARE) r = true;
    else r = (p == e);
  } else if (lbm_is_cons(p) && lbm_is_cons(e) ) {
    lbm_cons_t *p_cell = lbm_ref_cell(p);
    lbm_cons_t *e_cell = lbm_ref_cell(e);
    lbm_value headp = p_cell->car;
    lbm_value tailp = p_cell->cdr;
    lbm_value heade = e_cell->car;
    lbm_value taile = e_cell->cdr;
    r = match(headp, heade, env, gc);
    r = r && match (tailp, taile, env, gc);
  } else {
    r = struct_eq(p, e);
  }
  return r;
}

// Find match is not very picky about syntax.
// A completely malformed recv form is most likely to
// 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_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;
        *e = get_cadr(me);

        if (!lbm_is_symbol_nil(get_cadr(get_cdr(me)))) {
          return FM_PATTERN_ERROR;
        }
        return n;
      }
      curr_p = get_cdr(curr_p);
    }
    curr_p = plist;       /* search all patterns against next exp */
    n ++;
  }

  return FM_NO_MATCH;
}

/****************************************************/
/* Garbage collection                               */

static void mark_context(eval_context_t *ctx, void *arg1, void *arg2) {
  (void) arg1;
  (void) arg2;
  lbm_value roots[3] = {ctx->curr_exp, ctx->program, ctx->r };
  lbm_gc_mark_env(ctx->curr_env);
  lbm_gc_mark_roots(roots, 3);
  lbm_gc_mark_roots(ctx->mailbox, ctx->num_mail);
  lbm_gc_mark_aux(ctx->K.data, ctx->K.sp);
}

static int gc(void) {
  if (ctx_running) {
    ctx_running->state = ctx_running->state | LBM_THREAD_STATE_GC_BIT;
  }

  gc_requested = false;
  lbm_gc_state_inc();

  // The freelist should generally be NIL when GC runs.
  lbm_nil_freelist();
  lbm_value *env = lbm_get_global_env();
  for (int i = 0; i < GLOBAL_ENV_ROOTS; i ++) {
    lbm_gc_mark_env(env[i]);
  }

  mutex_lock(&qmutex); // Lock the queues.
                       // Any concurrent messing with the queues
                       // while doing GC cannot possibly be good.
  queue_iterator_nm(&queue, mark_context, NULL, NULL);
  queue_iterator_nm(&blocked, mark_context, NULL, NULL);

  if (ctx_running) {
    mark_context(ctx_running, NULL, NULL);
  }
  mutex_unlock(&qmutex);

#ifdef VISUALIZE_HEAP
  heap_vis_gen_image();
#endif

  int r = lbm_gc_sweep_phase();
  lbm_heap_new_freelist_length();
  lbm_memory_update_min_free();

  if (ctx_running) {
    ctx_running->state = ctx_running->state & ~LBM_THREAD_STATE_GC_BIT;
  }
  return r;
}

int lbm_perform_gc(void) {
  return gc();
}

/****************************************************/
/* Evaluation functions                             */


static void eval_symbol(eval_context_t *ctx) {
  lbm_uint s = lbm_dec_sym(ctx->curr_exp);
  if (s >= RUNTIME_SYMBOLS_START) {
    lbm_value res = ENC_SYM_NIL;
    if (lbm_env_lookup_b(&res, ctx->curr_exp, ctx->curr_env) ||
        lbm_global_env_lookup(&res, ctx->curr_exp)) {
      ctx->r =  res;
      ctx->app_cont = true;
      return;
    }
    // Dynamic load attempt
    // Only symbols of kind RUNTIME can be dynamically loaded.
    const char *sym_str = lbm_get_name_by_symbol(s);
    const char *code_str = NULL;
    if (!dynamic_load_callback(sym_str, &code_str)) {
      error_at_ctx(ENC_SYM_NOT_FOUND, ctx->curr_exp);
    }
    lbm_value *sptr = stack_reserve(ctx, 3);
    sptr[0] = ctx->curr_exp;
    sptr[1] = ctx->curr_env;
    sptr[2] = RESUME;

    lbm_value chan = ENC_SYM_NIL;
#ifdef LBM_ALWAYS_GC
    gc();
#endif
    if (!create_string_channel((char *)code_str, &chan, ENC_SYM_NIL)) {
      gc();
      if (!create_string_channel((char *)code_str, &chan, ENC_SYM_NIL)) {
        error_ctx(ENC_SYM_MERROR);
      }
    }

    // Here, chan has either been assigned or execution has terminated.

    lbm_value loader;
    WITH_GC_RMBR_1(loader, lbm_heap_allocate_list_init(2,
                                                       ENC_SYM_READ,
                                                       chan), chan);
    lbm_value evaluator;
    WITH_GC_RMBR_1(evaluator, lbm_heap_allocate_list_init(2,
                                                          ENC_SYM_EVAL,
                                                          loader), loader);
    ctx->curr_exp = evaluator;
    ctx->curr_env = ENC_SYM_NIL; // dynamics should be evaluable in empty local env
  } else {
    //special symbols and extensions can be handled the same way.
    ctx->r = ctx->curr_exp;
    ctx->app_cont = true;
  }
}

// (quote e) => e
static void eval_quote(eval_context_t *ctx) {
  ctx->r = get_cadr(ctx->curr_exp);
  ctx->app_cont = true;
}

// a => a
static void eval_selfevaluating(eval_context_t *ctx) {
  ctx->r = ctx->curr_exp;
  ctx->app_cont = true;
}

// (progn e1 ... en)
static void eval_progn(eval_context_t *ctx) {
  lbm_value exps = get_cdr(ctx->curr_exp);

  if (lbm_is_cons(exps)) {
    lbm_cons_t *cell = lbm_ref_cell(exps); // already checked that it's cons.
    ctx->curr_exp = cell->car;
    if (lbm_is_cons(cell->cdr)) { // malformed progn not ending in nil is tolerated
      lbm_uint *sptr = stack_reserve(ctx, 4);
      sptr[0] = ctx->curr_env; // env to restore between expressions in progn
      sptr[1] = lbm_enc_u(0);  // Has env been copied (needed for progn local bindings)
      sptr[2] = cell->cdr;     // Requirement: sptr[2] is a cons.
      sptr[3] = PROGN_REST;
    }
  } else if (lbm_is_symbol_nil(exps)) { // Empty progn is nil
    ctx->r = ENC_SYM_NIL;
    ctx->app_cont = true;
  } else {
    error_ctx(ENC_SYM_EERROR);
  }
}

// (atomic e1 ... en)
static void eval_atomic(eval_context_t *ctx) {
  if (is_atomic) atomic_error();
  stack_reserve(ctx, 1)[0] = EXIT_ATOMIC;
  is_atomic = true;
  eval_progn(ctx);
}

/* (call-cc (lambda (k) .... ))  */
static void eval_callcc(eval_context_t *ctx) {
  lbm_value cont_array;
  lbm_uint *sptr0 = stack_reserve(ctx, 1);
  sptr0[0] = is_atomic ? ENC_SYM_TRUE : ENC_SYM_NIL;
#ifdef LBM_ALWAYS_GC
  gc();
#endif
  if (!lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp)) {
    gc();
    lbm_heap_allocate_lisp_array(&cont_array, ctx->K.sp);
  }
  if (lbm_is_ptr(cont_array)) {
    lbm_array_header_t *arr = assume_array(cont_array);
    memcpy(arr->data, ctx->K.data, ctx->K.sp * sizeof(lbm_uint));
    // The stored stack contains the is_atomic flag.
    // This flag is overwritten in the following execution path.

    lbm_value acont = cons_with_gc(ENC_SYM_CONT, cont_array, ENC_SYM_NIL);
    lbm_value arg_list = cons_with_gc(acont, ENC_SYM_NIL, ENC_SYM_NIL);
    // Go directly into application evaluation without passing go
    lbm_uint *sptr = stack_reserve(ctx, 2);
    sptr0[0] = ctx->curr_env;
    sptr[0] = arg_list;
    sptr[1] = APPLICATION_START;
    ctx->curr_exp = get_cadr(ctx->curr_exp);
  } else {
    // failed to create continuation array.
    error_ctx(ENC_SYM_MERROR);
  }
}

// (define sym exp)
#define KEY 1
#define VAL 2
static void eval_define(eval_context_t *ctx) {
  lbm_value parts[3];
  lbm_value rest = extract_n(ctx->curr_exp, parts, 3);
  lbm_uint *sptr = stack_reserve(ctx, 2);
  if (lbm_is_symbol(parts[KEY]) && lbm_is_symbol_nil(rest)) {
    lbm_uint sym_val = lbm_dec_sym(parts[KEY]);
    sptr[0] = parts[KEY];
    if (sym_val >= RUNTIME_SYMBOLS_START) {
      sptr[1] = SET_GLOBAL_ENV;
      if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST) {
        stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
      }
      ctx->curr_exp = parts[VAL];
      return;
    }
  }
  error_at_ctx(ENC_SYM_EERROR, ctx->curr_exp);
}


/* Eval lambda is cheating, a lot! It does this
   for performance reasons. The cheats are that
   1. When  closure is created, a reference to the local env
   in which the lambda was evaluated is added to the closure.
   Ideally it should have created a list of free variables in the function
   and then looked up the values of these creating a new environment.
   2. The global env is considered global constant. As there is no copying
   of environment bindings into the closure, undefine may break closures.

   Correct closure creation is a lot more expensive than what happens here.
   However, one can try to write programs in such a way that closures are created
   seldomly. If one does that the space-usage benefits of "correct" closures
   may outweigh the performance gain of "incorrect" ones.

   some obscure programs such as test_setq_local_closure.lisp does not
   work properly due to this cheating.
 */
// (lambda param-list body-exp) -> (closure param-list body-exp env)
static void eval_lambda(eval_context_t *ctx) {
  lbm_value vals[3];
  extract_n(ctx->curr_exp, vals, 3);
  ctx->r = allocate_closure(vals[1],vals[2], ctx->curr_env);
#ifdef CLEAN_UP_CLOSURES
  lbm_uint sym_id  = 0;
  if (clean_cl_env_symbol) {
    lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
    lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
    ctx->curr_exp = app;
  } else if (lbm_get_symbol_by_name("clean-cl-env", &sym_id)) {
    clean_cl_env_symbol = lbm_enc_sym(sym_id);
    lbm_value tail = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
    lbm_value app = cons_with_gc(clean_cl_env_symbol, tail, tail);
    ctx->curr_exp = app;
  } else {
    ctx->app_cont = true;
  }
#else
  ctx->app_cont = true;
#endif
}

// (if cond-expr then-expr else-expr)
static void eval_if(eval_context_t *ctx) {
  lbm_value cdr = get_cdr(ctx->curr_exp);
  lbm_value *sptr = stack_reserve(ctx, 3);
  sptr[0] = get_cdr(cdr);
  sptr[1] = ctx->curr_env;
  sptr[2] = IF;
  ctx->curr_exp = get_car(cdr);
}

// (cond (cond-expr-1 expr-1)
//         ...
//       (cond-expr-N expr-N))
static void eval_cond(eval_context_t *ctx) {
  lbm_value cond1[2];
  lbm_value rest_conds = extract_n(ctx->curr_exp, cond1, 2);

  // end recursion at (cond )
  if (lbm_is_symbol_nil(cond1[1])) {
    ctx->r = ENC_SYM_NIL;
    ctx->app_cont = true;
  } else {
    // Cond is one of the few places where a bit of syntax checking takes place at runtime..
    // Maybe dont bother?
    lbm_uint len = lbm_list_length(cond1[1]);
    if (len != 2) {
      lbm_set_error_reason("Incorrect syntax in cond");
      error_ctx(ENC_SYM_EERROR);
    }
    lbm_value cond_expr[2];
    extract_n(cond1[1], cond_expr, 2);
    lbm_value rest;
    WITH_GC(rest, lbm_heap_allocate_list_init(2,
                                              cond_expr[1], // Then branch
                                              cons_with_gc(ENC_SYM_COND, rest_conds , ENC_SYM_NIL)));
    lbm_value *sptr = stack_reserve(ctx, 3);
    sptr[0] = rest;
    sptr[1] = ctx->curr_env;
    sptr[2] = IF;
    ctx->curr_exp = cond_expr[0]; //condition;
  }
}

static void eval_app_cont(eval_context_t *ctx) {
  lbm_stack_drop(&ctx->K, 1);
  ctx->app_cont = true;
}

// Create a named location in an environment to later receive a value.
static binding_location_status create_binding_location_internal(lbm_value key, lbm_value *env) {
  if (lbm_type_of(key) == LBM_TYPE_SYMBOL) { // default case
    if (key == ENC_SYM_NIL || key == ENC_SYM_DONTCARE) return BL_OK;
    lbm_value binding;
    lbm_value new_env_tmp;
    binding = lbm_cons(key, ENC_SYM_PLACEHOLDER);
    new_env_tmp = lbm_cons(binding, *env);
    if (lbm_is_symbol(binding) || lbm_is_symbol(new_env_tmp)) {
      return BL_NO_MEMORY;
    }
    *env = new_env_tmp;
  } else if (lbm_is_cons(key)) { // deconstruct case
    int r = create_binding_location_internal(get_car(key), env);
    if (r == BL_OK) {
      r = create_binding_location_internal(get_cdr(key), env);
    }
    return r;
  }
  return BL_OK;
}

static void create_binding_location(lbm_value key, lbm_value *env) {

  lbm_value env_tmp = *env;
#ifdef LBM_ALWAYS_GC
  lbm_gc_mark_phase(env_tmp);
  gc();
#endif
  binding_location_status r = create_binding_location_internal(key, &env_tmp);
  if (r != BL_OK) {
    if (r == BL_NO_MEMORY) {
      env_tmp = *env;
      lbm_gc_mark_phase(env_tmp);
      gc();
      r = create_binding_location_internal(key, &env_tmp);
    }
    switch(r) {
    case BL_OK:
      break;
    case BL_NO_MEMORY:
      error_ctx(ENC_SYM_MERROR);
      break;
    case BL_INCORRECT_KEY:
      error_ctx(ENC_SYM_TERROR);
      break;
    }
  }
  *env = env_tmp;
}

static void let_bind_values_eval(lbm_value binds, lbm_value exp, lbm_value env, eval_context_t *ctx) {
  if (lbm_is_cons(binds)) {
      // Preallocate binding locations.
      lbm_value curr = binds;
      while (lbm_is_cons(curr)) {
        lbm_value new_env_tmp = env;
        lbm_cons_t *cell = lbm_ref_cell(curr); // already checked that cons.
        lbm_value car_curr = cell->car;
        lbm_value cdr_curr = cell->cdr;
        lbm_value key = get_car(car_curr);
        create_binding_location(key, &new_env_tmp);
        env = new_env_tmp;
        curr = cdr_curr;
      }

      lbm_cons_t *cell = lbm_ref_cell(binds); // already checked that cons.
      lbm_value car_binds = cell->car;
      lbm_value cdr_binds = cell->cdr;
      lbm_value key_val[2];
      extract_n(car_binds, key_val, 2);

      lbm_uint *sptr = stack_reserve(ctx, 5);
      sptr[0] = exp;
      sptr[1] = cdr_binds;
      sptr[2] = env;
      sptr[3] = key_val[0];
      sptr[4] = BIND_TO_KEY_REST;
      ctx->curr_exp = key_val[1];
      ctx->curr_env = env;
    } else {
      ctx->curr_exp = exp;
    }
}

// (var x (...)) - local binding inside of an progn
// var has to take, place root-level nesting within progn.
// (progn ... (var a 10) ...) OK!
// (progn ... (something (var a 10)) ... ) NOT OK!
/* progn stack
   sp-4 : env
   sp-3 : 0
   sp-2 : rest
   sp-1 : PROGN_REST
*/
static void eval_var(eval_context_t *ctx) {
  if (ctx->K.sp >= 4) { // Possibly in progn
    lbm_value sv = ctx->K.data[ctx->K.sp - 1];
    if (IS_CONTINUATION(sv) && (sv == PROGN_REST)) {
      lbm_uint sp = ctx->K.sp;
      uint32_t is_copied = lbm_dec_as_u32(ctx->K.data[sp-3]);
      if (is_copied == 0) {
        lbm_value env;
        WITH_GC(env, lbm_env_copy_spine(ctx->K.data[sp-4]));
        ctx->K.data[sp-3] = lbm_enc_u(1);
        ctx->K.data[sp-4] = env;
      }
      lbm_value new_env = ctx->K.data[sp-4];
      lbm_value args = get_cdr(ctx->curr_exp);
      lbm_value key = get_car(args);

      create_binding_location(key, &new_env);

      ctx->K.data[sp-4] = new_env;

      lbm_value v_exp = get_cadr(args);
      lbm_value *sptr = stack_reserve(ctx, 3);
      sptr[0] = new_env;
      sptr[1] = key;
      sptr[2] = PROGN_VAR;
      // Activating the new environment before the evaluation of the value to be bound.
      // This would normally shadow the existing value, but create_binding_location sets
      // the binding to be $placeholder, which is ignored when looking up the value.
      // The way closures work, the var-variable needs to be in scope during val
      // evaluation for a recursive closure to be possible.
      ctx->curr_env = new_env;
      ctx->curr_exp = v_exp;
      return;
    }
  }
  lbm_set_error_reason((char*)lbm_error_str_var_outside_progn);
  error_ctx(ENC_SYM_EERROR);
}

// (setq x (...)) - same as (set 'x (...)) or (setvar 'x (...))
// does not error when given incorrect number of arguments.
static void eval_setq(eval_context_t *ctx) {
  lbm_value parts[3];
  extract_n(ctx->curr_exp, parts, 3);
  lbm_value *sptr = stack_reserve(ctx, 3);
  sptr[0] = ctx->curr_env;
  sptr[1] = parts[1];
  sptr[2] = SETQ;
  ctx->curr_exp = parts[2];
}

static void eval_move_to_flash(eval_context_t *ctx) {
  lbm_value args = get_cdr(ctx->curr_exp);
  lbm_value *sptr = stack_reserve(ctx,2);
  sptr[0] = args;
  sptr[1] = MOVE_TO_FLASH;
  ctx->app_cont = true;
}

// (loop list-of-local-bindings
//       condition-exp
//       body-exp)
static void eval_loop(eval_context_t *ctx) {
  lbm_value env              = ctx->curr_env;
  lbm_value parts[3];
  extract_n(get_cdr(ctx->curr_exp), parts, 3);
  lbm_value *sptr = stack_reserve(ctx, 3);
  sptr[0] = parts[LOOP_BODY];
  sptr[1] = parts[LOOP_COND];
  sptr[2] = LOOP_CONDITION;
  let_bind_values_eval(parts[LOOP_BINDS], parts[LOOP_COND], env, ctx);
}

/* (trap expression)
 *
 * suggested use:
 * (match (trap expression)
 *   ((exit-error (? err)) (error-handler err))
 *   ((exit-ok    (? v))   (value-handler v)))
 */
static void eval_trap(eval_context_t *ctx) {

  lbm_value expr = get_cadr(ctx->curr_exp);
  lbm_value retval;
  WITH_GC(retval, lbm_heap_allocate_list(2));
  lbm_set_car(retval, ENC_SYM_EXIT_OK); // Assume things will go well.
  lbm_uint *sptr = stack_reserve(ctx,3);
  sptr[0] = retval;
  sptr[1] = ctx->flags;
  sptr[2] = EXCEPTION_HANDLER;
  ctx->flags |= EVAL_CPS_CONTEXT_FLAG_TRAP_UNROLL_RETURN;
  ctx->curr_exp = expr;
}

// (let list-of-binding s
//      body-exp)
static void eval_let(eval_context_t *ctx) {
  lbm_value env      = ctx->curr_env;
  lbm_value parts[3];
  extract_n(ctx->curr_exp, parts, 3);
  let_bind_values_eval(parts[1], parts[2], env, ctx);
}

// (and exp0 ... expN)
static void eval_and(eval_context_t *ctx) {
  lbm_value rest = get_cdr(ctx->curr_exp);
  if (lbm_is_symbol_nil(rest)) {
    ctx->app_cont = true;
    ctx->r = ENC_SYM_TRUE;
  } else {
    lbm_value *sptr = stack_reserve(ctx, 3);
    sptr[0] = ctx->curr_env;
    sptr[1] = get_cdr(rest);
    sptr[2] = AND;
    ctx->curr_exp = get_car(rest);
  }
}

// (or exp0 ... expN)
static void eval_or(eval_context_t *ctx) {
  lbm_value rest = get_cdr(ctx->curr_exp);
  if (lbm_is_symbol_nil(rest)) {
    ctx->app_cont = true;
    ctx->r = ENC_SYM_NIL;
  } else {
    lbm_value *sptr = stack_reserve(ctx, 3);
    sptr[0] = ctx->curr_env;
    sptr[1] = get_cdr(rest);
    sptr[2] = OR;
    ctx->curr_exp = get_car(rest);
  }
}

// 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_is_cons(rest)) {
    lbm_cons_t *cell = lbm_ref_cell(rest);
    lbm_value cdr_rest = cell->cdr;
    ctx->curr_exp = cell->car;
    lbm_value *sptr = stack_reserve(ctx, 3);
    sptr[0] = cdr_rest;
    sptr[1] = ctx->curr_env;
    sptr[2] = MATCH;
  } else {
    // syntax error to not include at least one pattern
    error_ctx(ENC_SYM_EERROR);
  }
}

static void receive_base(eval_context_t *ctx, lbm_value pats) {
  if (ctx->num_mail == 0) {
      block_current_ctx(LBM_THREAD_STATE_RECV_BL,0,false);
  } else {
    lbm_value *msgs = ctx->mailbox;
    lbm_uint  num   = ctx->num_mail;

    lbm_value e;
    lbm_value new_env = ctx->curr_env;
#ifdef LBM_ALWAYS_GC
    gc();
#endif
    int n = find_match(pats, msgs, num, &e, &new_env);
    if (n == FM_NEED_GC) {
      gc();
      new_env = ctx->curr_env;
      n = find_match(pats, msgs, num, &e, &new_env);
      if (n == FM_NEED_GC) {
        error_ctx(ENC_SYM_MERROR);
      }
    }
    if (n == FM_PATTERN_ERROR) {
      lbm_set_error_reason("Incorrect pattern format for recv");
      error_at_ctx(ENC_SYM_EERROR,pats);
    } else if (n >= 0 ) { /* Match */
      mailbox_remove_mail(ctx, (lbm_uint)n);
      ctx->curr_env = new_env;
      ctx->curr_exp = e;
    } else { /* No match  go back to sleep */
      ctx->r = ENC_SYM_NO_MATCH;
      block_current_ctx(LBM_THREAD_STATE_RECV_BL, 0,false);
    }
  }
  return;
}

// Receive-timeout
// (recv-to timeout (pattern expr)
//                  (pattern expr))
static void eval_receive_timeout(eval_context_t *ctx) {
  if (is_atomic) atomic_error();
  lbm_value timeout_val = get_cadr(ctx->curr_exp);
  lbm_value pats = get_cdr(get_cdr(ctx->curr_exp));
  if (lbm_is_symbol_nil(pats)) {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_at_ctx(ENC_SYM_EERROR, ctx->curr_exp);
  } else {
    lbm_value *sptr = stack_reserve(ctx, 2);
    sptr[0] = pats;
    sptr[1] = RECV_TO;
    ctx->curr_exp = timeout_val;
  }
}

// Receive
// (recv (pattern expr)
//       (pattern expr))
static void eval_receive(eval_context_t *ctx) {
  if (is_atomic) atomic_error();
  lbm_value pats = get_cdr(ctx->curr_exp);
  if (lbm_is_symbol_nil(pats)) {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_at_ctx(ENC_SYM_EERROR,ctx->curr_exp);
  } else {
    receive_base(ctx, pats);
  }
}

/*********************************************************/
/*  Continuation functions                               */

// cont_set_global_env:
//
//   s[sp-1] = Key-symbol
//
//   ctx->r = Value
static void cont_set_global_env(eval_context_t *ctx){

  lbm_value key;
  lbm_value val = ctx->r;

  lbm_pop(&ctx->K, &key);
  lbm_uint dec_key = lbm_dec_sym(key);
  lbm_uint ix_key  = dec_key & GLOBAL_ENV_MASK;
  lbm_value *global_env = lbm_get_global_env();
  lbm_uint orig_env = global_env[ix_key];
  lbm_value new_env;
  // A key is a symbol and should not need to be remembered.
  WITH_GC(new_env, lbm_env_set(orig_env,key,val));

  global_env[ix_key] = new_env;
  ctx->r = val;

  ctx->app_cont = true;

  return;
}

// cont_resume:
//
// s[sp-2] = Expression
// s[sp-1] = Environment
//
// ctx->r = Irrelevant.
static void cont_resume(eval_context_t *ctx) {
  lbm_pop_2(&ctx->K, &ctx->curr_env, &ctx->curr_exp);
}

// cont_progn_rest:
//
// s[sp-3] = Environment to evaluate each expression in.
// s[sp-2] = Flag indicating if env has been copied.
// s[sp-1] = list of expressions to evaluate.
//
// ctx->r = Result of last evaluated expression.
static void cont_progn_rest(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 3);

  lbm_value env  = sptr[0];
  // eval_progn and cont_progn_rest both ensure that sptr[2] is a list
  // whenever cont_progn_rest is called.

  lbm_cons_t *rest_cell = lbm_ref_cell(sptr[2]);
  lbm_value rest_cdr = rest_cell->cdr;
  ctx->curr_exp = rest_cell->car;;
  ctx->curr_env = env;
  if (lbm_is_cons(rest_cdr)) {
    sptr[2] = rest_cdr; // Requirement: rest_cdr is a cons
    stack_reserve(ctx, 1)[0] = PROGN_REST;
  } else {
    // Nothing is pushed to stack for final element in progn. (tail-call req)
    lbm_stack_drop(&ctx->K, 3);
  }
}

static void cont_wait(eval_context_t *ctx) {

  lbm_value cid_val;
  lbm_pop(&ctx->K, &cid_val);
  lbm_cid cid = (lbm_cid)lbm_dec_i(cid_val);

  bool exists = false;

  lbm_blocked_iterator(context_exists, &cid, &exists);
  lbm_running_iterator(context_exists, &cid, &exists);

  if (ctx_running->id == cid) {
    exists = true;
  }

  if (exists) {
    lbm_value *sptr = stack_reserve(ctx, 2);
    sptr[0] = lbm_enc_i(cid);
    sptr[1] = WAIT;
    ctx->r = ENC_SYM_TRUE;
    ctx->app_cont = true;
    yield_ctx(50000);
  } else {
    ctx->r = ENC_SYM_TRUE;
    ctx->app_cont = true;
  }
}

static lbm_value perform_setvar(lbm_value key, lbm_value val, lbm_value env) {

  lbm_uint s = lbm_dec_sym(key);
  if (s >= RUNTIME_SYMBOLS_START) {
    lbm_value new_env = lbm_env_modify_binding(env, key, val);
    if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
      lbm_uint ix_key = lbm_dec_sym(key) & GLOBAL_ENV_MASK;
      lbm_value *glob_env = lbm_get_global_env();
      new_env = lbm_env_modify_binding(glob_env[ix_key], key, val);
      glob_env[ix_key] = new_env;
    }
    if (lbm_is_symbol(new_env) && new_env == ENC_SYM_NOT_FOUND) {
      lbm_set_error_reason((char*)lbm_error_str_variable_not_bound);
      error_at_ctx(ENC_SYM_NOT_FOUND, key);
    }
    return val;
  }
  error_at_ctx(ENC_SYM_EERROR, ENC_SYM_SETVAR);
  return ENC_SYM_NIL; // unreachable
}

static void apply_setvar(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 2 && lbm_is_symbol(args[0])) {
    lbm_value res;
    WITH_GC(res, perform_setvar(args[0], args[1], ctx->curr_env));
    ctx->r = args[1];
    lbm_stack_drop(&ctx->K, nargs+1);
    ctx->app_cont = true;
  } else {
    if (nargs == 2) lbm_set_error_reason((char*)lbm_error_str_incorrect_arg);
    else lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_at_ctx(ENC_SYM_EERROR, ENC_SYM_SETVAR);
  }
}


#define READING_EXPRESSION             ((0 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READING_PROGRAM                ((1 << LBM_VAL_SHIFT) | LBM_TYPE_U)
#define READING_PROGRAM_INCREMENTALLY  ((2 << LBM_VAL_SHIFT) | LBM_TYPE_U)

static void apply_read_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, bool program, bool incremental) {
  if (nargs == 1) {
    lbm_value chan = ENC_SYM_NIL;
    if (lbm_type_of_functional(args[0]) == LBM_TYPE_ARRAY) {
      char *str = lbm_dec_str(args[0]);
      if (str) {
#ifdef LBM_ALWAYS_GC
        gc();
#endif
        if (!create_string_channel(lbm_dec_str(args[0]), &chan, args[0])) {
          gc();
          if (!create_string_channel(lbm_dec_str(args[0]), &chan, args[0])) {
            error_ctx(ENC_SYM_MERROR);
          }
        }
      } else {
        error_ctx(ENC_SYM_EERROR);
      }
    } else if (lbm_type_of(args[0]) == LBM_TYPE_CHANNEL) {
      chan = args[0];
      // Streaming transfers can freeze the evaluator if the stream is cut while
      // the reader is reading inside of an atomic block.
      // It is generally not advisable to read in an atomic block but now it is also
      // enforced in the case where it can cause problems.
      if (lbm_channel_may_block(lbm_dec_channel(chan)) && is_atomic) {
       lbm_set_error_reason((char*)lbm_error_str_forbidden_in_atomic);
       is_atomic = false;
       error_ctx(ENC_SYM_EERROR);
      }
    } else {
      error_ctx(ENC_SYM_EERROR);
    }
    lbm_value *sptr = get_stack_ptr(ctx, 2);

    // If we are inside a reader, its settings are stored.
    sptr[0] = lbm_enc_u(ctx->flags);  // flags stored.
    sptr[1] = chan;
    lbm_value  *rptr = stack_reserve(ctx,2);
    if (!program && !incremental) {
      rptr[0] = READING_EXPRESSION;
    } else if (program && !incremental) {
      rptr[0] = READING_PROGRAM;
    } else if (program && incremental) {
      rptr[0] = READING_PROGRAM_INCREMENTALLY;
    }  // the last combo is illegal
    rptr[1] = READ_DONE;

    // Each reader starts in a fresh situation
    ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
    ctx->r = ENC_SYM_NIL; // set r to a known state.

    if (program) {
      if (incremental) {
        ctx->flags |= EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
        lbm_value  *rptr1 = stack_reserve(ctx,3);
        rptr1[0] = chan;
        rptr1[1] = ctx->curr_env;
        rptr1[2] = READ_EVAL_CONTINUE;
      } else {
        ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ;
        lbm_value  *rptr1 = stack_reserve(ctx,4);
        rptr1[0] = ENC_SYM_NIL;
        rptr1[1] = ENC_SYM_NIL;
        rptr1[2] = chan;
        rptr1[3] = READ_APPEND_CONTINUE;
      }
    }
    rptr = stack_reserve(ctx,3); // reuse of variable rptr
    rptr[0] = chan;
    rptr[1] = lbm_enc_u(1);
    rptr[2] = READ_NEXT_TOKEN;
    ctx->app_cont = true;
  } else {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_ctx(ENC_SYM_EERROR);
  }
}

static void apply_read_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  apply_read_base(args,nargs,ctx,true,false);
}

static void apply_read_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  apply_read_base(args,nargs,ctx,true,true);
}

static void apply_read(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  apply_read_base(args,nargs,ctx,false,false);
}

static void apply_spawn_base(lbm_value *args, lbm_uint nargs, eval_context_t *ctx, uint32_t context_flags) {

  lbm_uint stack_size = EVAL_CPS_DEFAULT_STACK_SIZE;
  lbm_uint closure_pos = 0;
  char *name = NULL;
  // allowed arguments:
  // (spawn opt-name opt-stack-size closure arg1 ... argN)

  if (nargs >= 1 &&
      lbm_is_closure(args[0])) {
    closure_pos = 0;
  } else if (nargs >= 2 &&
      lbm_is_number(args[0]) &&
      lbm_is_closure(args[1])) {
    stack_size = lbm_dec_as_u32(args[0]);
    closure_pos = 1;
  } else if (nargs >= 2 &&
             lbm_is_array_r(args[0]) &&
             lbm_is_closure(args[1])) {
    name = lbm_dec_str(args[0]);
    closure_pos = 1;
  } else if (nargs >= 3 &&
             lbm_is_array_r(args[0]) &&
             lbm_is_number(args[1]) &&
             lbm_is_closure(args[2])) {
    stack_size = lbm_dec_as_u32(args[1]);
    closure_pos = 2;
    name = lbm_dec_str(args[0]);
  } else {
    if (context_flags & EVAL_CPS_CONTEXT_FLAG_TRAP)
      error_at_ctx(ENC_SYM_TERROR,ENC_SYM_SPAWN_TRAP);
    else
      error_at_ctx(ENC_SYM_TERROR,ENC_SYM_SPAWN);
  }

  lbm_value cl[3];
  extract_n(get_cdr(args[closure_pos]), cl, 3);
  lbm_value curr_param = cl[CLO_PARAMS];
  lbm_value clo_env    = cl[CLO_ENV];
  lbm_uint i = closure_pos + 1;
  while (lbm_is_cons(curr_param) && i <= nargs) {
    lbm_value entry = cons_with_gc(get_car(curr_param), args[i], clo_env);
    lbm_value aug_env = cons_with_gc(entry, clo_env,ENC_SYM_NIL);
    clo_env = aug_env;
    curr_param = get_cdr(curr_param);
    i ++;
  }

  lbm_stack_drop(&ctx->K, nargs+1);

  lbm_value program = cons_with_gc(cl[CLO_BODY], ENC_SYM_NIL, clo_env);

  lbm_cid cid = lbm_create_ctx_parent(program,
                                      clo_env,
                                      stack_size,
                                      lbm_get_current_cid(),
                                      context_flags,
                                      name);
  ctx->r = lbm_enc_i(cid);
  ctx->app_cont = true;
  if (cid == -1) error_ctx(ENC_SYM_MERROR); // Kill parent and signal out of memory.
}

static void apply_spawn(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_NOTHING);
}

static void apply_spawn_trap(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  apply_spawn_base(args,nargs,ctx, EVAL_CPS_CONTEXT_FLAG_TRAP);
}

static void apply_yield(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 1 && lbm_is_number(args[0])) {
    lbm_uint ts = lbm_dec_as_u32(args[0]);
    lbm_stack_drop(&ctx->K, nargs+1);
    yield_ctx(ts);
  } else {
    lbm_set_error_reason((char*)lbm_error_str_no_number);
    error_at_ctx(ENC_SYM_TERROR, ENC_SYM_YIELD);
  }
}

static void apply_sleep(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 1 && lbm_is_number(args[0])) {
    lbm_uint ts = (lbm_uint)(1000000.0f * lbm_dec_as_float(args[0]));
    lbm_stack_drop(&ctx->K, nargs+1);
    yield_ctx(ts);
  } else {
    lbm_set_error_reason((char*)lbm_error_str_no_number);
    error_at_ctx(ENC_SYM_TERROR, ENC_SYM_SLEEP);
  }
}

static void apply_wait(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_I) {
    lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
    lbm_value *sptr = get_stack_ptr(ctx, 2);
    sptr[0] = lbm_enc_i(cid);
    sptr[1] = WAIT;
    ctx->r = ENC_SYM_TRUE;
    ctx->app_cont = true;
    yield_ctx(50000);
  } else {
    error_at_ctx(ENC_SYM_TERROR, ENC_SYM_WAIT);
  }
}

/* (eval expr)
   (eval env expr) */
static void apply_eval(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if ( nargs == 1) {
    ctx->curr_exp = args[0];
  } else if (nargs == 2) {
    ctx->curr_exp = args[1];
    ctx->curr_env = args[0];
  } else {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_at_ctx(ENC_SYM_EERROR, ENC_SYM_EVAL);
  }
  lbm_stack_drop(&ctx->K, nargs+1);
}

static void apply_eval_program(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  int prg_pos = 0;
  if (nargs == 2) {
    prg_pos = 1;
    ctx->curr_env = args[0]; // No check that args[0] is an actual env.
  }
  if (nargs == 1 || nargs == 2) {
    lbm_value prg = args[prg_pos]; // No check that this is a program.
    lbm_value app_cont;
    lbm_value app_cont_prg;
    lbm_value new_prg;
    lbm_value prg_copy;

    int len = -1;
    WITH_GC(prg_copy, lbm_list_copy(&len, prg));
    lbm_stack_drop(&ctx->K, nargs+1);
    // There is always a continuation (DONE).
    // If ctx->program is nil, the stack should contain DONE.
    // after adding an intermediate done for prg, stack becomes DONE, DONE.
    app_cont = cons_with_gc(ENC_SYM_APP_CONT, ENC_SYM_NIL, prg_copy);
    app_cont_prg = cons_with_gc(app_cont, ENC_SYM_NIL, prg_copy);
    new_prg = lbm_list_append(app_cont_prg, ctx->program);
    new_prg = lbm_list_append(prg_copy, new_prg);
    // new_prg is guaranteed to be a cons cell or nil
    // even if the eval-program application is syntactically broken.
    stack_reserve(ctx, 1)[0] = DONE;
    ctx->program = get_cdr(new_prg);
    ctx->curr_exp = get_car(new_prg);
  } else {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_at_ctx(ENC_SYM_EERROR, ENC_SYM_EVAL_PROGRAM);
  }
}

static void apply_send(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 2) {
    if (lbm_type_of(args[0]) == LBM_TYPE_I) {
      lbm_cid cid = (lbm_cid)lbm_dec_i(args[0]);
      lbm_value msg = args[1];
      int r = lbm_find_receiver_and_send(cid, msg);
      /* return the status */
      lbm_stack_drop(&ctx->K, nargs+1);
      ctx->r = r == 0 ? ENC_SYM_TRUE : ENC_SYM_NIL;
      ctx->app_cont = true;
    } else {
      error_at_ctx(ENC_SYM_TERROR, ENC_SYM_SEND);
    }
  } else {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_at_ctx(ENC_SYM_EERROR, ENC_SYM_SEND);
  }
}

static void apply_ok(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  lbm_value ok_val = ENC_SYM_TRUE;
  if (nargs >= 1) {
    ok_val = args[0];
  }
  ctx->r = ok_val;
  ok_ctx();
}

static void apply_error(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  (void) ctx;
  lbm_value err_val = ENC_SYM_EERROR;
  if (nargs >= 1) {
    err_val = args[0];
  }
  error_at_ctx(err_val, ENC_SYM_EXIT_ERROR);
}

// (map f arg-list)
static void apply_map(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 2 && lbm_is_cons(args[1])) {
    lbm_value *sptr = get_stack_ptr(ctx, 3);

    lbm_value f = args[0];
    lbm_cons_t *args1_cell = lbm_ref_cell(args[1]);
    lbm_value h = args1_cell->car;
    lbm_value t = args1_cell->cdr;

    lbm_value appli_1;
    lbm_value appli;
    WITH_GC(appli_1, lbm_heap_allocate_list(2));
    WITH_GC_RMBR_1(appli, lbm_heap_allocate_list(2), appli_1);

    lbm_value appli_0 = get_cdr(appli_1);

    lbm_set_car_and_cdr(appli_0, h, ENC_SYM_NIL);
    lbm_set_car(appli_1, ENC_SYM_QUOTE);

    lbm_set_car_and_cdr(get_cdr(appli), appli_1, ENC_SYM_NIL);
    lbm_set_car(appli, f);

    lbm_value elt = cons_with_gc(ctx->r, ENC_SYM_NIL, appli);
    sptr[0] = t;     // reuse stack space
    sptr[1] = ctx->curr_env;
    sptr[2] = elt;
    lbm_value *rptr = stack_reserve(ctx,4);
    rptr[0] = elt;
    rptr[1] = appli;
    rptr[2] = appli_0;
    rptr[3] = MAP;
    ctx->curr_exp = appli;
  } else if (nargs == 2 && lbm_is_symbol_nil(args[1])) {
    lbm_stack_drop(&ctx->K, 3);
    ctx->r = ENC_SYM_NIL;
    ctx->app_cont = true;
  } else {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_at_ctx(ENC_SYM_EERROR, ENC_SYM_MAP);
  }
}

static void apply_reverse(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 1 && lbm_is_list(args[0])) {
    lbm_value curr = args[0];

    lbm_value new_list = ENC_SYM_NIL;
    while (lbm_is_cons(curr)) {
      lbm_cons_t *curr_cell = lbm_ref_cell(curr); // known cons.
      lbm_value tmp = cons_with_gc(curr_cell->car, new_list, ENC_SYM_NIL);
      new_list = tmp;
      curr = curr_cell->cdr;
    }
    lbm_stack_drop(&ctx->K, 2);
    ctx->r = new_list;
    ctx->app_cont = true;
  } else {
    lbm_set_error_reason("Reverse requires a list argument");
    error_at_ctx(ENC_SYM_EERROR, ENC_SYM_REVERSE);
  }
}

static void apply_flatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 1) {
#ifdef LBM_ALWAYS_GC
    gc();
#endif
    lbm_value v = flatten_value(args[0]);
    if ( v == ENC_SYM_MERROR) {
      gc();
      v = flatten_value(args[0]);
    }

    if (lbm_is_symbol(v)) {
      error_at_ctx(v, ENC_SYM_FLATTEN);
    } else {
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = v;
      ctx->app_cont = true;
    }
    return;
  }
  error_at_ctx(ENC_SYM_TERROR, ENC_SYM_FLATTEN);
}

static void apply_unflatten(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if(nargs == 1 && lbm_type_of(args[0]) == LBM_TYPE_ARRAY) {
    lbm_array_header_t *array;
    array = (lbm_array_header_t *)get_car(args[0]);

    lbm_flat_value_t fv;
    fv.buf = (uint8_t*)array->data;
    fv.buf_size = array->size;
    fv.buf_pos = 0;

    lbm_value res;

    ctx->r = ENC_SYM_NIL;
    if (lbm_unflatten_value(&fv, &res)) {
      ctx->r =  res;
    }
    lbm_stack_drop(&ctx->K, 2);
    ctx->app_cont = true;
    return;
  }
  error_at_ctx(ENC_SYM_TERROR, ENC_SYM_UNFLATTEN);
}

static void apply_kill(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 2 && lbm_is_number(args[0])) {
    lbm_cid cid = lbm_dec_as_i32(args[0]);

    if (ctx->id == cid) {
      ctx->r = args[1];
      finish_ctx();
      return;
    }
    mutex_lock(&qmutex);
    eval_context_t *found = NULL;
    found = lookup_ctx_nm(&blocked, cid);
    if (found)
      drop_ctx_nm(&blocked, found);
    else
      found = lookup_ctx_nm(&queue, cid);
    if (found)
      drop_ctx_nm(&queue, found);

    if (found) {
      found->K.data[found->K.sp - 1] = KILL;
      found->r = args[1];
      found->app_cont = true;
      found->state = LBM_THREAD_STATE_READY;
      enqueue_ctx_nm(&queue,found);
      ctx->r = ENC_SYM_TRUE;
    } else {
      ctx->r = ENC_SYM_NIL;
    }
    lbm_stack_drop(&ctx->K, 3);
    ctx->app_cont = true;
    mutex_unlock(&qmutex);
    return;
  }
  error_at_ctx(ENC_SYM_TERROR, ENC_SYM_KILL);
}

static lbm_value cmp_to_clo(lbm_value cmp) {
  lbm_value closure;
  WITH_GC(closure, lbm_heap_allocate_list(4));
  lbm_set_car(closure, ENC_SYM_CLOSURE);
  lbm_value cl1 = lbm_cdr(closure);
  lbm_value par;
  WITH_GC_RMBR_1(par, lbm_heap_allocate_list_init(2, symbol_x, symbol_y), closure);
  lbm_set_car(cl1, par);
  lbm_value cl2 = lbm_cdr(cl1);
  lbm_value body;
  WITH_GC_RMBR_1(body, lbm_heap_allocate_list_init(3, cmp, symbol_x, symbol_y), closure);
  lbm_set_car(cl2, body);
  lbm_value cl3 = lbm_cdr(cl2);
  lbm_set_car(cl3, ENC_SYM_NIL);
  return closure;
}

// (merge comparator list1 list2)
static void apply_merge(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 3 && lbm_is_list(args[1]) && lbm_is_list(args[2])) {

    if (!lbm_is_closure(args[0])) {
      args[0] = cmp_to_clo(args[0]);
    }

    // Copy input lists for functional behaviour at top-level
    // merge itself is in-place in the copied lists.
    lbm_value a;
    lbm_value b;
    int len_a = -1;
    int len_b = -1;
    WITH_GC(a, lbm_list_copy(&len_a, args[1]));
    WITH_GC_RMBR_1(b, lbm_list_copy(&len_b, args[2]), a);

    if (len_a == 0) {
      ctx->r = b;
      lbm_stack_drop(&ctx->K, 4);
      ctx->app_cont = true;
      return;
    }
    if (len_b == 0) {
      ctx->r = a;
      lbm_stack_drop(&ctx->K, 4);
      ctx->app_cont = true;
      return;
    }

    args[1] = a; // keep safe by replacing the original on stack.
    args[2] = b;

    lbm_value a_1 = a;
    lbm_value a_rest = lbm_cdr(a);
    lbm_value b_1 = b;
    lbm_value b_rest = lbm_cdr(b);

    lbm_value cl[3]; // Comparator closure
    extract_n(lbm_cdr(args[0]), cl, 3);
    lbm_value cmp_env = cl[CLO_ENV];
    lbm_value par1 = ENC_SYM_NIL;
    lbm_value par2 = ENC_SYM_NIL;
    lbm_uint len = lbm_list_length(cl[CLO_PARAMS]);
    if (len == 2) {
      par1 = get_car(cl[CLO_PARAMS]);
      par2 = get_cadr(cl[CLO_PARAMS]);
      lbm_value new_env0;
      lbm_value new_env;
      WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a_1)));
      WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b_1)),new_env0);
      cmp_env = new_env;
    } else {
      error_at_ctx(ENC_SYM_TERROR, args[0]);
    }
    lbm_set_cdr(a_1, b_1);
    lbm_set_cdr(b_1, ENC_SYM_NIL);
    lbm_value cmp = cl[CLO_BODY];

    lbm_stack_drop(&ctx->K, 4); // TODO: Optimize drop 4 alloc 10 into alloc 6
    lbm_uint *sptr = stack_reserve(ctx, 10);
    sptr[0] = ENC_SYM_NIL; // head of merged list
    sptr[1] = ENC_SYM_NIL; // last of merged list
    sptr[2] = a_1;
    sptr[3] = a_rest;
    sptr[4] = b_rest;
    sptr[5] = cmp;
    sptr[6] = cmp_env;
    sptr[7] = par1;
    sptr[8] = par2;
    sptr[9] = MERGE_REST;
    ctx->curr_exp = cl[CLO_BODY];
    ctx->curr_env = cmp_env;
    return;
  }
  error_at_ctx(ENC_SYM_TERROR, ENC_SYM_MERGE);
}

// (sort comparator list)
static void apply_sort(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 2 && lbm_is_list(args[1])) {

    if (!lbm_is_closure(args[0])) {
      args[0] = cmp_to_clo(args[0]);
    }

    int len = -1;
    lbm_value list_copy;
    WITH_GC(list_copy, lbm_list_copy(&len, args[1]));
    if (len <= 1) {
      lbm_stack_drop(&ctx->K, 3);
      ctx->r = list_copy;
      ctx->app_cont = true;
      return;
    }

    args[1] = list_copy; // Keep safe, original replaced on stack.

    // Take the headmost 2, 1-element sublists.
    lbm_value a = list_copy;
    lbm_value b = lbm_cdr(a);
    lbm_value rest = lbm_cdr(b);
    // Do not terminate b. keep rest of list safe from GC in the following
    // closure extraction.
    //lbm_set_cdr(a, b); // This is void

    lbm_value cl[3]; // Comparator closure
    extract_n(lbm_cdr(args[0]), cl, 3);
    lbm_value cmp_env = cl[CLO_ENV];
    lbm_value par1 = ENC_SYM_NIL;
    lbm_value par2 = ENC_SYM_NIL;
    lbm_uint cl_len = lbm_list_length(cl[CLO_PARAMS]);
    if (cl_len == 2) {
      par1 = get_car(cl[CLO_PARAMS]);
      par2 = get_cadr(cl[CLO_PARAMS]);
      lbm_value new_env0;
      lbm_value new_env;
      WITH_GC(new_env0, lbm_env_set(cmp_env, par1, lbm_car(a)));
      WITH_GC_RMBR_1(new_env, lbm_env_set(new_env0, par2, lbm_car(b)), new_env0);
      cmp_env = new_env;
    } else {
      error_at_ctx(ENC_SYM_TERROR, args[0]);
    }
    lbm_value cmp = cl[CLO_BODY];

    // Terminate the comparator argument list.
    lbm_set_cdr(b, ENC_SYM_NIL);

    lbm_stack_drop(&ctx->K, 3);  //TODO: optimize drop 3, alloc 20 into alloc 17
    lbm_uint *sptr = stack_reserve(ctx, 20);
    sptr[0] = cmp;
    sptr[1] = cmp_env;
    sptr[2] = par1;
    sptr[3] = par2;
    sptr[4] = ENC_SYM_NIL; // head of merged accumulation of sublists
    sptr[5] = ENC_SYM_NIL; // last of merged accumulation of sublists
    sptr[6] = rest;
    sptr[7] = lbm_enc_i(1);
    sptr[8] = lbm_enc_i(len); //TODO: 28 bit i vs 32 bit i
    sptr[9] = MERGE_LAYER;
    sptr[10] = ENC_SYM_NIL; // head of merged sublist
    sptr[11] = ENC_SYM_NIL; // last of merged sublist
    sptr[12] = a;
    sptr[13] = ENC_SYM_NIL; // no a_rest, 1 element lists in layer 1.
    sptr[14] = ENC_SYM_NIL; // no b_rest, 1 element lists in layer 1.
    sptr[15] = cmp;
    sptr[16] = cmp_env;
    sptr[17] = par1;
    sptr[18] = par2;
    sptr[19] = MERGE_REST;
    ctx->curr_exp = cmp;
    ctx->curr_env = cmp_env;
    return;
  }
  error_ctx(ENC_SYM_TERROR);
}

static void apply_rest_args(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  lbm_value res;
  if (lbm_env_lookup_b(&res, ENC_SYM_REST_ARGS, ctx->curr_env)) {
    if (nargs == 1 && lbm_is_number(args[0])) {
      int32_t ix = lbm_dec_as_i32(args[0]);
      res = lbm_index_list(res, ix);
    }
    ctx->r = res;
  } else {
    ctx->r = ENC_SYM_NIL;
  }
  lbm_stack_drop(&ctx->K, nargs+1);
  ctx->app_cont = true;
}

/* (rotate list-expr dist/dir-expr) */
static void apply_rotate(lbm_value *args, lbm_uint nargs, eval_context_t *ctx) {
  if (nargs == 2 && lbm_is_list(args[0]) && lbm_is_number(args[1])) {
    int len = -1;
    lbm_value ls;
    WITH_GC(ls, lbm_list_copy(&len, args[0]));
    int dist = lbm_dec_as_i32(args[1]);
    if (len > 0 && dist != 0) {
      int d = dist;
      if (dist > 0) {
        ls = lbm_list_destructive_reverse(ls);
      } else {
        d = -dist;
      }

      lbm_value start = ls;
      lbm_value end = ENC_SYM_NIL;
      lbm_value curr = start;
      while (lbm_is_cons(curr)) {
        end = curr;
        curr = get_cdr(curr);
      }

      for (int i = 0; i < d; i ++) {
        lbm_value a = start;
        start = lbm_cdr(start);
        lbm_set_cdr(a, ENC_SYM_NIL);
        lbm_set_cdr(end, a);
        end = a;
      }
      ls = start;
      if (dist > 0) {
        ls = lbm_list_destructive_reverse(ls);
      }
    }
    lbm_stack_drop(&ctx->K, nargs+1);
    ctx->app_cont = true;
    ctx->r = ls;
    return;
  }
  error_ctx(ENC_SYM_EERROR);
}

/***************************************************/
/* Application lookup table                        */

typedef void (*apply_fun)(lbm_value *, lbm_uint, eval_context_t *);
static const apply_fun fun_table[] =
  {
   apply_setvar,
   apply_read,
   apply_read_program,
   apply_read_eval_program,
   apply_spawn,
   apply_spawn_trap,
   apply_yield,
   apply_wait,
   apply_eval,
   apply_eval_program,
   apply_send,
   apply_ok,
   apply_error,
   apply_map,
   apply_reverse,
   apply_flatten,
   apply_unflatten,
   apply_kill,
   apply_sleep,
   apply_merge,
   apply_sort,
   apply_rest_args,
   apply_rotate,
  };

/***************************************************/
/* Application of function that takes arguments    */
/* passed over the stack.                          */

static void application(eval_context_t *ctx, lbm_value *fun_args, lbm_uint arg_count) {
  /* If arriving here, we know that the fun is a symbol.
   *  and can be a built in operation or an extension.
   */
  lbm_value fun = fun_args[0];

  lbm_uint fun_val = lbm_dec_sym(fun);
  lbm_uint fun_kind = SYMBOL_KIND(fun_val);

  switch (fun_kind) {
  case SYMBOL_KIND_EXTENSION: {
    extension_fptr f = extension_table[SYMBOL_IX(fun_val)].fptr;

    lbm_value ext_res;
    WITH_GC(ext_res, f(&fun_args[1], arg_count));
    if (lbm_is_error(ext_res)) { //Error other than merror
      error_at_ctx(ext_res, fun);
    }
    lbm_stack_drop(&ctx->K, arg_count + 1);

    ctx->app_cont = true;
    ctx->r = ext_res;

    if (blocking_extension) {
      if (is_atomic) {
        // Check atomic_error explicitly so that the mutex
        // can be released if there is an error.
        blocking_extension = false;
        mutex_unlock(&blocking_extension_mutex);
        atomic_error();
      }
      blocking_extension = false;
      if (blocking_extension_timeout) {
        blocking_extension_timeout = false;
        block_current_ctx(LBM_THREAD_STATE_TIMEOUT, blocking_extension_timeout_us,true);
      } else {
        block_current_ctx(LBM_THREAD_STATE_BLOCKED, 0,true);
      }
      mutex_unlock(&blocking_extension_mutex);
    }
  }  break;
  case SYMBOL_KIND_FUNDAMENTAL:
    call_fundamental(SYMBOL_IX(fun_val), &fun_args[1], arg_count, ctx);
    break;
  case SYMBOL_KIND_APPFUN:
    fun_table[SYMBOL_IX(fun_val)](&fun_args[1], arg_count, ctx);
    break;
  default:
    // Symbols that are "special" but not in the way caught above
    // ends up here.
    lbm_set_error_reason("Symbol does not represent a function");
    error_at_ctx(ENC_SYM_EERROR,fun_args[0]);
    break;
  }
}

static void cont_closure_application_args(eval_context_t *ctx) {
  lbm_uint* sptr = get_stack_ptr(ctx, 5);

  lbm_value arg_env = (lbm_value)sptr[0];
  lbm_value exp     = (lbm_value)sptr[1];
  lbm_value clo_env = (lbm_value)sptr[2];
  lbm_value params  = (lbm_value)sptr[3];
  lbm_value args    = (lbm_value)sptr[4];

  lbm_value car_params, cdr_params;
  get_car_and_cdr(params, &car_params, &cdr_params);

  bool a_nil = lbm_is_symbol_nil(args);
  bool p_nil = lbm_is_symbol_nil(cdr_params);

  lbm_value binder = allocate_binding(car_params, ctx->r, clo_env);

  if (!a_nil && !p_nil) {
    lbm_value car_args, cdr_args;
    get_car_and_cdr(args, &car_args, &cdr_args);
    sptr[2] = binder;
    sptr[3] = cdr_params;
    sptr[4] = cdr_args;
    stack_reserve(ctx,1)[0] = 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 = binder;
    ctx->curr_exp = exp;
  } else if (p_nil) {
    lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, binder);
    sptr[2] = rest_binder;
    sptr[3] = get_cdr(args);
    sptr[4] = get_car(rest_binder); // last element of rest_args so far
    stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
    ctx->curr_exp = get_car(args);
    ctx->curr_env = arg_env;
  }  else {
    lbm_set_error_reason((char*)lbm_error_str_num_args);
    error_ctx(ENC_SYM_EERROR);
  }
}


static void cont_closure_args_rest(eval_context_t *ctx) {
  lbm_uint* sptr = get_stack_ptr(ctx, 5);
  lbm_value arg_env = (lbm_value)sptr[0];
  lbm_value exp     = (lbm_value)sptr[1];
  lbm_value clo_env = (lbm_value)sptr[2];
  lbm_value args    = (lbm_value)sptr[3];
  lbm_value last    = (lbm_value)sptr[4];
  lbm_cons_t* heap = lbm_heap_state.heap;
#ifdef LBM_ALWAYS_GC
  gc();
#endif
  lbm_value binding = lbm_heap_state.freelist;
  if (binding == ENC_SYM_NIL) {
    gc();
    binding = lbm_heap_state.freelist;
    if (binding == ENC_SYM_NIL) error_ctx(ENC_SYM_MERROR);
  }
  lbm_uint binding_ix = lbm_dec_ptr(binding);
  lbm_heap_state.freelist = heap[binding_ix].cdr;
  lbm_heap_state.num_alloc += 1;
  heap[binding_ix].car = ctx->r;
  heap[binding_ix].cdr = ENC_SYM_NIL;


  lbm_set_cdr(last, binding);
  sptr[4] = binding;

  if (args == ENC_SYM_NIL) {
    lbm_stack_drop(&ctx->K, 5);
    ctx->curr_env = clo_env;
    ctx->curr_exp = exp;
  } else {
    stack_reserve(ctx,1)[0] = CLOSURE_ARGS_REST;
    sptr[3] = get_cdr(args);
    ctx->curr_exp = get_car(args);
    ctx->curr_env = arg_env;
  }
}

static void cont_application_args(eval_context_t *ctx) {
  lbm_uint *sptr = get_stack_ptr(ctx, 3);

  lbm_value env = sptr[0];
  lbm_value rest = sptr[1];
  lbm_value count = sptr[2];

  ctx->curr_env = env;
  sptr[0] = ctx->r; // Function 1st then Arguments
  if (lbm_is_cons(rest)) {
    lbm_cons_t *cell = lbm_ref_cell(rest);
    sptr[1] = env;
    sptr[2] = cell->cdr;
    lbm_value *rptr = stack_reserve(ctx,2);
    rptr[0] = count + (1 << LBM_VAL_SHIFT);
    rptr[1] = APPLICATION_ARGS;
    ctx->curr_exp = cell->car;
  } else {
    // No more arguments
    lbm_stack_drop(&ctx->K, 2);
    lbm_uint nargs = lbm_dec_u(count);
    lbm_value *args = get_stack_ptr(ctx, (uint32_t)(nargs + 1));
    application(ctx,args, nargs);
  }
}

static void cont_and(eval_context_t *ctx) {
  lbm_value env;
  lbm_value rest;
  lbm_value arg = ctx->r;
  lbm_pop_2(&ctx->K, &rest, &env);
  if (lbm_is_symbol_nil(arg)) {
    ctx->app_cont = true;
    ctx->r = ENC_SYM_NIL;
  } else if (lbm_is_symbol_nil(rest)) {
    ctx->app_cont = true;
  } else {
    lbm_value *sptr = stack_reserve(ctx, 3);
    sptr[0] = env;
    sptr[1] = get_cdr(rest);
    sptr[2] = AND;
    ctx->curr_env = env;
    ctx->curr_exp = get_car(rest);
  }
}

static void cont_or(eval_context_t *ctx) {
  lbm_value env;
  lbm_value rest;
  lbm_value arg = ctx->r;
  lbm_pop_2(&ctx->K, &rest, &env);
  if (!lbm_is_symbol_nil(arg)) {
    ctx->app_cont = true;
  } else if (lbm_is_symbol_nil(rest)) {
    ctx->app_cont = true;
    ctx->r = ENC_SYM_NIL;
  } else {
    lbm_value *sptr = stack_reserve(ctx, 3);
    sptr[0] = env;
    sptr[1] = get_cdr(rest);
    sptr[2] = OR;
    ctx->curr_exp = get_car(rest);
    ctx->curr_env = env;
  }
}

static int fill_binding_location(lbm_value key, lbm_value value, lbm_value env) {
  if (lbm_type_of(key) == LBM_TYPE_SYMBOL) {
    if (key == ENC_SYM_DONTCARE) return FB_OK;
    lbm_env_modify_binding(env,key,value);
    return FB_OK;
  } else if (lbm_is_cons(key) &&
             lbm_is_cons(value)) {
    int r = fill_binding_location(get_car(key), get_car(value), env);
    if (r == FB_OK) {
      r = fill_binding_location(get_cdr(key), get_cdr(value), env);
    }
    return r;
  }
  return FB_TYPE_ERROR;
}

static void cont_bind_to_key_rest(eval_context_t *ctx) {

  lbm_value *sptr = get_stack_ptr(ctx, 4);

  lbm_value rest = sptr[1];
  lbm_value env  = sptr[2];
  lbm_value key  = sptr[3];

  if (fill_binding_location(key, ctx->r, env) < 0) {
    lbm_set_error_reason("Incorrect type of name/key in let-binding");
    error_at_ctx(ENC_SYM_TERROR, key);
  }

  if (lbm_is_cons(rest)) {
    lbm_value car_rest = get_car(rest);
    lbm_value key_val[2];
    extract_n(car_rest, key_val, 2);

    sptr[1] = get_cdr(rest);
    sptr[3] = key_val[0];
    stack_reserve(ctx,1)[0] = BIND_TO_KEY_REST;
    ctx->curr_exp = key_val[1];
    ctx->curr_env = env;
  } else {
    // Otherwise evaluate the expression in the populated env
    ctx->curr_exp = sptr[0];
    ctx->curr_env = env;
    lbm_stack_drop(&ctx->K, 4);
  }
}

static void cont_if(eval_context_t *ctx) {

  lbm_value arg = ctx->r;

  lbm_value *sptr = pop_stack_ptr(ctx, 2);

  ctx->curr_env = sptr[1];
  if (lbm_is_symbol_nil(arg)) {
    ctx->curr_exp = get_cadr(sptr[0]); // else branch
  } else {
    ctx->curr_exp = get_car(sptr[0]); // then branch
  }
}

static void cont_match(eval_context_t *ctx) {
  lbm_value e = ctx->r;
  bool  do_gc = false;

  lbm_uint *sptr = get_stack_ptr(ctx, 2);
  lbm_value patterns = (lbm_value)sptr[0];
  lbm_value orig_env = (lbm_value)sptr[1]; // restore enclosing environment.
  lbm_value new_env = orig_env;

  if (lbm_is_symbol_nil(patterns)) {
    // no more patterns
    lbm_stack_drop(&ctx->K, 2);
    ctx->r = ENC_SYM_NO_MATCH;
    ctx->app_cont = true;
  } else if (lbm_is_cons(patterns)) {
    lbm_value match_case = get_car(patterns);
    lbm_value pattern = get_car(match_case);
    lbm_value n1      = get_cadr(match_case);
    lbm_value n2      = get_cadr(get_cdr(match_case));
    lbm_value body;
    bool check_guard = false;
    if (lbm_is_symbol_nil(n2)) { // TODO: Not a very robust check.
      body = n1;
    } else {
      body = n2;
      check_guard = true;
    }
#ifdef LBM_ALWAYS_GC
    gc();
#endif
    bool is_match = match(pattern, e, &new_env, &do_gc);
    if (do_gc) {
      gc();
      do_gc = false;
      new_env = orig_env;
      is_match = match(pattern, e, &new_env, &do_gc);
      if (do_gc) {
        error_ctx(ENC_SYM_MERROR);
      }
    }
    if (is_match) {
      if (check_guard) {
        lbm_value *rptr = stack_reserve(ctx,5);
        sptr[0] = get_cdr(patterns);
        sptr[1] = ctx->curr_env;
        rptr[0] = MATCH;
        rptr[1] = new_env;
        rptr[2] = body;
        rptr[3] = e;
        rptr[4] = MATCH_GUARD;
        ctx->curr_env = new_env;
        ctx->curr_exp = n1; // The guard
      } else {
        lbm_stack_drop(&ctx->K, 2);
        ctx->curr_env = new_env;
        ctx->curr_exp = body;
      }
    } else {
      // set up for checking of next pattern
      sptr[0] = get_cdr(patterns);
      sptr[1] = orig_env;
      stack_reserve(ctx,1)[0] = MATCH;
      // leave r unaltered
      ctx->app_cont = true;
    }
  } else {
    error_at_ctx(ENC_SYM_TERROR, ENC_SYM_MATCH);
  }
}

static void cont_exit_atomic(eval_context_t *ctx) {
  is_atomic = false; // atomic blocks cannot nest!
  ctx->app_cont = true;
}

// cont_map:
//
// sptr[0]: s[sp-6] = Rest of the input list.
// sptr[1]: s[sp-5] = Environment to restore for the eval of each application.
// sptr[2]: s[sp-4] = Result list.
// sptr[3]: s[sp-3] = Cell that goes into result list after being populated with application result.
// sptr[4]: s[sp-2] = Ref to application.
// sptr[5]: s[sp-1] = Ref to application argument.
//
// ctx->r  = eval result of previous application.
static void cont_map(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 6);

  lbm_value ls  = sptr[0];
  lbm_value env = sptr[1];
  lbm_value t   = sptr[3];
  lbm_set_car(t, ctx->r); // update car field tailmost position.
  if (lbm_is_cons(ls)) {
    lbm_cons_t *cell = lbm_ref_cell(ls); // already checked that cons.
    lbm_value next = cell->car;
    lbm_value rest = cell->cdr;
    sptr[0] = rest;
    stack_reserve(ctx,1)[0] = MAP;
    lbm_set_car(sptr[5], next); // new arguments

    lbm_value elt = cons_with_gc(ENC_SYM_NIL, ENC_SYM_NIL, ENC_SYM_NIL);
    lbm_set_cdr(t, elt);
    sptr[3] = elt;  // (r1 ... rN . (nil . nil))
    ctx->curr_exp = sptr[4];
    ctx->curr_env = env;
  } else {
    ctx->r = sptr[2]; //head of result list
    ctx->curr_env = env;
    lbm_stack_drop(&ctx->K, 6);
    ctx->app_cont = true;
  }
}

static void cont_match_guard(eval_context_t *ctx) {
  if (lbm_is_symbol_nil(ctx->r)) {
    lbm_value e;
    lbm_pop(&ctx->K, &e);
    lbm_stack_drop(&ctx->K, 2);
    ctx->r = e;
    ctx->app_cont = true;
  } else {
    lbm_value body;
    lbm_value env;
    lbm_stack_drop(&ctx->K, 1);
    lbm_pop_2(&ctx->K, &body, &env);
    lbm_stack_drop(&ctx->K, 3);
    ctx->curr_env = env;
    ctx->curr_exp = body;
  }
}

static void cont_terminate(eval_context_t *ctx) {
  error_ctx(ctx->r);
}

static void cont_loop(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 2);
  stack_reserve(ctx,1)[0] = LOOP_CONDITION;
  ctx->curr_exp = sptr[1];
}

static void cont_loop_condition(eval_context_t *ctx) {
  if (lbm_is_symbol_nil(ctx->r)) {
    lbm_stack_drop(&ctx->K, 2);
    ctx->app_cont = true;  // A loop returns nil? Makes sense to me... but in general?
    return;
  }
  lbm_value *sptr = get_stack_ptr(ctx, 2);
  stack_reserve(ctx,1)[0] = LOOP;
  ctx->curr_exp = sptr[0];
}

static void cont_merge_rest(eval_context_t *ctx) {
  lbm_uint *sptr = get_stack_ptr(ctx, 9);

  // If comparator returns true (result is in ctx->r):
  //   "a" should be moved to the last element position in merged list.
  //   A new element from "a_rest" should be moved into comparator argument 1 pos.
  // else
  //   "b" should be moved to last element position in merged list.
  //   A new element from "b_rest" should be moved into comparator argument 2 pos.
  //
  // If a_rest or b_rest is NIL:
  //   we are done, the remaining elements of
  //   non_nil list should be appended to merged list.
  // else
  //   Set up for a new comparator evaluation and recurse.
  lbm_value a = sptr[2];
  lbm_value b = lbm_cdr(a);
  lbm_set_cdr(a, ENC_SYM_NIL); // terminate 1 element list

  if (ctx->r == ENC_SYM_NIL) { // Comparison false

    if (sptr[0] == ENC_SYM_NIL) {
      sptr[0] = b;
      sptr[1] = b;
    } else {
      lbm_set_cdr(sptr[1], b);
      sptr[1] = b;
    }
    if (sptr[4] == ENC_SYM_NIL) {
      lbm_set_cdr(a, sptr[3]);
      lbm_set_cdr(sptr[1], a);
      ctx->r = sptr[0];
      lbm_stack_drop(&ctx->K, 9);
      ctx->app_cont = true;
      return;
    } else {
      b = sptr[4];
      sptr[4] = lbm_cdr(sptr[4]);
      lbm_set_cdr(b, ENC_SYM_NIL);
    }
  } else {
    if (sptr[0] == ENC_SYM_NIL) {
      sptr[0] = a;
      sptr[1] = a;
    } else {
      lbm_set_cdr(sptr[1], a);
      sptr[1] = a;
    }

    if (sptr[3] == ENC_SYM_NIL) {
      lbm_set_cdr(b, sptr[4]);
      lbm_set_cdr(sptr[1], b);
      ctx->r = sptr[0];
      lbm_stack_drop(&ctx->K, 9);
      ctx->app_cont = true;
      return;
    } else {
      a = sptr[3];
      sptr[3] = lbm_cdr(sptr[3]);
      lbm_set_cdr(a, ENC_SYM_NIL);
    }
  }
  lbm_set_cdr(a, b);
  sptr[2] = a;

  lbm_value par1 = sptr[7];
  lbm_value par2 = sptr[8];
  lbm_value cmp_body = sptr[5];
  lbm_value cmp_env = sptr[6];
  // Environment should be preallocated already at this point
  // and the operations below should never need GC.
  lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
  lbm_value new_env = lbm_env_set(new_env0, par2, lbm_car(b));
  if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }
  cmp_env = new_env;

  stack_reserve(ctx,1)[0] = MERGE_REST;
  ctx->curr_exp = cmp_body;
  ctx->curr_env = cmp_env;
}

// merge_layer stack contents
// s[sp-9] = cmp
// s[sp-8] = cmp_env
// s[sp-7] = par1
// s[sp-6] = par2
// s[sp-5] = acc - first cell
// s[sp-4] = acc - last cell
// s[sp-3] = rest;
// s[sp-2] = layer
// s[sp-1] = length or original list
//
// ctx->r merged sublist
static void cont_merge_layer(eval_context_t *ctx) {
  lbm_uint *sptr = get_stack_ptr(ctx, 9);
  lbm_int layer = lbm_dec_i(sptr[7]);
  lbm_int len = lbm_dec_i(sptr[8]);

  lbm_value r_curr = ctx->r;
  while (lbm_is_cons(r_curr)) {
    lbm_value next = lbm_cdr(r_curr);
    if (next == ENC_SYM_NIL) {
      break;
    }
    r_curr = next;
  }

  if (sptr[4] == ENC_SYM_NIL) {
    sptr[4] = ctx->r;
    sptr[5] = r_curr;
  } else {
    lbm_set_cdr(sptr[5], ctx->r); // accumulate merged sublists.
    sptr[5] = r_curr;
  }

  lbm_value layer_rest = sptr[6];
  // switch layer or done ?
  if (layer_rest == ENC_SYM_NIL) {
    if (layer * 2 >= len) {
      ctx->r = sptr[4];
      ctx->app_cont = true;
      lbm_stack_drop(&ctx->K, 9);
      return;
    } else {
      // Setup for merges of the next layer
      layer = layer * 2;
      sptr[7] = lbm_enc_i(layer);
      layer_rest = sptr[4]; // continue on the accumulation of all sublists.
      sptr[5] = ENC_SYM_NIL;
      sptr[4] = ENC_SYM_NIL;
    }
  }
  // merge another sublist based on current layer.
  lbm_value a_list = layer_rest;
  // build sublist a
  lbm_value curr = layer_rest;
  for (int i = 0; i < layer-1; i ++) {
    if (lbm_is_cons(curr)) {
      curr = lbm_cdr(curr);
    } else {
      break;
    }
  }
  layer_rest = lbm_cdr(curr);
  lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.

  lbm_value b_list = layer_rest;
  // build sublist b
  curr = layer_rest;
  for (int i = 0; i < layer-1; i ++) {
    if (lbm_is_cons(curr)) {
      curr = lbm_cdr(curr);
    } else {
      break;
    }
  }
  layer_rest = lbm_cdr(curr);
  lbm_set_cdr(curr, ENC_SYM_NIL); //terminate sublist.

  sptr[6] = layer_rest;

  if (b_list == ENC_SYM_NIL) {
    stack_reserve(ctx,1)[0] = MERGE_LAYER;
    ctx->r = a_list;
    ctx->app_cont = true;
    return;
  }
  // Set up for a merge of sublists.

  lbm_value a_rest = lbm_cdr(a_list);
  lbm_value b_rest = lbm_cdr(b_list);
  lbm_value a = a_list;
  lbm_value b = b_list;
  lbm_set_cdr(a, b);
  // Terminating the b list would be incorrect here
  // if there was any chance that the environment update below
  // performs GC.
  lbm_set_cdr(b, ENC_SYM_NIL);

  lbm_value cmp_body = sptr[0];
  lbm_value cmp_env = sptr[1];
  lbm_value par1 = sptr[2];
  lbm_value par2 = sptr[3];
  // Environment should be preallocated already at this point
  // and the operations below should never need GC.
  lbm_value new_env0 = lbm_env_set(cmp_env, par1, lbm_car(a));
  lbm_value new_env = lbm_env_set(cmp_env, par2, lbm_car(b));
  if (lbm_is_symbol(new_env0) || lbm_is_symbol(new_env)) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }
  cmp_env = new_env;

  lbm_uint *merge_cont = stack_reserve(ctx, 11);
  merge_cont[0] = MERGE_LAYER;
  merge_cont[1] = ENC_SYM_NIL;
  merge_cont[2] = ENC_SYM_NIL;
  merge_cont[3] = a;
  merge_cont[4] = a_rest;
  merge_cont[5] = b_rest;
  merge_cont[6] = cmp_body;
  merge_cont[7] = cmp_env;
  merge_cont[8] = par1;
  merge_cont[9] = par2;
  merge_cont[10] = MERGE_REST;
  ctx->curr_exp = cmp_body;
  ctx->curr_env = cmp_env;
  return;
}

/****************************************************/
/*   READER                                         */

static void read_finish(lbm_char_channel_t *str, eval_context_t *ctx) {

  /* Tokenizer reached "end of file"
     The parser could be in a state where it needs
     more tokens to correctly finish an expression.

     Four cases
     1. The program / expression is malformed and the context should die.
     2. We are finished reading a program and should close off the
     internal representation with a closing parenthesis. Then
     apply continuation.
     3. We are finished reading an expression and should
     apply the continuation
     4. We are finished read-and-evaluating

     In case 2, we should find the READ_DONE at sp - 5.
     In case 3, we should find the READ_DONE at sp - 1.
     In case 4, we should find the READ_DONE at sp - 4.

     case 3 should not end up here, but rather end up in
     cont_read_done.
  */

  if (lbm_is_symbol(ctx->r)) {
    lbm_uint sym_val = lbm_dec_sym(ctx->r);
    if (sym_val >= TOKENIZER_SYMBOLS_START &&
        sym_val <= TOKENIZER_SYMBOLS_END) {
      read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
    }
  }

  if (ctx->K.sp > 4  && (ctx->K.data[ctx->K.sp - 4] == READ_DONE) &&
      (ctx->K.data[ctx->K.sp - 5] == READING_PROGRAM_INCREMENTALLY)) {
    /* read and evaluate is done */
    lbm_value env;
    lbm_value s;
    lbm_value sym;
    lbm_pop_3(&ctx->K, &sym, &env, &s);
    ctx->curr_env = env;
    ctx->app_cont = true; // Program evaluated and result is in ctx->r.
  } else if (ctx->K.sp > 5 && (ctx->K.data[ctx->K.sp - 5] == READ_DONE) &&
             (ctx->K.data[ctx->K.sp - 6] == READING_PROGRAM)) {
    /* successfully finished reading a program  (CASE 2) */
    ctx->r = ENC_SYM_CLOSEPAR;
    ctx->app_cont = true;
  } else {
    if (lbm_channel_row(str) == 1 && lbm_channel_column(str) == 1) {
      // (read "") evaluates to nil.
      ctx->r = ENC_SYM_NIL;
      ctx->app_cont = true;
    } else {
      lbm_channel_reader_close(str);
      lbm_set_error_reason((char*)lbm_error_str_parse_eof);
      read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
    }
  }
}

/* cont_read_next_token
   sp-2 : Stream
   sp-1 : Grab row
*/
static void cont_read_next_token(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 2);
  lbm_value stream = sptr[0];
  lbm_value grab_row0 = sptr[1];

  lbm_char_channel_t *chan = lbm_dec_channel(stream);
  if (chan == NULL || chan->state == NULL) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }

  if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
    lbm_stack_drop(&ctx->K, 2);
    read_finish(chan, ctx);
    return;
  }
  /* Eat whitespace and comments */
  if (!tok_clean_whitespace(chan)) {
    sptr[0] = stream;
    sptr[1] = lbm_enc_u(0);
    stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
    yield_ctx(EVAL_CPS_MIN_SLEEP);
    return;
  }
  /* After eating whitespace we may be at end of file/stream */
  if (!lbm_channel_more(chan) && lbm_channel_is_empty(chan)) {
    lbm_stack_drop(&ctx->K, 2);
    read_finish(chan, ctx);
    return;
  }

  if (lbm_dec_u(grab_row0)) {
    ctx->row0 = (int32_t)lbm_channel_row(chan);
    ctx->row1 = -1; // a new start, end is unknown
  }

  /* Attempt to extract tokens from the character stream */
  int n = 0;
  lbm_value res = ENC_SYM_NIL;
  unsigned int string_len = 0;

  /*
   * SYNTAX
   */
  uint32_t match;
  n = tok_syntax(chan, &match);
  if (n > 0) {
    if (!lbm_channel_drop(chan, (unsigned int)n)) {
      error_ctx(ENC_SYM_FATAL_ERROR);
    }
    ctx->app_cont = true;
    switch(match) {
    case TOKOPENPAR: {
      sptr[0] = ENC_SYM_NIL;
      sptr[1] = ENC_SYM_NIL;
      lbm_value *rptr = stack_reserve(ctx,5);
      rptr[0] = stream;
      rptr[1] = READ_APPEND_CONTINUE;
      rptr[2] = stream;
      rptr[3] = lbm_enc_u(0);
      rptr[4] = READ_NEXT_TOKEN;
      ctx->r = ENC_SYM_OPENPAR;
    } return;
    case TOKCLOSEPAR: {
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = ENC_SYM_CLOSEPAR;
    } return;
    case TOKOPENBRACK: {
      sptr[0] = stream;
      sptr[1] = READ_START_ARRAY;
      lbm_value *rptr = stack_reserve(ctx, 3);
      rptr[0] = stream;
      rptr[1] = lbm_enc_u(0);
      rptr[2] = READ_NEXT_TOKEN;
      ctx->r = ENC_SYM_OPENBRACK;
    } return;
    case TOKCLOSEBRACK:
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = ENC_SYM_CLOSEBRACK;
      return;
    case TOKDOT:
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = ENC_SYM_DOT;
      return;
    case TOKDONTCARE:
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = ENC_SYM_DONTCARE;
      return;
    case TOKQUOTE:
      sptr[0] = ENC_SYM_QUOTE;
      sptr[1] = WRAP_RESULT;
      break;
    case TOKBACKQUOTE: {
      sptr[0] = QQ_EXPAND_START;
      sptr[1] = stream;
      lbm_value *rptr = stack_reserve(ctx, 2);
      rptr[0] = lbm_enc_u(0);
      rptr[1] = READ_NEXT_TOKEN;
      ctx->app_cont = true;
    } return;
    case TOKCOMMAAT:
      sptr[0] = ENC_SYM_COMMAAT;
      sptr[1] = WRAP_RESULT;
      break;
    case TOKCOMMA:
      sptr[0] = ENC_SYM_COMMA;
      sptr[1] = WRAP_RESULT;
      break;
    case TOKMATCHANY:
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = ENC_SYM_MATCH_ANY;
      return;
    case TOKOPENCURL: {
      sptr[0] = ENC_SYM_NIL;
      sptr[1] = ENC_SYM_NIL;
      lbm_value *rptr = stack_reserve(ctx,2);
      rptr[0] = stream;
      rptr[1] = READ_APPEND_CONTINUE;
      ctx->r = ENC_SYM_PROGN;
    } return;
    case TOKCLOSECURL:
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = ENC_SYM_CLOSEPAR;
      return;
    case TOKCONSTSTART: /* fall through */
    case TOKCONSTEND: {
      if (match == TOKCONSTSTART)  ctx->flags |= EVAL_CPS_CONTEXT_FLAG_CONST;
      if (match == TOKCONSTEND)    ctx->flags &= ~EVAL_CPS_CONTEXT_FLAG_CONST;
      sptr[0] = stream;
      sptr[1] = lbm_enc_u(0);
      stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
      ctx->app_cont = true;
    } return;
    default:
      read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
    }
    // read next token
    lbm_value *rptr = stack_reserve(ctx, 3);
    rptr[0] = stream;
    rptr[1] = lbm_enc_u(0);
    rptr[2] = READ_NEXT_TOKEN;
    ctx->app_cont = true;
    return;
  } else if (n < 0) goto retry_token;

  /*
   *  STRING
   */
  n = tok_string(chan, &string_len);
  if (n >= 2) {
    lbm_channel_drop(chan, (unsigned int)n);
#ifdef LBM_ALWAYS_GC
    gc();
#endif
    if (!lbm_heap_allocate_array(&res, (unsigned int)(string_len+1))) {
      gc();
      lbm_heap_allocate_array(&res, (unsigned int)(string_len+1));
    }
    if (lbm_is_ptr(res)) {
      lbm_array_header_t *arr = assume_array(res);
      char *data = (char*)arr->data;
      memset(data,0, string_len + 1);
      memcpy(data, tokpar_sym_str, string_len);
      lbm_stack_drop(&ctx->K, 2);
      ctx->r = res;
      ctx->app_cont = true;
      return;
    } else {
      error_ctx(ENC_SYM_MERROR);
    }
  } else if (n < 0) goto retry_token;

  /*
   * FLOAT
   */
  token_float f_val;
  n = tok_double(chan, &f_val);
  if (n > 0) {
    lbm_channel_drop(chan, (unsigned int) n);
    switch(f_val.type) {
    case TOKTYPEF32:
      WITH_GC(res, lbm_enc_float((float)f_val.value));
      break;
    case TOKTYPEF64:
      res = lbm_enc_double(f_val.value);
      break;
    default:
      read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
    }
    lbm_stack_drop(&ctx->K, 2);
    ctx->r = res;
    ctx->app_cont = true;
    return;
  } else if (n < 0) goto retry_token;

  /*
   * INTEGER
   */
  token_int int_result;
  n = tok_integer(chan, &int_result);
  if (n > 0) {
    lbm_channel_drop(chan, (unsigned int)n);
    switch(int_result.type) {
    case TOKTYPEBYTE:
      res = lbm_enc_char((uint8_t)(int_result.negative ? -int_result.value : int_result.value));
      break;
    case TOKTYPEI:
      res = lbm_enc_i((lbm_int)(int_result.negative ? -int_result.value : int_result.value));
      break;
    case TOKTYPEU:
      res = lbm_enc_u((lbm_uint)(int_result.negative ? -int_result.value : int_result.value));
      break;
    case TOKTYPEI32:
      WITH_GC(res, lbm_enc_i32((int32_t)(int_result.negative ? -int_result.value : int_result.value)));
      break;
    case TOKTYPEU32:
      WITH_GC(res,lbm_enc_u32((uint32_t)(int_result.negative ? -int_result.value : int_result.value)));
      break;
    case TOKTYPEI64:
      WITH_GC(res,lbm_enc_i64((int64_t)(int_result.negative ? -int_result.value : int_result.value)));
      break;
    case TOKTYPEU64:
      WITH_GC(res,lbm_enc_u64((uint64_t)(int_result.negative ? -int_result.value : int_result.value)));
      break;
    default:
      read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
    }
    lbm_stack_drop(&ctx->K, 2);
    ctx->r = res;
    ctx->app_cont = true;
    return;
  } else if (n < 0) goto retry_token;

  /*
   * SYMBOL
   */
  n = tok_symbol(chan);
  if (n > 0) {
    lbm_channel_drop(chan, (unsigned int) n);
    lbm_uint symbol_id;
    if (!lbm_get_symbol_by_name(tokpar_sym_str, &symbol_id)) {
      int r = 0;
      if (n > 4 &&
          tokpar_sym_str[0] == 'e' &&
          tokpar_sym_str[1] == 'x' &&
          tokpar_sym_str[2] == 't' &&
          tokpar_sym_str[3] == '-') {
        lbm_uint ext_id;
        lbm_uint ext_name_len = (lbm_uint)n + 1;
#ifdef LBM_ALWAYS_GC
        gc();
#endif
        char *ext_name = lbm_malloc(ext_name_len);
        if (!ext_name) {
          gc();
          ext_name = lbm_malloc(ext_name_len);
        }
        if (ext_name) {
          memcpy(ext_name, tokpar_sym_str, ext_name_len);
          r = lbm_add_extension(ext_name, lbm_extensions_default);
          if (!lbm_lookup_extension_id(ext_name, &ext_id)) {
            error_ctx(ENC_SYM_FATAL_ERROR);
          }
          symbol_id = ext_id;
        } else {
          error_ctx(ENC_SYM_MERROR);
        }
      } else {
        if (ctx->flags & EVAL_CPS_CONTEXT_FLAG_CONST &&
            ctx->flags & EVAL_CPS_CONTEXT_FLAG_INCREMENTAL_READ) {
          r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id, true); //flash
          if (!r) {
            lbm_set_error_reason((char*)lbm_error_str_flash_error);
            error_ctx(ENC_SYM_FATAL_ERROR);
          }
        } else {
#ifdef LBM_ALWAYS_GC
          gc();
#endif
          r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false); //ram
          if (!r) {
            gc();
            r = lbm_add_symbol_base(tokpar_sym_str, &symbol_id,false); //ram
          }
        }
      }
      if (!r) {
        read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
      }
    }
    lbm_stack_drop(&ctx->K, 2);
    ctx->r = lbm_enc_sym(symbol_id);
    ctx->app_cont = true;
    return;
  } else if (n == TOKENIZER_NEED_MORE) {
    goto retry_token;
  } else if (n <= TOKENIZER_STRING_ERROR) {
    read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
  }

  /*
   * CHAR
   */
  char c_val;
  n = tok_char(chan, &c_val);
  if(n > 0) {
    lbm_channel_drop(chan,(unsigned int) n);
    lbm_stack_drop(&ctx->K, 2);
    ctx->r = lbm_enc_char((uint8_t)c_val);
    ctx->app_cont = true;
    return;
  }else if (n < 0) goto retry_token;

  read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));

 retry_token:
  if (n == TOKENIZER_NEED_MORE) {
    sptr[0] = stream;
    sptr[1] = lbm_enc_u(0);
    stack_reserve(ctx,1)[0] = READ_NEXT_TOKEN;
    yield_ctx(EVAL_CPS_MIN_SLEEP);
    return;
  }
  read_error_ctx(lbm_channel_row(chan), lbm_channel_column(chan));
}

static void cont_read_start_array(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 1);
  lbm_value stream = sptr[0];

  lbm_char_channel_t *str = lbm_dec_channel(stream);
  if (str == NULL || str->state == NULL) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }
  if (ctx->r == ENC_SYM_CLOSEBRACK) {
    lbm_value array;

    if (!lbm_heap_allocate_array(&array, 0)) {
      gc();
      if (!lbm_heap_allocate_array(&array, 0)) {
        lbm_set_error_reason((char*)lbm_error_str_read_no_mem);
        lbm_channel_reader_close(str);
        error_ctx(ENC_SYM_FATAL_ERROR); // Terminates ctx
      }
    }
    lbm_stack_drop(&ctx->K, 1);
    ctx->r = array;
    ctx->app_cont = true;
  } else if (lbm_is_number(ctx->r)) {
#ifdef LBM_ALWAYS_GC
    gc();
#endif
    lbm_uint num_free = lbm_memory_longest_free();
    lbm_uint initial_size = (lbm_uint)((float)num_free * 0.9);
    if (initial_size == 0) {
      gc();
      num_free = lbm_memory_longest_free();
      initial_size = (lbm_uint)((float)num_free * 0.9);
      if (initial_size == 0) {
        lbm_channel_reader_close(str);
        error_ctx(ENC_SYM_MERROR);
      }
    }
    lbm_value array;
    initial_size = sizeof(lbm_uint) * initial_size;

    // Keep in mind that this allocation can fail for both
    // lbm_memory and heap reasons.
    if (!lbm_heap_allocate_array(&array, initial_size)) {
      gc();
      if (!lbm_heap_allocate_array(&array, initial_size)) {
        lbm_set_error_reason((char*)lbm_error_str_read_no_mem);
        lbm_channel_reader_close(str);
        error_ctx(ENC_SYM_FATAL_ERROR);
        // NOTE: If array is not created evaluation ends here.
        // Static analysis seems unaware.
      }
    }

    sptr[0] = array;
    lbm_value *rptr = stack_reserve(ctx, 4);
    rptr[0] = lbm_enc_u(initial_size);
    rptr[1] = lbm_enc_u(0);
    rptr[2] = stream;
    rptr[3] = READ_APPEND_ARRAY;
    ctx->app_cont = true;
  } else {
    lbm_channel_reader_close(str);
    read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
  }
}

static void cont_read_append_array(eval_context_t *ctx) {
  lbm_uint *sptr = get_stack_ptr(ctx, 4);

  lbm_value array  = sptr[0];
  lbm_value size   = lbm_dec_as_u32(sptr[1]);
  lbm_value ix     = lbm_dec_as_u32(sptr[2]);
  lbm_value stream = sptr[3];

  if (ix >= (size - 1)) {
    error_ctx(ENC_SYM_MERROR);
  }

  // if sptr[0] is not an array something is very very wrong.
  // Not robust against a garbage on stack. But how would garbage get onto stack?
  lbm_array_header_t *arr = assume_array(array);
  if (lbm_is_number(ctx->r)) {
    ((uint8_t*)arr->data)[ix] = (uint8_t)lbm_dec_as_u32(ctx->r);

    sptr[2] = lbm_enc_u(ix + 1);
    lbm_value *rptr = stack_reserve(ctx, 4);
    rptr[0] = READ_APPEND_ARRAY;
    rptr[1] = stream;
    rptr[2] = lbm_enc_u(0);
    rptr[3] = READ_NEXT_TOKEN;
    ctx->app_cont = true;
  } else if (lbm_is_symbol(ctx->r) && ctx->r == ENC_SYM_CLOSEBRACK) {
    lbm_uint array_size = ix / sizeof(lbm_uint);

    if (ix % sizeof(lbm_uint) != 0) {
      array_size = array_size + 1;
    }
    lbm_memory_shrink((lbm_uint*)arr->data, array_size);
    arr->size = ix;
    lbm_stack_drop(&ctx->K, 4);
    ctx->r = array;
    ctx->app_cont = true;
  } else {
    error_ctx(ENC_SYM_TERROR);
  }
}

static void cont_read_append_continue(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 3);

  lbm_value first_cell = sptr[0];
  lbm_value last_cell  = sptr[1];
  lbm_value stream     = sptr[2];

  lbm_char_channel_t *str = lbm_dec_channel(stream);
  if (str == NULL || str->state == NULL) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }

  if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {

    switch(ctx->r) {
    case ENC_SYM_CLOSEPAR:
      if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
        lbm_set_cdr(last_cell, ENC_SYM_NIL); // terminate the list
        ctx->r = first_cell;
      } else {
        ctx->r = ENC_SYM_NIL;
      }
      lbm_stack_drop(&ctx->K, 3);
      /* Skip reading another token and apply the continuation */
      ctx->app_cont = true;
      return;
    case ENC_SYM_DOT: {
      lbm_value *rptr = stack_reserve(ctx, 4);
      rptr[0] = READ_DOT_TERMINATE;
      rptr[1] = stream;
      rptr[2] = lbm_enc_u(0);
      rptr[3] = READ_NEXT_TOKEN;
      ctx->app_cont = true;
    } return;
    }
  }
  lbm_value new_cell = cons_with_gc(ctx->r, ENC_SYM_NIL, ENC_SYM_NIL);
  if (lbm_is_symbol_merror(new_cell)) {
    lbm_channel_reader_close(str);
    read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
    return;
  }
  if (lbm_type_of(last_cell) == LBM_TYPE_CONS) {
    lbm_set_cdr(last_cell, new_cell);
    last_cell = new_cell;
  } else {
    first_cell = last_cell = new_cell;
  }
  sptr[0] = first_cell;
  sptr[1] = last_cell;
  sptr[2] = stream;    // unchanged.
  lbm_value *rptr = stack_reserve(ctx, 4);
  rptr[0] = READ_APPEND_CONTINUE;
  rptr[1] = stream;
  rptr[2] = lbm_enc_u(0);
  rptr[3] = READ_NEXT_TOKEN;
  ctx->app_cont = true;
}

static void cont_read_eval_continue(eval_context_t *ctx) {
  lbm_value env;
  lbm_value stream;
  lbm_pop_2(&ctx->K, &env, &stream);

  lbm_char_channel_t *str = lbm_dec_channel(stream);
  if (str && str->state) {
    ctx->row1 = (lbm_int)str->row(str);
    if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL) {
      switch(ctx->r) {
      case ENC_SYM_CLOSEPAR:
        ctx->app_cont = true;
        return;
      case ENC_SYM_DOT:
        // A dot here is a syntax error.
        lbm_set_error_reason((char*)lbm_error_str_parse_dot);
        read_error_ctx(lbm_channel_row(str),lbm_channel_column(str));
        return;
      }
    }
    lbm_value *rptr = stack_reserve(ctx, 8);
    rptr[0] = stream;
    rptr[1] = env;
    rptr[2] = READ_EVAL_CONTINUE;
    rptr[3] = stream;
    rptr[4] = lbm_enc_u(1);
    rptr[5] = READ_NEXT_TOKEN;
    rptr[6] = lbm_enc_u(ctx->flags);
    rptr[7] = POP_READER_FLAGS;

    ctx->curr_env = env;
    ctx->curr_exp = ctx->r;
  } else {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }
}

static void cont_read_expect_closepar(eval_context_t *ctx) {
  lbm_value res;
  lbm_value stream;

  lbm_pop_2(&ctx->K, &res, &stream);

  lbm_char_channel_t *str = lbm_dec_channel(stream);
  if (str == NULL || str->state == NULL) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }

  if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
      ctx->r == ENC_SYM_CLOSEPAR) {
    ctx->r = res;
    ctx->app_cont = true;
  } else {
    lbm_channel_reader_close(str);
    lbm_set_error_reason((char*)lbm_error_str_parse_close);
    read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
  }
}

static void cont_read_dot_terminate(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 3);

  lbm_value last_cell  = sptr[1];
  lbm_value stream = sptr[2];

  lbm_char_channel_t *str = lbm_dec_channel(stream);
  if (str == NULL || str->state == NULL) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }

  lbm_stack_drop(&ctx->K ,3);

  if (lbm_type_of(ctx->r) == LBM_TYPE_SYMBOL &&
      (ctx->r == ENC_SYM_CLOSEPAR ||
       ctx->r == ENC_SYM_DOT)) {
    lbm_channel_reader_close(str);
    lbm_set_error_reason((char*)lbm_error_str_parse_dot);
    read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
  } else {
    if (lbm_is_cons(last_cell)) {
      lbm_set_cdr(last_cell, ctx->r);
      ctx->r = sptr[0]; // first cell
      lbm_value *rptr = stack_reserve(ctx, 6);
      rptr[0] = stream;
      rptr[1] = ctx->r;
      rptr[2] = READ_EXPECT_CLOSEPAR;
      rptr[3] = stream;
      rptr[4] = lbm_enc_u(0);
      rptr[5] = READ_NEXT_TOKEN;
      ctx->app_cont = true;
    } else {
      lbm_channel_reader_close(str);
      lbm_set_error_reason((char*)lbm_error_str_parse_dot);
      read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
    }
  }
}

static void cont_read_done(eval_context_t *ctx) {
  lbm_value stream;
  lbm_value f_val;
  lbm_value reader_mode;
  lbm_pop_3(&ctx->K, &reader_mode, &stream, &f_val);

  uint32_t flags = lbm_dec_as_u32(f_val);
  ctx->flags &= ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
  ctx->flags |= (flags & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);

  lbm_char_channel_t *str = lbm_dec_channel(stream);
  if (str == NULL || str->state == NULL) {
    error_ctx(ENC_SYM_FATAL_ERROR);
  }

  lbm_channel_reader_close(str);
  if (lbm_is_symbol(ctx->r)) {
    lbm_uint sym_val = lbm_dec_sym(ctx->r);
    if (sym_val >= TOKENIZER_SYMBOLS_START &&
        sym_val <= TOKENIZER_SYMBOLS_END) {
      read_error_ctx(lbm_channel_row(str), lbm_channel_column(str));
    }
  }
  ctx->row0 = -1;
  ctx->row1 = -1;
  ctx->app_cont = true;
}

static void cont_wrap_result(eval_context_t *ctx) {
  lbm_value cell;
  lbm_value wrapper;
  lbm_pop(&ctx->K, &wrapper);
  WITH_GC(cell, lbm_heap_allocate_list_init(2,
                                            wrapper,
                                            ctx->r));
  ctx->r = cell;
  ctx->app_cont = true;
}

static void cont_application_start(eval_context_t *ctx) {

  /* sptr[0] = env
   * sptr[1] = args
   * ctx->r  = function
   */

  if (lbm_is_symbol(ctx->r)) {
    stack_reserve(ctx,1)[0] = lbm_enc_u(0);
    cont_application_args(ctx);
  } else if (lbm_is_cons(ctx->r)) {
    lbm_uint *sptr = get_stack_ptr(ctx, 2);
    lbm_value args = (lbm_value)sptr[1];
    switch (get_car(ctx->r)) {
    case ENC_SYM_CLOSURE: {
      lbm_value cl[3];
      extract_n(get_cdr(ctx->r), cl, 3);
      lbm_value arg_env = (lbm_value)sptr[0];
      lbm_value arg0, arg_rest;
      get_car_and_cdr(args, &arg0, &arg_rest);
      sptr[1] = cl[CLO_BODY];
      bool a_nil = lbm_is_symbol_nil(args);
      bool p_nil = lbm_is_symbol_nil(cl[CLO_PARAMS]);
      lbm_value *reserved = stack_reserve(ctx, 4);

      if (!a_nil && !p_nil) {
        reserved[0] = cl[CLO_ENV];
        reserved[1] = cl[CLO_PARAMS];
        reserved[2] = arg_rest;
        reserved[3] = CLOSURE_ARGS;
        ctx->curr_exp = arg0;
        ctx->curr_env = arg_env;
      } else if (a_nil && p_nil) {
        // No params, No args
        lbm_stack_drop(&ctx->K, 6);
        ctx->curr_exp = cl[CLO_BODY];
        ctx->curr_env = cl[CLO_ENV];
      } else if (p_nil) {
        reserved[1] = get_cdr(args);      // protect cdr(args) from allocate_binding
        ctx->curr_exp = get_car(args);    // protect car(args) from allocate binding
        ctx->curr_env = arg_env;
        lbm_value rest_binder = allocate_binding(ENC_SYM_REST_ARGS, ENC_SYM_NIL, cl[CLO_ENV]);
        reserved[0] = rest_binder;
        reserved[2] = get_car(rest_binder);
        reserved[3] = CLOSURE_ARGS_REST;
      } else {
        lbm_set_error_reason((char*)lbm_error_str_num_args);
        error_at_ctx(ENC_SYM_EERROR, ctx->r);
      }
    } break;
    case ENC_SYM_CONT:{
      /* Continuation created using call-cc.
       * ((SYM_CONT . cont-array) arg0 )
       */
      lbm_value c = get_cdr(ctx->r); /* should be the continuation array*/

      if (!lbm_is_lisp_array_r(c)) {
        error_ctx(ENC_SYM_FATAL_ERROR);
      }

      lbm_uint arg_count = lbm_list_length(args);
      lbm_value arg = ENC_SYM_NIL;
      switch (arg_count) {
      case 0:
        arg = ENC_SYM_NIL;
        break;
      case 1:
        arg = get_car(args);
        break;
      default:
        lbm_set_error_reason((char*)lbm_error_str_num_args);
        error_ctx(ENC_SYM_EERROR);
      }
      lbm_stack_clear(&ctx->K);

      lbm_array_header_t *arr = assume_array(c);
      ctx->K.sp = arr->size / sizeof(lbm_uint);
      memcpy(ctx->K.data, arr->data, arr->size);

      lbm_value atomic;
      lbm_pop(&ctx->K, &atomic);
      is_atomic = atomic ? 1 : 0;

      ctx->curr_exp = arg;
      break;
    }
    case ENC_SYM_MACRO:{
      /*
       * Perform macro expansion.
       * Macro expansion is really just evaluation in an
       * environment augmented with the unevaluated expressions passed
       * as arguments.
       */
      lbm_value env = (lbm_value)sptr[0];

      lbm_value curr_param = get_cadr(ctx->r);
      lbm_value curr_arg = args;
      lbm_value expand_env = env;
      while (lbm_is_cons(curr_param) &&
             lbm_is_cons(curr_arg)) {
        lbm_cons_t *param_cell = lbm_ref_cell(curr_param); // already checked that cons.
        lbm_cons_t *arg_cell = lbm_ref_cell(curr_arg);
        lbm_value car_curr_param = param_cell->car;
        lbm_value cdr_curr_param = param_cell->cdr;
        lbm_value car_curr_arg = arg_cell->car;
        lbm_value cdr_curr_arg = arg_cell->cdr;

        lbm_value entry = cons_with_gc(car_curr_param, car_curr_arg, expand_env);
        lbm_value aug_env = cons_with_gc(entry, expand_env,ENC_SYM_NIL);
        expand_env = aug_env;

        curr_param = cdr_curr_param;
        curr_arg   = cdr_curr_arg;
      }
      /* Two rounds of evaluation is performed.
       * First to instantiate the arguments into the macro body.
       * Second to evaluate the resulting program.
       */
      sptr[1] = EVAL_R;
      lbm_value exp = get_cadr(get_cdr(ctx->r));
      ctx->curr_exp = exp;
      ctx->curr_env = expand_env;
    } break;
    default:
      error_ctx(ENC_SYM_EERROR);
    }
  } else {
    error_ctx(ENC_SYM_EERROR);
  }
}

static void cont_eval_r(eval_context_t* ctx) {
  lbm_value env;
  lbm_pop(&ctx->K, &env);
  ctx->curr_exp = ctx->r;
  ctx->curr_env = env;
}

static void cont_progn_var(eval_context_t* ctx) {

  lbm_value key;
  lbm_value env;

  lbm_pop_2(&ctx->K, &key, &env);

  if (fill_binding_location(key, ctx->r, env) < 0) {
    lbm_set_error_reason("Incorrect type of name/key in let-binding");
    error_at_ctx(ENC_SYM_TERROR, key);
  }

  ctx->app_cont = true;
}

static void cont_setq(eval_context_t *ctx) {
  lbm_value sym;
  lbm_value env;
  lbm_pop_2(&ctx->K, &sym, &env);
  lbm_value res;
  WITH_GC(res, perform_setvar(sym, ctx->r, env));
  ctx->r = res;
  ctx->app_cont = true;
}

lbm_flash_status request_flash_storage_cell(lbm_value val, lbm_value *res) {

  lbm_value flash_cell;
  lbm_flash_status s = lbm_allocate_const_cell(&flash_cell);
  if (s != LBM_FLASH_WRITE_OK)
    return s;
  lbm_value new_val = val;
  new_val &= ~LBM_PTR_VAL_MASK; // clear the value part of the ptr
  new_val |= (flash_cell & LBM_PTR_VAL_MASK);
  new_val |= LBM_PTR_TO_CONSTANT_BIT;
  *res = new_val;
  return s;
}

static void cont_move_to_flash(eval_context_t *ctx) {

  lbm_value args;
  lbm_pop(&ctx->K, &args);

  if (lbm_is_symbol_nil(args)) {
    // Done looping over arguments. return true.
    ctx->r = ENC_SYM_TRUE;
    ctx->app_cont = true;
    return;
  }

  lbm_value first_arg, rest;
  get_car_and_cdr(args, &first_arg, &rest);

  lbm_value val;
  if (lbm_is_symbol(first_arg) && lbm_global_env_lookup(&val, first_arg)) {
    // Prepare to copy the rest of the arguments when done with first.
    lbm_value *rptr = stack_reserve(ctx, 2);
    rptr[0] = rest;
    rptr[1] = MOVE_TO_FLASH;
    if (lbm_is_ptr(val) &&
        (!(val & LBM_PTR_TO_CONSTANT_BIT))) {
      lbm_value * rptr1 = stack_reserve(ctx, 3);
      rptr1[0] = first_arg;
      rptr1[1] = SET_GLOBAL_ENV;
      rptr1[2] = MOVE_VAL_TO_FLASH_DISPATCH;
      ctx->r = val;
    }
    ctx->app_cont = true;
    return;
  }
  error_ctx(ENC_SYM_EERROR);
}

static void cont_move_val_to_flash_dispatch(eval_context_t *ctx) {

  lbm_value val = ctx->r;

  if (lbm_is_cons(val)) {
    lbm_value *rptr = stack_reserve(ctx, 5);
    rptr[0] = ENC_SYM_NIL; // fst cell of list
    rptr[1] = ENC_SYM_NIL; // last cell of list
    rptr[2] = get_cdr(val);
    rptr[3] = MOVE_LIST_TO_FLASH;
    rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
    ctx->r = get_car(val);
    ctx->app_cont = true;
    return;
  }

  if (lbm_is_ptr(val) && (val & LBM_PTR_TO_CONSTANT_BIT)) {
    //ctx->r unchanged
    ctx->app_cont = true;
    return;
  }

  if (lbm_is_ptr(val)) {
    lbm_cons_t *ref = lbm_ref_cell(val);
    if (lbm_type_of(ref->cdr) == LBM_TYPE_SYMBOL) {
      switch (ref->cdr) {
      case ENC_SYM_RAW_I_TYPE: /* fall through */
      case ENC_SYM_RAW_U_TYPE:
      case ENC_SYM_RAW_F_TYPE: {
        lbm_value flash_cell = ENC_SYM_NIL;
        handle_flash_status(request_flash_storage_cell(val, &flash_cell));
        handle_flash_status(write_const_car(flash_cell, ref->car));
        handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
        ctx->r = flash_cell;
      } break;
      case ENC_SYM_IND_I_TYPE: /* fall through */
      case ENC_SYM_IND_U_TYPE:
      case ENC_SYM_IND_F_TYPE: {
#ifndef LBM64
        /* 64 bit values are in lbm mem on 32bit platforms. */
        lbm_uint *lbm_mem_ptr = (lbm_uint*)ref->car;
        lbm_uint flash_ptr;

        handle_flash_status(lbm_write_const_raw(lbm_mem_ptr, 2, &flash_ptr));
        lbm_value flash_cell = ENC_SYM_NIL;
        handle_flash_status(request_flash_storage_cell(val, &flash_cell));
        handle_flash_status(write_const_car(flash_cell, flash_ptr));
        handle_flash_status(write_const_cdr(flash_cell, ref->cdr));
        ctx->r = flash_cell;
#else
        // There are no indirect types in LBM64
        error_ctx(ENC_SYM_FATAL_ERROR);
#endif
      } break;
      case ENC_SYM_LISPARRAY_TYPE: {
        lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
        lbm_uint size = arr->size / sizeof(lbm_uint);
        lbm_uint flash_addr = 0;
        lbm_value *arrdata = (lbm_value *)arr->data;
        lbm_value flash_cell = ENC_SYM_NIL;
        handle_flash_status(request_flash_storage_cell(val, &flash_cell));
        handle_flash_status(lbm_allocate_const_raw(size, &flash_addr));
        lift_array_flash(flash_cell,
                         false,
                         (char *)flash_addr,
                         arr->size);
        // Move array contents to flash recursively
        lbm_value *rptr = stack_reserve(ctx, 5);
        rptr[0] = flash_cell;
        rptr[1] = lbm_enc_u(0);
        rptr[2] = val;
        rptr[3] = MOVE_ARRAY_ELTS_TO_FLASH;
        rptr[4] = MOVE_VAL_TO_FLASH_DISPATCH;
        ctx->r = arrdata[0];
        ctx->app_cont = true;
        return;
      }
      case ENC_SYM_ARRAY_TYPE: {
        lbm_array_header_t *arr = (lbm_array_header_t*)ref->car;
        // arbitrary address: flash_arr.
        lbm_uint flash_arr = 0;
        handle_flash_status(lbm_write_const_array_padded((uint8_t*)arr->data, arr->size, &flash_arr));
        lbm_value flash_cell = ENC_SYM_NIL;
        handle_flash_status(request_flash_storage_cell(val, &flash_cell));
        lift_array_flash(flash_cell,
                         true,
                         (char *)flash_arr,
                         arr->size);
        ctx->r = flash_cell;
      } break;
      case ENC_SYM_CHANNEL_TYPE: /* fall through */
      case ENC_SYM_CUSTOM_TYPE:
        lbm_set_error_reason((char *)lbm_error_str_flash_not_possible);
        error_ctx(ENC_SYM_EERROR);
      }
    } else {
      error_ctx(ENC_SYM_FATAL_ERROR);
    }
    ctx->app_cont = true;
    return;
  }
  ctx->r = val;
  ctx->app_cont = true;
}

static void cont_move_list_to_flash(eval_context_t *ctx) {

  // ctx->r holds the value that should go in car

  lbm_value *sptr = get_stack_ptr(ctx, 3);

  lbm_value fst = sptr[0];
  lbm_value lst = sptr[1];
  lbm_value val = sptr[2];


  lbm_value new_lst = ENC_SYM_NIL;
  // Allocate element ptr storage after storing the element to flash.
  handle_flash_status(request_flash_storage_cell(lbm_enc_cons_ptr(LBM_PTR_NULL), &new_lst));

  if (lbm_is_symbol_nil(fst)) {
    lst = new_lst;
    fst = new_lst;
    handle_flash_status(write_const_car(lst, ctx->r));
  } else {
    handle_flash_status(write_const_cdr(lst, new_lst)); // low before high
    handle_flash_status(write_const_car(new_lst, ctx->r));
    lst = new_lst;
  }

  if (lbm_is_cons(val)) {
    sptr[0] = fst;
    sptr[1] = lst;//rest_cell;
    sptr[2] = get_cdr(val);
    lbm_value *rptr = stack_reserve(ctx, 2);
    rptr[0] = MOVE_LIST_TO_FLASH;
    rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
    ctx->r = get_car(val);
  } else {
    sptr[0] = fst;
    sptr[1] = lst;
    sptr[2] = CLOSE_LIST_IN_FLASH;
    stack_reserve(ctx, 1)[0] = MOVE_VAL_TO_FLASH_DISPATCH;
    ctx->r =  val;
  }
  ctx->app_cont = true;
}

static void cont_close_list_in_flash(eval_context_t *ctx) {
  lbm_value fst;
  lbm_value lst;
  lbm_pop_2(&ctx->K, &lst, &fst);
  lbm_value val = ctx->r;
  handle_flash_status(write_const_cdr(lst, val));
  ctx->r = fst;
  ctx->app_cont = true;
}

static void cont_move_array_elts_to_flash(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 3);
  // sptr[2] = source array in RAM
  // sptr[1] = current index
  // sptr[0] = target array in flash
  lbm_array_header_t *src_arr = assume_array(sptr[2]);
  lbm_uint size = src_arr->size / sizeof(lbm_uint);
  lbm_value *srcdata = (lbm_value *)src_arr->data;

  lbm_array_header_t *tgt_arr = assume_array(sptr[0]);
  lbm_uint *tgtdata = (lbm_value *)tgt_arr->data;
  lbm_uint ix = lbm_dec_as_u32(sptr[1]);
  handle_flash_status(lbm_const_write(&tgtdata[ix], ctx->r));
  if (ix >= size-1) {
    ctx->r = sptr[0];
    lbm_stack_drop(&ctx->K, 3);
    ctx->app_cont = true;
    return;
  }
  sptr[1] = lbm_enc_u(ix + 1);
  lbm_value *rptr = stack_reserve(ctx, 2);
  rptr[0] = MOVE_ARRAY_ELTS_TO_FLASH;
  rptr[1] = MOVE_VAL_TO_FLASH_DISPATCH;
  ctx->r = srcdata[ix+1];
  ctx->app_cont = true;
  return;
}

static void cont_qq_expand_start(eval_context_t *ctx) {
  lbm_value *rptr = stack_reserve(ctx, 2);
  rptr[0] = ctx->r;
  rptr[1] = QQ_EXPAND;
  ctx->r = ENC_SYM_NIL;
  ctx->app_cont = true;
}

lbm_value quote_it(lbm_value qquoted) {
  if (lbm_is_symbol(qquoted) &&
      lbm_is_special(qquoted)) return qquoted;

  lbm_value val = cons_with_gc(qquoted, ENC_SYM_NIL, ENC_SYM_NIL);
  return cons_with_gc(ENC_SYM_QUOTE, val, ENC_SYM_NIL);
}

bool is_append(lbm_value a) {
  return (lbm_is_cons(a) &&
          lbm_is_symbol(get_car(a)) &&
          (get_car(a) == ENC_SYM_APPEND));
}

lbm_value append(lbm_value front, lbm_value back) {
  if (lbm_is_symbol_nil(front)) return back;
  if (lbm_is_symbol_nil(back)) return front;

  if (lbm_is_quoted_list(front) &&
      lbm_is_quoted_list(back)) {
    lbm_value f = get_cadr(front);
    lbm_value b = get_cadr(back);
    return quote_it(lbm_list_append(f, b));
  }

  if (is_append(back) &&
      lbm_is_quoted_list(get_cadr(back)) &&
       lbm_is_quoted_list(front)) {
    lbm_value ql = get_cadr(back);
    lbm_value f = get_cadr(front);
    lbm_value b = get_cadr(ql);

    lbm_value v = lbm_list_append(f, b);
    lbm_set_car(get_cdr(ql), v);
    return back;
  }

  if (is_append(back)) {
    back  = get_cdr(back);
    lbm_value new = cons_with_gc(front, back, ENC_SYM_NIL);
    return cons_with_gc(ENC_SYM_APPEND, new, ENC_SYM_NIL);
  }

  lbm_value t0, t1;

  t0 = cons_with_gc(back, ENC_SYM_NIL, front);
  t1 = cons_with_gc(front, t0, ENC_SYM_NIL);
  return cons_with_gc(ENC_SYM_APPEND, t1, ENC_SYM_NIL);
}

/* Bawden's qq-expand implementation
(define (qq-expand x)
  (cond ((tag-comma? x)
         (tag-data x))
        ((tag-comma-atsign? x)
         (error "Illegal"))
        ((tag-backquote? x)
         (qq-expand
          (qq-expand (tag-data x))))
        ((pair? x)
         `(append
           ,(qq-expand-list (car x))
           ,(qq-expand (cdr x))))
        (else `',x)))
 */
static void cont_qq_expand(eval_context_t *ctx) {
  lbm_value qquoted;
  lbm_pop(&ctx->K, &qquoted);

  switch(lbm_type_of(qquoted)) {
  case LBM_TYPE_CONS: {
    lbm_value car_val = get_car(qquoted);
    lbm_value cdr_val = get_cdr(qquoted);
    if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
        car_val == ENC_SYM_COMMA) {
      ctx->r = append(ctx->r, get_car(cdr_val));
      ctx->app_cont = true;
    } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
               car_val == ENC_SYM_COMMAAT) {
      error_ctx(ENC_SYM_RERROR);
    } else {
      lbm_value *rptr = stack_reserve(ctx, 6);
      rptr[0] = ctx->r;
      rptr[1] = QQ_APPEND;
      rptr[2] = cdr_val;
      rptr[3] = QQ_EXPAND;
      rptr[4] = car_val;
      rptr[5] = QQ_EXPAND_LIST;
      ctx->app_cont = true;
      ctx->r = ENC_SYM_NIL;
    }

  } break;
  default: {
    lbm_value res = quote_it(qquoted);
    ctx->r = append(ctx->r, res);
    ctx->app_cont = true;
  }
  }
}

static void cont_qq_append(eval_context_t *ctx) {
  lbm_value head;
  lbm_pop(&ctx->K, &head);
  ctx->r = append(head, ctx->r);
  ctx->app_cont = true;
}

/* Bawden's qq-expand-list implementation
(define (qq-expand-list x)
  (cond ((tag-comma? x)
         `(list ,(tag-data x)))
        ((tag-comma-atsign? x)
         (tag-data x))
        ((tag-backquote? x)
         (qq-expand-list
          (qq-expand (tag-data x))))
        ((pair? x)
         `(list
           (append
            ,(qq-expand-list (car x))
            ,(qq-expand (cdr x)))))
        (else `'(,x))))
*/

static void cont_qq_expand_list(eval_context_t* ctx) {
  lbm_value l;
  lbm_pop(&ctx->K, &l);

  ctx->app_cont = true;
  switch(lbm_type_of(l)) {
  case LBM_TYPE_CONS: {
    lbm_value car_val = get_car(l);
    lbm_value cdr_val = get_cdr(l);
    if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
        car_val == ENC_SYM_COMMA) {
      lbm_value tl = cons_with_gc(get_car(cdr_val), ENC_SYM_NIL, ENC_SYM_NIL);
      lbm_value tmp = cons_with_gc(ENC_SYM_LIST, tl, ENC_SYM_NIL);
      ctx->r = append(ctx->r, tmp);
      return;
    } else if (lbm_type_of(car_val) == LBM_TYPE_SYMBOL &&
               car_val == ENC_SYM_COMMAAT) {
      ctx->r = get_car(cdr_val);
      return;
    } else {
      lbm_value *rptr = stack_reserve(ctx, 7);
      rptr[0] = QQ_LIST;
      rptr[1] = ctx->r;
      rptr[2] = QQ_APPEND;
      rptr[3] = cdr_val;
      rptr[4] = QQ_EXPAND;
      rptr[5] = car_val;
      rptr[6] = QQ_EXPAND_LIST;
      ctx->r = ENC_SYM_NIL;
    }

  } break;
  default: {
    lbm_value a_list = cons_with_gc(l, ENC_SYM_NIL, ENC_SYM_NIL);
    lbm_value tl = cons_with_gc(a_list, ENC_SYM_NIL, ENC_SYM_NIL);
    lbm_value tmp = cons_with_gc(ENC_SYM_QUOTE, tl, ENC_SYM_NIL);
    ctx->r = append(ctx->r, tmp);
  }
  }
}

static void cont_qq_list(eval_context_t *ctx) {
  lbm_value val = ctx->r;
  lbm_value apnd_app = cons_with_gc(val, ENC_SYM_NIL, ENC_SYM_NIL);
  lbm_value tmp = cons_with_gc(ENC_SYM_LIST, apnd_app, ENC_SYM_NIL);
  ctx->r = tmp;
  ctx->app_cont = true;
}

static void cont_kill(eval_context_t *ctx) {
  (void) ctx;
  ok_ctx();
}

static void cont_pop_reader_flags(eval_context_t *ctx) {
  lbm_value flags;
  lbm_pop(&ctx->K, &flags);
  ctx->flags = ctx->flags & ~EVAL_CPS_CONTEXT_READER_FLAGS_MASK;
  ctx->flags |= (lbm_dec_as_u32(flags) & EVAL_CPS_CONTEXT_READER_FLAGS_MASK);
  // r is unchanged.
  ctx->app_cont = true;
}

static void cont_exception_handler(eval_context_t *ctx) {
  lbm_value *sptr = pop_stack_ptr(ctx, 2);
  lbm_value retval = sptr[0];
  lbm_value flags = sptr[1];
  lbm_set_car(get_cdr(retval), ctx->r);
  ctx->flags = (uint32_t)flags;
  ctx->r = retval;
  ctx->app_cont = true;
}

// cont_recv_to:
//
// s[sp-1] = patterns
//
// ctx->r = timeout value
static void cont_recv_to(eval_context_t *ctx) {
  if (lbm_is_number(ctx->r)) {
    lbm_value *sptr = get_stack_ptr(ctx, 1); // patterns at sptr[0]
    float timeout_time = lbm_dec_as_float(ctx->r);

    if (ctx->num_mail > 0) {
      lbm_value e;
      lbm_value new_env = ctx->curr_env;
#ifdef LBM_ALWAYS_GC
      gc();
#endif
      int n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
      if (n == FM_NEED_GC) {
        gc();
        new_env = ctx->curr_env;
        n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
        if (n == FM_NEED_GC) error_ctx(ENC_SYM_MERROR);
      }
      if (n == FM_PATTERN_ERROR) {
        lbm_set_error_reason("Incorrect pattern format for recv");
        error_at_ctx(ENC_SYM_EERROR, sptr[0]);
      } else if (n >= 0) { // match
        mailbox_remove_mail(ctx, (lbm_uint)n);
        ctx->curr_env = new_env;
        ctx->curr_exp = e;
        lbm_stack_drop(&ctx->K, 1);
        return;
      }
    }
    // If no mail or no match, go to sleep
    lbm_uint *rptr = stack_reserve(ctx,2);
    rptr[0] = ctx->r; // timeout time
    rptr[1] = RECV_TO_RETRY;
    block_current_ctx(LBM_THREAD_STATE_RECV_TO,S_TO_US(timeout_time),true);
  } else {
    error_ctx(ENC_SYM_TERROR);
  }
}

// cont_recv_to_retry
//
// s[sp-2] = patterns
// s[sp-1] = timeout value
//
// ctx->r = nonsense | timeout symbol
static void cont_recv_to_retry(eval_context_t *ctx) {
  lbm_value *sptr = get_stack_ptr(ctx, 2); //sptr[0] = patterns, sptr[1] = timeout

  // num_mail should be at least 1 here.
  if (ctx->num_mail > 0) {
    lbm_value e;
    lbm_value new_env = ctx->curr_env;
#ifdef LBM_ALWAYS_GC
    gc();
#endif
    int n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
    if (n == FM_NEED_GC) {
      gc();
      new_env = ctx->curr_env;
      n = find_match(sptr[0], ctx->mailbox, ctx->num_mail, &e, &new_env);
      if (n == FM_NEED_GC) error_ctx(ENC_SYM_MERROR);
    }
    if (n == FM_PATTERN_ERROR) {
      lbm_set_error_reason("Incorrect pattern format for recv");
      error_at_ctx(ENC_SYM_EERROR, sptr[0]);
    } else if (n >= 0) { // match
      mailbox_remove_mail(ctx, (lbm_uint)n);
      ctx->curr_env = new_env;
      ctx->curr_exp = e;
      lbm_stack_drop(&ctx->K, 2);
      return;
    }
  }

  // No message matched but the timeout was reached.
  // This is like having a recv-to with no case that matches
  // the timeout symbol.
  if (ctx->r == ENC_SYM_TIMEOUT) {
    lbm_stack_drop(&ctx->K, 2);
    ctx->app_cont = true;
    return;
  }

  //TODO: Timeout is reset if there is a completely unrelated message.
  //      Don't currently have an easy fix for this.
  stack_reserve(ctx,1)[0] = RECV_TO_RETRY;
  block_current_ctx(LBM_THREAD_STATE_RECV_TO,S_TO_US(sptr[1]),true);
}

/*********************************************************/
/* Continuations table                                   */
typedef void (*cont_fun)(eval_context_t *);

static const cont_fun continuations[NUM_CONTINUATIONS] =
  { advance_ctx,  // CONT_DONE
    cont_set_global_env,
    cont_bind_to_key_rest,
    cont_if,
    cont_progn_rest,
    cont_application_args,
    cont_and,
    cont_or,
    cont_wait,
    cont_match,
    cont_application_start,
    cont_eval_r,
    cont_resume,
    cont_closure_application_args,
    cont_exit_atomic,
    cont_read_next_token,
    cont_read_append_continue,
    cont_read_eval_continue,
    cont_read_expect_closepar,
    cont_read_dot_terminate,
    cont_read_done,
    cont_read_start_array,
    cont_read_append_array,
    cont_map,
    cont_match_guard,
    cont_terminate,
    cont_progn_var,
    cont_setq,
    cont_move_to_flash,
    cont_move_val_to_flash_dispatch,
    cont_move_list_to_flash,
    cont_close_list_in_flash,
    cont_qq_expand_start,
    cont_qq_expand,
    cont_qq_append,
    cont_qq_expand_list,
    cont_qq_list,
    cont_kill,
    cont_loop,
    cont_loop_condition,
    cont_merge_rest,
    cont_merge_layer,
    cont_closure_args_rest,
    cont_move_array_elts_to_flash,
    cont_pop_reader_flags,
    cont_exception_handler,
    cont_recv_to,
    cont_wrap_result,
    cont_recv_to_retry
  };

/*********************************************************/
/* Evaluators lookup table (special forms)               */
typedef void (*evaluator_fun)(eval_context_t *);

static const evaluator_fun evaluators[] =
  {
   eval_quote,
   eval_define,
   eval_progn,
   eval_lambda,
   eval_if,
   eval_let,
   eval_and,
   eval_or,
   eval_match,
   eval_receive,
   eval_receive_timeout,
   eval_callcc,
   eval_atomic,
   eval_selfevaluating, // macro
   eval_selfevaluating, // cont
   eval_selfevaluating, // closure
   eval_cond,
   eval_app_cont,
   eval_var,
   eval_setq,
   eval_move_to_flash,
   eval_loop,
   eval_trap
  };


/*********************************************************/
/* Evaluator step function                               */

static void evaluation_step(void){
  eval_context_t *ctx = ctx_running;
#ifdef VISUALIZE_HEAP
  heap_vis_gen_image();
#endif

  if (ctx->app_cont) {
    lbm_value k;
    lbm_pop(&ctx->K, &k);
    ctx->app_cont = false;

    lbm_uint decoded_k = DEC_CONTINUATION(k);

    if (decoded_k < NUM_CONTINUATIONS) {
      continuations[decoded_k](ctx);
    } else {
      error_ctx(ENC_SYM_FATAL_ERROR);
    }
    return;
  }

  if (lbm_is_symbol(ctx->curr_exp)) {
    eval_symbol(ctx);
    return;
  }
  if (lbm_is_cons(ctx->curr_exp)) {
    lbm_cons_t *cell = lbm_ref_cell(ctx->curr_exp);
    lbm_value h = cell->car;
    if (lbm_is_symbol(h) && ((h & ENC_SPECIAL_FORMS_MASK) == ENC_SPECIAL_FORMS_BIT)) {
      lbm_uint eval_index = lbm_dec_sym(h) & SPECIAL_FORMS_INDEX_MASK;
      evaluators[eval_index](ctx);
      return;
    }
    /*
     * At this point head can be anything. It should evaluate
     * into a form that can be applied (closure, symbol, ...) though.
     */
    lbm_value *reserved = stack_reserve(ctx, 3);
    reserved[0] = ctx->curr_env;
    reserved[1] = cell->cdr;
    reserved[2] = APPLICATION_START;
    ctx->curr_exp = h; // evaluate the function
    return;
  }

  eval_selfevaluating(ctx);
  return;
}


// Reset has a built in pause.
// so after reset, continue.
void lbm_reset_eval(void) {
  eval_cps_next_state_arg = 0;
  eval_cps_next_state = EVAL_CPS_STATE_RESET;
  if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
}

void lbm_pause_eval(void ) {
  eval_cps_next_state_arg = 0;
  eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
  if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
}

void lbm_pause_eval_with_gc(uint32_t num_free) {
  eval_cps_next_state_arg = num_free;
  eval_cps_next_state = EVAL_CPS_STATE_PAUSED;
  if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
}

void lbm_continue_eval(void) {
  eval_cps_next_state = EVAL_CPS_STATE_RUNNING;
  if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
}

void lbm_kill_eval(void) {
  eval_cps_next_state = EVAL_CPS_STATE_KILL;
  if (eval_cps_next_state != eval_cps_run_state) eval_cps_state_changed = true;
}

uint32_t lbm_get_eval_state(void) {
  return eval_cps_run_state;
}

// Only unblocks threads that are unblockable.
// A sleeping thread is not unblockable.
static void handle_event_unblock_ctx(lbm_cid cid, lbm_value v) {
  eval_context_t *found = NULL;
  mutex_lock(&qmutex);

  found = lookup_ctx_nm(&blocked, cid);
  if (found && LBM_IS_STATE_UNBLOCKABLE(found->state)){
    drop_ctx_nm(&blocked,found);
    if (lbm_is_error(v)) {
      get_stack_ptr(found, 1)[0] = TERMINATE; // replace TOS
      found->app_cont = true;
    }
    found->r = v;
    found->state = LBM_THREAD_STATE_READY;
    enqueue_ctx_nm(&queue,found);
  }
  mutex_unlock(&qmutex);
}

static void handle_event_define(lbm_value key, lbm_value val) {
  lbm_uint dec_key = lbm_dec_sym(key);
  lbm_uint ix_key  = dec_key & GLOBAL_ENV_MASK;
  lbm_value *global_env = lbm_get_global_env();
  lbm_uint orig_env = global_env[ix_key];
  lbm_value new_env;
  // A key is a symbol and should not need to be remembered.
  WITH_GC(new_env, lbm_env_set(orig_env,key,val));

  global_env[ix_key] = new_env;
}

static lbm_value get_event_value(lbm_event_t *e) {
  lbm_value v;
  if (e->buf_len > 0) {
    lbm_flat_value_t fv;
    fv.buf = (uint8_t*)e->buf_ptr;
    fv.buf_size = e->buf_len;
    fv.buf_pos = 0;
    if (!lbm_unflatten_value(&fv, &v)) {
      lbm_set_flags(LBM_FLAG_HANDLER_EVENT_DELIVERY_FAILED);
      v = ENC_SYM_EERROR;
    }
    // Free the flat value buffer. GC is unaware of its existence.
    lbm_free(fv.buf);
  } else {
    v = (lbm_value)e->buf_ptr;
  }
  return v;
}

static void process_events(void) {

  if (!lbm_events) {
    return;
  }

  lbm_event_t e;
  while (lbm_event_pop(&e)) {
    lbm_value event_val = get_event_value(&e);
    switch(e.type) {
    case LBM_EVENT_UNBLOCK_CTX:
      handle_event_unblock_ctx((lbm_cid)e.parameter, event_val);
      break;
    case LBM_EVENT_DEFINE:
      handle_event_define((lbm_value)e.parameter, event_val);
      break;
    case LBM_EVENT_FOR_HANDLER:
      if (lbm_event_handler_pid >= 0) {
        lbm_find_receiver_and_send(lbm_event_handler_pid, event_val);
      }
      break;
    case LBM_EVENT_RUN_USER_CALLBACK:
      user_callback((void*)e.parameter);
      break;
    }
  }
}

/* eval_cps_run can be paused
   I think it would be better use a mailbox for
   communication between other threads and the run_eval
   but for now a set of variables will be used. */
void lbm_run_eval(void){

  if (setjmp(critical_error_jmp_buf) > 0) {
    printf_callback("GC stack overflow!\n");
    critical_error_callback();
    // terminate evaluation thread.
    return;
  }

  setjmp(error_jmp_buf);

  while (eval_running) {
    if (eval_cps_state_changed  || eval_cps_run_state == EVAL_CPS_STATE_PAUSED) {
      eval_cps_state_changed = false;
      switch (eval_cps_next_state) {
      case EVAL_CPS_STATE_RESET:
        if (eval_cps_run_state != EVAL_CPS_STATE_RESET) {
          is_atomic = false;
          blocked.first = NULL;
          blocked.last = NULL;
          queue.first = NULL;
          queue.last = NULL;
          ctx_running = NULL;
          eval_steps_quota = eval_steps_refill;
          eval_cps_run_state = EVAL_CPS_STATE_RESET;
          if (blocking_extension) {
            blocking_extension = false;
            mutex_unlock(&blocking_extension_mutex);
          }
        }
        usleep_callback(EVAL_CPS_MIN_SLEEP);
        continue;
      case EVAL_CPS_STATE_PAUSED:
        if (eval_cps_run_state != EVAL_CPS_STATE_PAUSED) {
          if (lbm_heap_num_free() < eval_cps_next_state_arg) {
            gc();
          }
          eval_cps_next_state_arg = 0;
          eval_cps_run_state = EVAL_CPS_STATE_PAUSED;
        }
        usleep_callback(EVAL_CPS_MIN_SLEEP);
        continue;
      case EVAL_CPS_STATE_KILL:
        eval_cps_run_state = EVAL_CPS_STATE_DEAD;
        eval_running = false;
        continue;
      default: // running state
        eval_cps_run_state = eval_cps_next_state;
        break;
      }
    }
    while (true) {
      if (eval_steps_quota && ctx_running) {
        eval_steps_quota--;
        evaluation_step();
      } else {
        if (eval_cps_state_changed) break;
        eval_steps_quota = eval_steps_refill;
        if (!is_atomic) {
          if (gc_requested) {
            gc();
          }
          process_events();
          mutex_lock(&qmutex);
          if (ctx_running) {
            enqueue_ctx_nm(&queue, ctx_running);
            ctx_running = NULL;
          }
          wake_up_ctxs_nm();
          ctx_running = dequeue_ctx_nm(&queue);
          mutex_unlock(&qmutex);
          if (!ctx_running) {
            lbm_system_sleeping = true;
            //Fixed sleep interval to poll events regularly.
            usleep_callback(EVAL_CPS_MIN_SLEEP);
            lbm_system_sleeping = false;
          }
        }
      }
    }
  }
}

lbm_cid lbm_eval_program(lbm_value lisp) {
  return lbm_create_ctx(lisp, ENC_SYM_NIL, 256, NULL);
}

lbm_cid lbm_eval_program_ext(lbm_value lisp, unsigned int stack_size) {
  return lbm_create_ctx(lisp, ENC_SYM_NIL, stack_size, NULL);
}

int lbm_eval_init() {
  if (!qmutex_initialized) {
    mutex_init(&qmutex);
    qmutex_initialized = true;
  }
  if (!lbm_events_mutex_initialized) {
    mutex_init(&lbm_events_mutex);
    lbm_events_mutex_initialized = true;
  }
  if (!blocking_extension_mutex_initialized) {
    mutex_init(&blocking_extension_mutex);
    blocking_extension_mutex_initialized = true;
  }

  mutex_lock(&qmutex);
  mutex_lock(&lbm_events_mutex);

  blocked.first = NULL;
  blocked.last = NULL;
  queue.first = NULL;
  queue.last = NULL;
  ctx_running = NULL;

  eval_cps_run_state = EVAL_CPS_STATE_RUNNING;

  mutex_unlock(&lbm_events_mutex);
  mutex_unlock(&qmutex);

  if (!lbm_init_env()) return 0;
  eval_running = true;
  return 1;
}

bool lbm_eval_init_events(unsigned int num_events) {

  mutex_lock(&lbm_events_mutex);
  lbm_events = (lbm_event_t*)lbm_malloc(num_events * sizeof(lbm_event_t));
  bool r = false;
  if (lbm_events) {
    lbm_events_max = num_events;
    lbm_events_head = 0;
    lbm_events_tail = 0;
    lbm_events_full = false;
    lbm_event_handler_pid = -1;
    r = true;
  }
  mutex_unlock(&lbm_events_mutex);
  return r;
}

Generated by: GCOVR (Version 4.2)