cirilisp/eval.c

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

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

int currentRecursionDepth = 0;
int maxRecursionDepth = 10000;

object apply(object function, object parameters, env currentEnv);

object Eval(object input, env currentEnv)
{
	object result;

	if (TYPE(input) == symbolObject)
	{
		result = referVariable(SYM(input), currentEnv);
	}
	else if (TYPE(input) == consObject)
	{
		if (!properList(input))
		{
			deleteObject(input);
			SIGERR(improperListError);
		}
		else
		{
			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)
			{
				result = apply(CAR(input), CDR(input),
						currentEnv);
			}

			if (TYPE(CAR(input)) == procedureObject &&
				PROC_SPECIAL(CAR(input)) &&
				PROC_TYPE(CAR(input)) == compoundProc)
			{
				result = Eval(result, currentEnv);
			}
		}
	}
	else
	{
		result = copyObject(input);
	}

	deleteObject(input);
	return result;
}

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 apply(object procedure, object parameters, env currentEnv)
{
	object result;

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

	if (PROC_TYPE(procedure) == builtinProc)
	{
		object(*f)() = PROC_BUILTIN(procedure);
		if (f == defineInt || f == lambdaInt || f == ifInt ||
			f == applyInt)
		{
			result = f(parameters, currentEnv);
		}
		else
		{
			result = f(parameters);
		}

		return result;
	}

	if (++currentRecursionDepth > maxRecursionDepth)
	{
		--currentRecursionDepth;
		SIGERR(maxRecursionDepthError);
	}

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

	env procEnv = createEnvironment(definitionEnv);
	if (!bindArgs(parameters, args, procEnv))
	{
		deleteObject(args);
		removeEnvironment(procEnv);
		SIGERR(argumentNumberError);
	}

	object *currentExprPointer = &PROC_COMP_BODY(procedure);
	while (TYPE(*currentExprPointer) != nilObject)
	{
		object currentExpr = copyObject(CAR(*currentExprPointer));
		currentExpr = Eval(currentExpr, procEnv);
		if (TYPE(CDR(*currentExprPointer)) == nilObject)
		{
			result = copyObject(currentExpr);
		}
		currentExprPointer = &CDR(*currentExprPointer);
		deleteObject(currentExpr);
	}
	removeEnvironment(procEnv);
	--currentRecursionDepth;

	return result;
}