cirilisp/eval.c

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

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

int currentRecursionDepth = 0;
#define MAXRECURSIONDEPTH 1000

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))
		{
			TYPE(result) = errorObject;
			ERR(result) = improperListError;
		}
		else
		{
			int specialForm = 0;
			if (TYPE(CAR(input)) == symbolObject &&
					isSpecialForm(SYM(CAR(input))))
			{
				specialForm = 1;
				CAR(input) = eval(CAR(input), currentEnv);
			}

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

					if (TYPE(CAR(*currentCell)) ==
							errorObject)
					{
						noErrors = 0;
						TYPE(result) = errorObject;
						ERR(result) =
							ERR(CAR(*currentCell));
						break;
					}
					currentCell = &CDR(*currentCell);
				}
			}

			if (noErrors)
			{
				result = apply(CAR(input), CDR(input),
						currentEnv);
			}
		}
	}
	else
	{
		result = copyObject(input);
	}

	deleteObject(input);
	return result;
}

object apply(object procedure, object parameters, env currentEnv)
{
	object result;

	if (TYPE(procedure) != procedureObject)
	{
		TYPE(result) = errorObject;
		ERR(result) = notApplicableError;
		return result;
	}

	if (PROC_TYPE(procedure) == builtinProc)
	{
		object(*f)() = PROC_BUILTIN(procedure);
		if (f == define || f == lambda)
		{
			result = f(parameters, currentEnv);
		}
		else
		{
			result = f(parameters);
		}

		return result;
	}

	if (++currentRecursionDepth > MAXRECURSIONDEPTH)
	{
		--currentRecursionDepth;
		SIGERR(maxRecursionDepthError);
	}
	object args = copyObject(PROC_COMP_ARGS(procedure));
	object body = copyObject(PROC_COMP_BODY(procedure));
	env definitionEnv = PROC_COMP_ENV(procedure);
	if (listLength(parameters) != listLength(args))
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
		return result;
	}

	env procEnv = createEnvironment(definitionEnv);
	object *currentArg = &args;
	object *currentParam = &parameters;
	while (TYPE(*currentArg) != nilObject)
	{
		addSymbolVariable(SYM(CAR(*currentArg)), CAR(*currentParam),
			procEnv);
		currentArg = &CDR(*currentArg);
		currentParam = &CDR(*currentParam);
	}
	object *currentSubProc = &body;
	while (TYPE(*currentSubProc) != nilObject)
	{
		CAR(*currentSubProc) = eval(CAR(*currentSubProc), procEnv);
		if (TYPE(CDR(*currentSubProc)) == nilObject)
		{
			result = copyObject(CAR(*currentSubProc));
		}
		currentSubProc = &CDR(*currentSubProc);
	}
	deleteObject(args);
	deleteObject(body);
	removeEnvironment(procEnv);
	--currentRecursionDepth;

	return result;
}