cirilisp/eval.c

#include <stdlib.h>
#include <string.h>

#include "util.h"
#include "internals.h"
#include "eval.h"

int bindArgs(object parameters, object args, env newEnv)
/* на почетку извршавања функције, везује прослеђене параметре, за симболе у
 * дефиницији функције, везивање се врши у новонасталом окружењу, уколико је
 * параметри нису правилни за дате аргументе, враћа 0, уколико нема грешке
 * враћа 1 */
{
	if (properList(args))
	/* уколико је листа аргумената правилна, број аргумената је одређен */
	{
		if (listLength(parameters) != listLength(args))
		{
			return 0;
		}
		else
		{
			object *currentArg = &args;
			object *currentParam = &parameters;
			while (TYPE(*currentArg) != nilObject)
			{
				addSymbolVariable(SYM(CAR(*currentArg)),
					CAR(*currentParam), newEnv);
				currentArg = &CDR(*currentArg);
				currentParam = &CDR(*currentParam);
			}
			return 1;
		}
	}
	else
	/* у супротном, број аргумената је само ограничен одоздо */
	{
		if (improperListLength(args) - 1 > listLength(parameters))
		{
			return 0;
		}
		else
		{
			object *currentArg = &args;
			object *currentParam = &parameters;
			while (TYPE(*currentArg) == consObject)
			{
				addSymbolVariable(SYM(CAR(*currentArg)),
					CAR(*currentParam), newEnv);
				currentArg = &CDR(*currentArg);
				currentParam = &CDR(*currentParam);
			}
			addSymbolVariable(SYM(*currentArg), *currentParam,
					newEnv);
			return 1;
		}
	}
}

object Eval(object input, env currentEnv)
{
	object result;
	int tailExpression = 0, macroEvalPending;

eval:
	macroEvalPending = 0;
	if (TYPE(input) == symbolObject)
	{
		result = referVariable(SYM(input), currentEnv);
	}
	else if (TYPE(input) == consObject)
	{
		if (!properList(input))
		{
			deleteObject(input);
			SIGERR(improperListError);
		}

		int regularEvalOrder = 1;
		CAR(input) = Eval(CAR(input), currentEnv);
		if (TYPE(CAR(input)) == errorObject)
		{
			result = copyObject(CAR(input));
			deleteObject(input);
			CPYERR(ERR(result));
		}

		if (TYPE(CAR(input)) == procedureObject &&
			PROC_SPECIAL(CAR(input)))
		{
			regularEvalOrder = 0;
		}

		object *currentCell = &CDR(input);
		int noErrors = 1;
		if (regularEvalOrder)
		{
			while (TYPE(*currentCell) != nilObject)
			{
				CAR(*currentCell) =
					Eval(CAR(*currentCell), currentEnv);

				if (TYPE(CAR(*currentCell)) == errorObject)
				{
					noErrors = 0;
					object err =
						copyObject(CAR(*currentCell));
					deleteObject(input);
					CPYERR(ERR(err));
					break;
				}
				currentCell = &CDR(*currentCell);
			}
			if (noErrors)
			{
				goto apply;
			}
		}
		else
		{
			if (TYPE(CAR(input)) == procedureObject &&
				PROC_SPECIAL(CAR(input)) &&
				PROC_TYPE(CAR(input)) == compoundProc)
			{
				macroEvalPending = 1;
			}
			goto apply;
		}
	}
	else
	{
		result = copyObject(input);
	}

	if (tailExpression)
	{
		removeEnvironment(currentEnv);
	}
	deleteObject(input);
	return result;

	object procedure, parameters;
apply:
	procedure = copyObject(CAR(input));
	parameters = copyObject(CDR(input));
	deleteObject(input);

	if (TYPE(procedure) != procedureObject)
	{
		deleteObject(procedure);
		deleteObject(parameters);
		SIGERR(notApplicableError);
	}

	if (PROC_TYPE(procedure) == builtinProc)
	{
		object(*f)() = PROC_BUILTIN(procedure);

		if (f == ifInt)
		{
			if (listLength(parameters) >= 2)
			{
				CAR(CDR(parameters)) =
				quoteExpression(CAR(CDR(parameters)));
			}
			if (listLength(parameters) >= 3)
			{
				CAR(CDR(CDR(parameters))) =
				quoteExpression(CAR(CDR(CDR(parameters))));
			}
		}
		else if (f == beginInt)
		{
			if (listLength(parameters) >= 1)
			{
				object *current = &parameters;
				while (TYPE(CDR(*current)) != nilObject)
				{
					current = &CDR(*current);
				}
				CAR(*current) = quoteExpression(CAR(*current));
			}
		}

		if (f == defineInt || f == lambdaInt || f == ifInt ||
			f == applyInt || f == defineMacroInt || f == beginInt)
		{
			result = f(parameters, currentEnv);
		}
		else
		{
			result = f(parameters);
		}

		deleteObject(procedure);
		deleteObject(parameters);
		if (f == beginInt || f == ifInt)
		{
			input = result;
			goto eval;
		}
		else if (tailExpression)
		{
			removeEnvironment(currentEnv);
		}

		return result;
	}

	object args = copyObject(PROC_COMP_ARGS(procedure));
	env definitionEnv = PROC_COMP_ENV(procedure);
	env procEnv;

	if (tailExpression && !macroEvalPending)
	{
		if (definitionEnv == currentEnv)
		{
			procEnv = currentEnv;
		}
		else
		{
			removeEnvironment(currentEnv);
			procEnv = createEnvironment(definitionEnv);
		}
	}
	else
	{
		procEnv = createEnvironment(definitionEnv);
	}

	if (!bindArgs(parameters, args, procEnv))
	{
		deleteObject(args);
		removeEnvironment(procEnv);
		deleteObject(procedure);
		deleteObject(parameters);
		SIGERR(argumentNumberError);
	}
	deleteObject(args);

	object *currentExprPointer = &PROC_COMP_BODY(procedure);
	object currentExpr;
	while (TYPE(CDR(*currentExprPointer)) != nilObject)
	/* сви изрази осим задњег */
	{
		currentExpr = copyObject(CAR(*currentExprPointer));
		currentExpr = Eval(currentExpr, procEnv);

		deleteObject(currentExpr);
		currentExprPointer = &CDR(*currentExprPointer);
	}
	/* репни израз */
	currentExpr = copyObject(CAR(*currentExprPointer));

	deleteObject(procedure);
	deleteObject(parameters);
	input = currentExpr;
	if (macroEvalPending)
	{
		input = Eval(input, procEnv);
		removeEnvironment(procEnv);
	}
	else
	{
		currentEnv = procEnv;
		tailExpression = 1;
	}
	goto eval;
}