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);

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);
		}
		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)
				{
					goto apply;
				}
			}
			else
			{
				if (TYPE(CAR(input)) == procedureObject &&
					PROC_SPECIAL(CAR(input)) &&
					PROC_TYPE(CAR(input)) == compoundProc)
				{
					macroEvalPending = 1;
				}
				goto apply;
				// big problem pendejo
			}
		}
	}
	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 (tailExpression && PROC_TYPE(procedure) != builtinProc && !macroEvalPending)
	{
		removeEnvironment(currentEnv);
	}


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

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

		if (tailExpression)
		{
			removeEnvironment(currentEnv);
		}

		deleteObject(procedure);
		deleteObject(parameters);
		return result;
	}

	if (++currentRecursionDepth > maxRecursionDepth)
	{
		--currentRecursionDepth;
		deleteObject(procedure);
		deleteObject(parameters);
		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);
		deleteObject(procedure);
		deleteObject(parameters);
		SIGERR(argumentNumberError);
	}

	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));
	//pruneExpr(&currentExpr); ова функција ће бити коришћена за
	// упроштавање израза, тако да постану репно-елиминалбилни, када буде
	// написана ЛОЛ :)

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