cirilisp/eval.c

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

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

object apply(object function, object parameters);

object eval(object input)
{
	object result;

	if (TYPE(input) == symbolObject)
	{
		result = referVariable(SYM(input));
	}
	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));
			}

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

					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));
			}
		}
	}
	else
	{
		result = copyObject(input);
	}

	deleteObject(input);
	return result;
}

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

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

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

		return result;
	}

	object args = copyObject(PROC_COMP_ARGS(procedure));
	object body = copyObject(PROC_COMP_BODY(procedure));
	if (listLength(parameters) != listLength(args))
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
		return result;
	}

	if (!createTable())
	{
		deleteObject(args);
		deleteObject(body);
		TYPE(result) = errorObject;
		ERR(result) = maxRecursionDepthError;
		return result;
	}
	object *currentArg = &args;
	object *currentParam = &parameters;
	while (TYPE(*currentArg) != nilObject)
	{
		addSymbolVariable(SYM(CAR(*currentArg)), CAR(*currentParam));
		currentArg = &CDR(*currentArg);
		currentParam = &CDR(*currentParam);
	}
	object *currentSubProc = &body;
	while (TYPE(*currentSubProc) != nilObject)
	{
		CAR(*currentSubProc) = eval(CAR(*currentSubProc));
		if (TYPE(CDR(*currentSubProc)) == nilObject)
		{
			result = CAR(*currentSubProc);
		}
		currentSubProc = &CDR(*currentSubProc);
	}
	deleteObject(args);
	deleteObject(body);
	removeTable();

	return result;
}