ulisp-picocalc/ulisp-extensions.ino

/*
 User Extensions
*/

// Utility functions
uint8_t
dec_to_bcd(uint8_t n)
{
	uint8_t bcd = 0;
	uint8_t	tens = n / 10;

	bcd = tens << 4;
	tens *= 10;
	bcd += (n - tens) & 0x0f;
	return bcd;
}


uint8_t
bcd_to_dec(uint8_t n)
{
	return ((n>>4) * 10) + (n&0x0f);
}

// Definitions
object *
fn_now(object *args, object *env)
{
	(void) env;
	static unsigned long Offset;
	unsigned long now = millis()/1000;
	int nargs = listlength(args);

	// Set time
	if (nargs == 3) {
		Offset = (unsigned long)((checkinteger(first(args))*60		\
					+ checkinteger(second(args)))*60	\
				+ checkinteger(third(args)) - now);
	} else if (nargs > 0) {
		error2(PSTR("wrong number of arguments"));
	}

	// Return time
	unsigned long secs = Offset + now;
	object *seconds = number(secs%60);
	object *minutes = number((secs/60)%60);
	object *hours = number((secs/3600)%24);

	return cons(hours, cons(minutes, cons(seconds, NULL)));
}


void
hyperprint(object *form, int lm, pfun_t pfun)
{
	if (atom(form)) {
		if (isbuiltin(form, NOTHING)) {
			printsymbol(form, pfun);
		} else {
			printobject(form, pfun);
		}
	} else if (quoted(form)) {
		pfun('\'');
		hyperprint(car(cdr(form)), lm + 1, pfun);
	} else {
		lm = lm + PPINDENT;
		bool fits = (subwidth(form, PPWIDTH - lm - PPINDENT) >= 0);
		int special = 0, extra = 0; bool separate = true;
		object *arg = car(form);

		if (symbolp(arg) && builtinp(arg->name)) {
			uint8_t minmax = getminmax(builtin(arg->name));
			if (minmax == 0327 || minmax == 0313) {
				special = 2; // defun, setq, setf, defvar
			} else if (minmax == 0317 || minmax == 0017 ||
				   minmax == 0117 || minmax == 0123) {
				special = 1;
			}
		}

		while (form != NULL) {
			if (atom(form)) { 
				pfstring(PSTR(" . "), pfun); 
				printobject(form, pfun);
				pfun(')');
				return;
			} else if (separate) { 
				pfun('(');
				separate = false;
			} else if (special) {
				pfun(' ');
				special--; 
			} else if (fits) {
				pfun(' ');
			} else {
				pln(pfun);
				indent(lm, ' ', pfun);
			}

			hyperprint(car(form), lm+extra, pfun);
			form = cdr(form);
		}
		pfun(')');
	}
}

object *
fn_sym_def(object *args, object *env)
{
	(void) env;

	object *obj = first(args);
	pfun_t pfun = pstreamfun(cdr(args));
#if defined(gfxsupport)
	if (pfun == gfxwrite) ppwidth = GFXPPWIDTH;
#endif
	object *pair = findvalue(obj, env);
	object *var = car(pair);
	object *val = cdr(pair);
	pln(pfun);

	if (consp(val) && symbolp(car(val)) && builtin(car(val)->name) == LAMBDA) {
		hyperprint(cons(bsymbol(DEFUN), cons(var, cdr(val))), 0, pfun);
	} else {
		hyperprint(cons(bsymbol(DEFVAR), cons(var, cons(quote(val), NULL))), 0, pfun);
	}

	pln(pfun);
	ppwidth = PPWIDTH;
	return bsymbol(NOTHING);
}

object *
fn_lambdap(object *arg, object *env)
{
	(void) env;

	if (consp(arg)) {
		arg = car(arg);
	}

	if (builtin(arg->name) == LAMBDA) {
		return tee;
	}

	return nil;
}


// Symbol names
const char stringlambdap[] PROGMEM	= "lambdap";
const char stringnow[] PROGMEM		= "now";
const char string_sym_def[] PROGMEM	= "symbol-def";

// Documentation strings

const char doclambdap[] PROGMEM		= "(lambdap x)"
"Returns t if the form passed in is a lambda.";

const char docnow[] PROGMEM = "(now [hh mm ss])\n"
"Sets the current time, or with no arguments returns the current time\n"
"as a list of three integers (hh mm ss).";

const char docpform[] PROGMEM = "(pform form str)\n"
"Print a form to a stream in a manner suitable for writing to storage.";

const char doc_sym_def[] PROGMEM = "(symbol-def symbol [str])\n"
"Prints the definition of a symbol (variable or function) defined in\n"
"ulisp using the pretty printer."
"If str is specified it prints to the specified stream.\n"
"It returns no value.";


// Symbol lookup table
const tbl_entry_t lookup_table2[] PROGMEM = {
  { stringlambdap, fn_lambdap, 0211, doclambdap },
  { stringnow, fn_now, 0203, docnow },
  { string_sym_def, fn_sym_def, 0212, doc_sym_def },
};

// Table cross-reference functions

tbl_entry_t *tables[] = {lookup_table, lookup_table2};
const unsigned int tablesizes[] = { arraysize(lookup_table), arraysize(lookup_table2) };

const tbl_entry_t *
table(int n)
{
	return tables[n];
}

unsigned int
tablesize(int n)
{
	return tablesizes[n];
}