text: /**@brief Example program for custom callbacks with the Embed library
   * @license MIT
   * @author Richard James Howe
   * @file call.c
   *
   * See <https://github.com/howerj/embed> for more information.
   *
   * NOTES:
   *
   * This file shows how you can extend the embed virtual machine using its
   * library API to add double and floating point words to that are accessible
   * via the eForth image.
   *
   * Proper floating point number input has not been implemented, but floating point
   * output has been (with the word 'f.'). Floating point number can be input
   * only as integers (with the word 's>f'). There is no plan to add more 
   * floating point number words, as this program is here only as a 
   * demonstration that new functionality can be added, that is, that is 
   * extension is possible.
   *
   * A number of helper routines are added that make dealing with the library
   * interface easier; 'eset', 'eget' and 'eclr' for setting, getting and
   * clearing error codes so that the results of push and pop do not have to
   * be checked each time, a table of function pointers and strings is used
   * to define new words, and other minor things.
   *
   * Only numbers are passed to and from the eForth interpreter, it is in
   * principle possible to pass strings but requires a more intimate knowledge
   * of the internals.
   *
   * Examples:
   *
   *    2 s>f f.
   *    2.000000e+00 ( <- 2.0 is printed )
   *
   *    2 s>f fsqrt f.
   *    1.414214e+00 ( square root of 2 )
   *
   * Awkward numeric input of a floating point number can technically be
   * done with the 'fget' function:
   *
   *    fget
   *    3.443   ( <- must be on a new line 'fget 3.443' does not work )
   *    f.
   *    3.443000e+00 */
  
  #include "embed.h"
  #include "util.h"
  #include <errno.h>
  #include <stdbool.h>
  #include <assert.h>
  #include <string.h>
  #include <stdlib.h>
  #include <math.h>
  #include <ctype.h>
  #include <stdio.h>
  
  struct vm_extension_t;
  typedef struct vm_extension_t vm_extension_t;
  
  typedef float vm_float_t;
  typedef int32_t sdc_t;   /**< signed double cell type */
  
  typedef int (*embed_callback_extended_t)(vm_extension_t *v);
  typedef struct {
  	embed_callback_extended_t cb; /**< Callback for function */
  	const char *name;             /**< Forth function */
  	bool use;                     /**< Use this callback? */
  } callbacks_t;
  
  struct vm_extension_t {
  	embed_t *h;              /**< embed VM instance we are operating with */
  	callbacks_t *callbacks;  /**< callbacks to use with this instance */
  	size_t callbacks_length; /**< length of 'callbacks' field */
  	embed_opt_t o;           /**< embed virtual machine options */
  	cell_t error;          /**< current error condition */
  };
  
  #define CALLBACK_XMACRO\
  	X("d+",       cb_dplus,      false)\
  	X("d*",       cb_dmul,       false)\
  	X("d.",       cb_dprint,     false)\
  	X("d-",       cb_dsub,       false)\
  	X("d/",       cb_ddiv,       false)\
  	X("d<",       cb_dless,      false)\
  	X("d>",       cb_dmore,      false)\
  	X("d=",       cb_dequal,     false)\
  	X("dnegate",  cb_dnegate,    false)\
  	X("f.",       cb_flt_print,  true)\
  	X("f+",       cb_fadd,       true)\
  	X("f-",       cb_fsub,       true)\
  	X("f*",       cb_fmul,       true)\
  	X("f/",       cb_fdiv,       true)\
  	X("f>d",      cb_f2d,        true)\
  	X("f<",       cb_fless,      true)\
  	X("f>",       cb_fmore,      true)\
  	X("fdup",     cb_fdup,       true)\
  	X("fswap",    cb_fswap,      true)\
  	X("fdrop",    cb_fdrop,      true)\
  	X("fover",    cb_fover,      true)\
  	X("fnip",     cb_fnip,       true)\
  	X("s>f",      cb_s2f,        true)\
  	X("f>s",      cb_f2s,        true)\
  	X("fsin",     cb_fsin,       true)\
  	X("fcos",     cb_fcos,       true)\
  	X("ftan",     cb_ftan,       true)\
  	X("fasin",    cb_fasin,      true)\
  	X("facos",    cb_facos,      true)\
  	X("fatan",    cb_fatan,      true)\
  	X("fatan2",   cb_fatan2,     true)\
  	X("flog",     cb_flog,       true)\
  	X("flog10",   cb_flog10,     true)\
  	X("fpow",     cb_fpow,       true)\
  	X("fexp",     cb_fexp,       true)\
  	X("fsqrt",    cb_fsqrt,      true)\
  	X("fget",     cb_fget,       true)\
  	X("floor",    cb_floor,      true)\
  	X("fceil",    cb_fceil,      true)\
  	X("fround",   cb_fround,     true)\
  	X("fabs",     cb_fabs,       true)\
  	X("ferfc",    cb_ferfc,      false)\
  	X("ferf",     cb_ferf,       false)\
  	X("flgamma",  cb_flgamma,    false)\
  	X("ftgamma",  cb_ftgamma,    false)\
  	X("fmin",     cb_fmin,       true)\
  	X("fmax",     cb_fmax,       true)\
  
  #define X(NAME, FUNCTION, USE) static int FUNCTION ( vm_extension_t * const v );
  	CALLBACK_XMACRO
  #undef X
  
  static callbacks_t callbacks[] = {
  #define X(NAME, FUNCTION, USE) { .name = NAME, .cb = FUNCTION, .use = USE },
  	CALLBACK_XMACRO
  #undef X
  };
  
  static inline size_t number_of_callbacks(void) { return sizeof(callbacks) / sizeof(callbacks[0]); }
  
  static inline cell_t eset(vm_extension_t * const v, const cell_t error) { /**< set error register if not set */
  	assert(v);
  	if(!(v->error))
  		v->error = error;
  	return v->error;
  }
  
  static inline cell_t eget(vm_extension_t const * const v) { /**< get current error register */
  	assert(v);
  	return v->error;
  }
  
  static inline cell_t eclr(vm_extension_t * const v) { /**< clear error register and return value before clear */
  	assert(v);
  	const cell_t error = v->error;
  	v->error = 0;
  	return error;
  }
  
  static inline cell_t pop(vm_extension_t *v) {
  	assert(v);
  	if(eget(v))
  		return 0;
  	cell_t rv = 0;
  	int e = 0;
  	if((e = embed_pop(v->h, &rv)) < 0)
  		eset(v, e);
  	return rv;
  }
  
  static inline void push(vm_extension_t * const v, const cell_t value) {
  	assert(v);
  	if(eget(v))
  		return;
  	int e = 0;
  	if((e = embed_push(v->h, value)) < 0)
  		eset(v, e);
  }
  
  static inline void udpush(vm_extension_t * const v, const double_cell_t value) {
  	push(v, value);
  	push(v, value >> 16);
  }
  
  static inline double_cell_t udpop(vm_extension_t * const v) {
  	const double_cell_t hi = pop(v);
  	const double_cell_t lo = pop(v);
  	const double_cell_t d  = (hi << 16) | lo;
  	return d;
  }
  
  static inline sdc_t dpop(vm_extension_t * const v)                     { return udpop(v); }
  static inline void  dpush(vm_extension_t * const v, const sdc_t value) { udpush(v, value); }
  
  typedef union { vm_float_t f; double_cell_t d; } fd_u;
  
  static inline vm_float_t fpop(vm_extension_t * const v) {
  	BUILD_BUG_ON(sizeof(vm_float_t) != sizeof(double_cell_t));
  	const fd_u fd = { .d = udpop(v) };
  	return fd.f;
  }
  
  static inline void fpush(vm_extension_t * const v, const vm_float_t f) {
  	const fd_u fd = { .f = f };
  	udpush(v, fd.d);
  }
  
  static int cb_dplus(vm_extension_t * const v) {
  	dpush(v, dpop(v) + dpop(v));
  	return eclr(v);
  }
  
  static int cb_dmul(vm_extension_t * const v) {
  	dpush(v, dpop(v) * dpop(v));
  	return eclr(v);
  }
  
  static int cb_dsub(vm_extension_t * const v) {
  	const sdc_t d1 = dpop(v);
  	const sdc_t d2 = dpop(v);
  	dpush(v, d2 - d1);
  	return eclr(v);
  }
  
  static int cb_ddiv(vm_extension_t * const v) {
  	const sdc_t d1 = dpop(v);
  	const sdc_t d2 = dpop(v);
  	if(!d1) {
  		eset(v, 10); /* division by zero */
  		return eclr(v);
  	}
  	dpush(v, d2 / d1);
  	return eclr(v);
  }
  
  static int cb_dnegate(vm_extension_t * const v) {
  	dpush(v, -dpop(v));
  	return eclr(v);
  }
  
  static int cb_dless(vm_extension_t * const v) {
  	const sdc_t d1 = dpop(v);
  	const sdc_t d2 = dpop(v);
  	push(v, -(d2 < d1));
  	return eclr(v);
  }
  
  static int cb_dmore(vm_extension_t * const v) {
  	const sdc_t d1 = dpop(v);
  	const sdc_t d2 = dpop(v);
  	push(v, -(d2 > d1));
  	return eclr(v);
  }
  
  static int cb_dequal(vm_extension_t * const v) {
  	push(v, -(dpop(v) == dpop(v)));
  	return eclr(v);
  }
  
  static int cb_dprint(vm_extension_t * const v) {
  	const long d = dpop(v);
  	if(eget(v))
  		return eclr(v);
  	char buf[80] = { 0 };
  	snprintf(buf, sizeof(buf)-1, "%ld", d); /**@bug does not respect eForth base */
  	embed_puts(v->h, buf);
  	return eclr(v);
  }
  
  static int cb_flt_print(vm_extension_t * const v) {
  	const vm_float_t flt = fpop(v);
  	char buf[512] = { 0 }; /* floats can be quite large */
  	if(eget(v))
  		return eclr(v);
  	snprintf(buf, sizeof(buf)-1, "%e", flt);
  	embed_puts(v->h, buf);
  	return eclr(v);
  }
  
  static int cb_fadd(vm_extension_t * const v) {
  	fpush(v, fpop(v) + fpop(v));
  	return eclr(v);
  }
  
  static int cb_fmul(vm_extension_t * const v) {
  	fpush(v, fpop(v) * fpop(v));
  	return eclr(v);
  }
  
  static int cb_fsub(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	fpush(v, f2 - f1);
  	return eclr(v);
  }
  
  static int cb_fdiv(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	if(f1 == 0.0f) {
  		eset(v, 42); /* floating point division by zero */
  		return eclr(v);
  	}
  	fpush(v, f2 / f1);
  	return eclr(v);
  }
  
  /*// 'd>f' would need take into account the 'dpl' variable
  static int cb_d2f(vm_extension_t * const v) { 
  	fpush(v, dpop(v));
  	return eclr(v);
  }*/
  
  static int cb_f2d(vm_extension_t * const v) {
  	dpush(v, fpop(v));
  	return eclr(v);
  }
  
  static int cb_fless(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	push(v, -(f2 < f1));
  	return eclr(v);
  }
  
  static int cb_fmore(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	push(v, -(f2 > f1));
  	return eclr(v);
  }
  
  static int cb_fdup(vm_extension_t * const v) {
  	const vm_float_t f = fpop(v);
  	fpush(v, f);
  	fpush(v, f);
  	return eclr(v);
  }
  
  static int cb_fswap(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	fpush(v, f1);
  	fpush(v, f2);
  	return eclr(v);
  }
  
  static int cb_fdrop(vm_extension_t * const v) {
  	fpop(v);
  	return eclr(v);
  }
  
  static int cb_fnip(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	fpop(v);
  	fpush(v, f1);
  	return eclr(v);
  }
  
  static int cb_fover(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	fpush(v, f2);
  	fpush(v, f1);
  	fpush(v, f2);
  	return eclr(v);
  }
  
  static int cb_s2f(vm_extension_t * const v) {
  	int16_t i = pop(v);
  	fpush(v, i);
  	return eclr(v);
  }
  
  static int cb_f2s(vm_extension_t * const v) {
  	push(v, (int16_t)fpop(v));
  	return eclr(v);
  }
  
  static int cb_fsin(vm_extension_t * const v) {
  	fpush(v, sinf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_fcos(vm_extension_t * const v) {
  	fpush(v, cosf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_ftan(vm_extension_t * const v) {
  	fpush(v, tanf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_fasin(vm_extension_t * const v) {
  	fpush(v, asinf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_facos(vm_extension_t * const v) {
  	fpush(v, acosf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_fatan(vm_extension_t * const v) {
  	fpush(v, atanf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_fexp(vm_extension_t * const v) {
  	fpush(v, expf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_fatan2(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	fpush(v, atan2f(f1, f2));
  	return eclr(v);
  }
  
  static int cb_fpow(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v);
  	const vm_float_t f2 = fpop(v);
  	fpush(v, powf(f1, f2));
  	return eclr(v);
  }
  
  static int cb_fsqrt(vm_extension_t * const v) {
  	const vm_float_t f = fpop(v);
  	if(f < 0.0f)
  		return eset(v, 43);
  	fpush(v, sqrtf(f));
  	return eclr(v);
  }
  
  static int cb_flog(vm_extension_t * const v) {
  	const vm_float_t f = fpop(v);
  	if(f <= 0.0f)
  		return eset(v, 43);
  	fpush(v, logf(f));
  	return eclr(v);
  }
  
  static int cb_flog10(vm_extension_t * const v) {
  	const vm_float_t f = fpop(v);
  	if(f <= 0.0f)
  		return eset(v, 43);
  	fpush(v, log10f(f));
  	return eclr(v);
  }
  
  static int get_a_char(vm_extension_t * const v) {
  	embed_fgetc_t get = v->o.get;
  	void *getp = v->o.in;
  	int ch, no_data = 0;
  	do { ch = get(getp, &no_data); } while(no_data);
  	return ch;
  }
  
  static int cb_fget(vm_extension_t * const v) {
  	char buf[512] = { 0 };
  	int ch = 0;
  	vm_float_t f = 0.0;
  
  	while(isspace(ch = get_a_char(v)))
  		;
  
  	if(ch == EOF)
  		return 57;
  
  	buf[0] = ch;
  
  	for(size_t i = 1; i < (sizeof(buf)-1); i++) {
  		if((ch = get_a_char(v)) == EOF)
  			return 57;
  		if(isspace(ch))
  			break;
  		buf[i] = ch;
  	}
  
  	if(sscanf(buf, "%f", &f) != 1)
  		return 13;
  
  	fpush(v, f);
  
  	return eclr(v);
  }
  
  static int cb_fround(vm_extension_t * const v) {
  	fpush(v, roundf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_floor(vm_extension_t * const v) {
  	fpush(v, floorf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_fceil(vm_extension_t * const v) {
  	fpush(v, ceilf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_fabs(vm_extension_t * const v) {
  	fpush(v, fabsf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_ferf(vm_extension_t * const v) {
  	fpush(v, fabsf(fpop(v)));
  	return eclr(v);
  }
  
  static int cb_ferfc(vm_extension_t * const v) {
  	vm_float_t f = fpop(v);
  	if(eget(v))
  		return eclr(v);
  	errno = 0;
  	f = erff(f);
  	if(errno == ERANGE)
  		return eset(v, 43);
  	fpush(v, f);
  	return eclr(v);
  }
  
  static int cb_flgamma(vm_extension_t * const v) {
  	vm_float_t f = fpop(v);
  	errno = 0;
  	f = lgammaf(f);
  	if(errno == ERANGE)
  		return eset(v, 43);
  	fpush(v, f);
  	return eclr(v);
  }
  
  static int cb_ftgamma(vm_extension_t * const v) {
  	vm_float_t f = fpop(v);
  	errno = 0;
  	f = tgammaf(f);
  	if(errno == ERANGE || errno == EDOM)
  		return eset(v, 43);
  	fpush(v, f);
  	return eclr(v);
  }
  
  static int cb_fmin(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v), f2 = fpop(v);
  	fpush(v, f1 < f2 ? f1 : f2);
  	return eclr(v);
  }
  
  static int cb_fmax(vm_extension_t * const v) {
  	const vm_float_t f1 = fpop(v), f2 = fpop(v);
  	fpush(v, f1 > f2 ? f1 : f2);
  	return eclr(v);
  }
  
  /*! The virtual machine has only one callback, which we can then use to vector
   * into a table of callbacks provided in 'param', which is a pointer to an
   * instance of 'vm_extension_t' */
  static int callback_selector(embed_t *h, void *param) {
  	assert(h);
  	assert(param);
  	vm_extension_t *e = (vm_extension_t*)param;
  	if(e->h != h)
  		embed_fatal("embed extensions: instance corruption");
  	eclr(e);
  	const cell_t func = pop(e);
  	if(eget(e))
  		return eclr(e);
  	if(func >= e->callbacks_length)
  		return -21;
  	const callbacks_t *cb = &e->callbacks[func];
  	if(!(cb->use))
  		return -21;
  	return cb->cb(e);
  }
  
  /*! This adds the call backs to an instance of the virtual machine running
   * an eForth image by defining new words in it with 'embed_eval'.  */
  static int callbacks_add(embed_t * const h, const bool optimize,  callbacks_t *cb, const size_t number) {
  	assert(h && cb);
  	const char *optimizer = optimize ? "-2 cells allot ' vm chars ," : "";
  	static const char *preamble = "only forth definitions system +order\n";
  	int r = 0;
  	if((r = embed_eval(h, preamble)) < 0) {
  		embed_error("embed: eval(%s) returned %d", preamble, r);
  		return r;
  	}
  
  	for(size_t i = 0; i < number; i++) {
  		char line[80] = { 0 };
  		if(!cb[i].use)
  			continue;
  		r = snprintf(line, sizeof(line), ": %s %u vm ; %s\n", cb[i].name, (unsigned)i, optimizer);
  		assert(strlen(line) < sizeof(line) - 1);
  		if(r < 0) {
  			embed_error("format error in snprintf (returned %d)", r);
  			return -1;
  		}
  		if((r = embed_eval(h, line)) < 0) {
  			embed_error("embed: eval(%s) returned %d", line, r);
  			return r;
  		}
  	}
  	embed_reset(h);
  	return 0;
  }
  
  static vm_extension_t *vm_extension_new(void) {
  	vm_extension_t *v = embed_alloc(sizeof(*v));
  	if(!v)
  		return NULL;
  	v->h = embed_new();
  	if(!(v->h))
  		goto fail;
  
  	v->callbacks_length = number_of_callbacks(),
  	v->callbacks        = callbacks;
  	v->o                = embed_opt_default_hosted();
  	v->o.callback       = callback_selector;
  	v->o.param          = v;
  	embed_opt_set(v->h, &v->o);
  
  	if(callbacks_add(v->h, true, v->callbacks, v->callbacks_length) < 0) {
  		embed_error("adding callbacks failed");
  		goto fail;
  	}
  
  	return v;
  fail:
  	if(v->h)
  		embed_free(v->h);
  	return NULL;
  }
  
  static int vm_extension_run(vm_extension_t *v) {
  	assert(v);
  	return embed_vm(v->h);
  }
  
  static void vm_extension_free(vm_extension_t *v) {
  	assert(v);
  	embed_free(v->h);
  	memset(v, 0, sizeof(*v));
  	free(v);
  }
  
  int main(void) {
  	BUILD_BUG_ON(sizeof(double_cell_t) != sizeof(sdc_t));
  	vm_extension_t *v = vm_extension_new();
  	if(!v)
  		embed_fatal("embed extensions: load failed");
  	const int r = vm_extension_run(v);
  	vm_extension_free(v);
  	return r;
  }
  
  