eigenmath/userfunc.cpp

#include "stdafx.h"
#include "defs.h"

extern U *formal_arg[6];

//-----------------------------------------------------------------------------
//
//	Example: f(x) = x^2
//
//	p1	*-------*---------------*
//		|	|		|
//		setq	*-------*	*-------*-------*
//			|	|	|	|	|
//			f	x	power	x	2
//
//-----------------------------------------------------------------------------

#define NAME p2
#define ARGS p3
#define BODY p4
#define BODY2 p5
#define TMP p6

void
define_user_function(void)
{
	int i, n;

	NAME = caadr(p1);
	ARGS = cdadr(p1);
	BODY = caddr(p1);

	if (!issymbol(NAME))
		stop("in function definition, user symbol expected for function name");

	n = length(ARGS);

	if (n > 6)
		stop("more than 6 formal args in function definition");

	// subst args in body

	push(BODY);
	TMP = ARGS;
	for (i = 0; i < n; i++) {
		if (!issymbol(car(TMP)))
			stop("in function definition, formal arg is not a user symbol");
		push(car(TMP));
		push(formal_arg[i]);
		subst();
		TMP = cdr(TMP);
	}
	BODY2 = pop();

	// binding

	NAME->u.sym.binding = BODY;
	NAME->u.sym.binding2 = BODY2;

	// do eval, maybe

	if (car(BODY) == symbol(EVAL)) {

		// remove eval

		NAME->u.sym.binding = cadr(BODY);
		NAME->u.sym.binding2 = cadr(BODY2);

		// build function call with quoted symbols

		push(NAME);
		TMP = ARGS;
		for (i = 0; i < n; i++) {
			push_symbol(QUOTE);
			push(car(TMP));
			list(2);
			TMP = cdr(TMP);
		}
		list(n + 1);

		// eval

		eval();
		BODY = pop();

		// subst args in body

		push(BODY);
		TMP = ARGS;
		for (i = 0; i < n; i++) {
			push(car(TMP));
			push(formal_arg[i]);
			subst();
			TMP = cdr(TMP);
		}
		BODY2 = pop();

		// update bindings

		NAME->u.sym.binding = BODY;
		NAME->u.sym.binding2 = BODY2;
	}

	push(symbol(NIL));	// return value
}

// Note: Tried doing func eval above using formal_arg and then back subst
// symbols from ARGLIST.
// The problem with this method is that the resulting BODY might be
// denormalized.
// In other words, the terms and factors are not sorted properly.
// This causes problems since add() and multiply() use a merge sort that
// requires sorted (normalized) terms and factors.
// The code above ensures a normalized BODY.

//-----------------------------------------------------------------------------
//
//	Example: f(x,y)
//
//	p1 -> (f x y)
//
//	car(p1) -> f
//
//-----------------------------------------------------------------------------

#define FUNC_NAME p2
#define ACTUAL_ARGLIST p3

void
eval_user_function(void)
{
	int h, i;

	h = tos;

	FUNC_NAME = car(p1);
	ACTUAL_ARGLIST = cdr(p1);

	// undefined function?

	if (FUNC_NAME->u.sym.binding == FUNC_NAME) {
		push(FUNC_NAME);
		while (iscons(ACTUAL_ARGLIST)) {
			push(car(ACTUAL_ARGLIST));
			eval();
			ACTUAL_ARGLIST = cdr(ACTUAL_ARGLIST);
		}
		list(tos - h);
		return;
	}

	// is it a function?

	if (FUNC_NAME->u.sym.binding2 == symbol(NIL))
		stop("Attempt to call non-function");

	// eval actual args in current formal arg context, don't modify formal args yet

	for (i = 0; i < 6; i++) {
		push(car(ACTUAL_ARGLIST));
		eval();
		ACTUAL_ARGLIST = cdr(ACTUAL_ARGLIST);
		push(symbol(NIL)); // make room for saving binding2
	}

	// ok, now it's safe to modify formal args

	for (i = 0; i < 6; i++) {
		TMP = formal_arg[i]->u.sym.binding;
		formal_arg[i]->u.sym.binding = stack[h + 2 * i];
		stack[h + 2 * i] = TMP;
		TMP = formal_arg[i]->u.sym.binding2;
		formal_arg[i]->u.sym.binding2 = stack[h + 2 * i + 1];
		stack[h + 2 * i + 1] = TMP;
	}

	// evaluate user-defined function

	push(FUNC_NAME->u.sym.binding2);
	eval();

	// restore args

	TMP = pop();
	for (i = 0; i < 6; i++) {
		formal_arg[5 - i]->u.sym.binding2 = pop();
		formal_arg[5 - i]->u.sym.binding = pop();
	}
	push(TMP);
}

void
eval_binding2(void)
{
	p1 = cadr(p1);
	if (!issymbol(p1))
		stop("symbol expected in binding2");
	push(p1->u.sym.binding2);
}

//-----------------------------------------------------------------------------
//
//	Evaluate an expression with a symbol set to a value.
//
//	Input:		tos-3	expr
//
//			tos-2	symbol
//
//			tos-1	value
//
//	Output:		Result on stack
//
//-----------------------------------------------------------------------------

#define F p1
#define X p2
#define VAL p3

void
evalat(void)
{
	int mark;

	save();

	VAL = pop();
	X = pop();

	if (!issymbol(X)) {
		push(X);
		push(VAL);
		subst();
		eval();
		restore();
		return;
	}

	push(X);
	mark = save_symbols(1);

	X->u.sym.binding = VAL;
	X->u.sym.binding2 = symbol(NIL);

	eval();

	restore_symbols(mark);

	restore();
}

static char *s[] = {

	"f=quote(f)",
	"",

	"x=quote(x)",
	"",

	"y=quote(y)",
	"",

	// args of generic functions should be evaluated

	"f(1+2,3*4)",
	"f(3,12)",

	// simple func def

	"f(x)=x^2",
	"",

	"f",
	"x^2",

	"binding2(f)",
	"$1^2",

	// symbols should be quoted in eval

	"x=123",
	"",

	"f(x)=eval(x^3)",
	"",

	"f",
	"x^3",

	// bindings should be restored

	"x=123",
	"",

	"y=345",
	"",

	"f(x,y)=x^2+y^3",
	"",

	"f(2,3)",
	"31",

	"x",
	"123",

	"y",
	"345",

	// as above but this time with function bindings

	"x(a)=sin(a)",
	"",

	"y(b)=cos(b)",
	"",

	"f(x,y)=x^2+y^3",
	"",

	"f(2,3)",
	"31",

	"x",
	"sin(a)",

	"binding2(x)",
	"sin($1)",

	"y",
	"cos(b)",

	"binding2(y)",
	"cos($1)",

	// clean up

	"f=quote(f)",
	"",

	"x=quote(x)",
	"",

	"y=quote(y)",
	"",
};

void
test_user_func(void)
{
	test(__FILE__, s, sizeof s / sizeof (char *));
}