cirilisp/internals.c

#include <string.h>

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

int allNums(object list)
{
	object *currentCell = &list;
	while (TYPE(*currentCell) != nilObject)
	{
		if (TYPE(CAR(*currentCell)) != numberObject)
		{
			return 0;
		}
		currentCell = &CDR(*currentCell);
	}
	return 1;
}

int allSyms(object list)
{
	object *currentCell = &list;
	while (TYPE(*currentCell) != nilObject)
	{
		if (TYPE(CAR(*currentCell)) != symbolObject)
		{
			return 0;
		}
		currentCell = &CDR(*currentCell);
	}
	return 1;
}



object add(object parameters)
{
	object result;
	TYPE(result) = numberObject;

	if (!allNums(parameters))
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}
	else if (listLength(parameters) == 0)
	{
		result = longlongToNumber(0LL);
	}
	else
	{
		object first, rest;
		first = CAR(parameters);
		rest = add(CDR(parameters));

		result = plusNum(first, rest);
	}

	return result;
}

object subtract(object parameters)
{
	object result;
	TYPE(result) = numberObject;

	if (!allNums(parameters))
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}
	else if (listLength(parameters) == 0)
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
	}
	else if (listLength(parameters) == 1)
	{
		result = minusNum(CAR(parameters));
	}
	else
	{
		result = plusNum(CAR(parameters),
				minusNum(add(CDR(parameters))));
	}

	return result;
}

object multiply(object parameters)
{
	object result;
	TYPE(result) = numberObject;

	if (!allNums(parameters))
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}
	else if (listLength(parameters) == 0)
	{
		result = longlongToNumber(1LL);
	}
	else
	{
		object first, rest;
		first = CAR(parameters);
		rest = multiply(CDR(parameters));

		result = timesNum(first,rest);
	}

	return result;
}

object divide(object parameters)
{
	object result;
	TYPE(result) = numberObject;

	if (!allNums(parameters))
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}
	else if (listLength(parameters) == 0)
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
	}
	else if (listLength(parameters) == 1)
	{
		result = inverseNum(CAR(parameters));
	}
	else
	{
		object check = inverseNum(multiply(CDR(parameters)));
		if (TYPE(check) != errorObject)
		{
			result = timesNum(CAR(parameters),
				inverseNum(multiply(CDR(parameters))));
		}
		else
		{
			result = check;
		}
		result = shortenFractionNum(result);
	}

	return result;
}

object exactToInexact(object parameters)
{
	object result;

	if (listLength(parameters) != 1)
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
	}
	else if (TYPE(CAR(parameters)) != numberObject)
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}
	else
	{
		result = exactToInexactNum(CAR(parameters));
	}

	return result;
}

object inexactToExact(object parameters)
{
	object result;

	if (listLength(parameters) != 1)
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
	}
	else if (TYPE(CAR(parameters)) != numberObject)
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}
	else
	{
		result = inexactToExactNum(CAR(parameters));
	}

	return result;
}

object quote(object parameters)
{
	object result;
	if (listLength(parameters) != 1)
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
	}
	else
	{
		result = copyObject(CAR(parameters));
	}
	return result;
}

int validArgumentList(object list)
{
	if (!properList(list) || !allSyms(list))
	{
		return 0;
	}
	else
	{
		int allUniqueSyms = 1;
		object *currentSymbol1 = &list;
		while (TYPE(*currentSymbol1) != nilObject)
		{
			object *currentSymbol2 = &CDR(*currentSymbol1);
			while (TYPE(*currentSymbol2) != nilObject)
			{
				if (!strcmp(SYM(CAR(*currentSymbol1)),
					SYM(CAR(*currentSymbol2))))
				{
					allUniqueSyms = 0;
					goto breakloop;
				}
				currentSymbol2 = &CDR(*currentSymbol2);
			}
			currentSymbol1 = &CDR(*currentSymbol1);
		}
breakloop:
		return allUniqueSyms;
	}
}

object lambda(object parameters, env currentEnv)
{
	object result;
	if (listLength(parameters) < 2)
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
	}
	else if (!validArgumentList(CAR(parameters)))
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}
	else
	{
		TYPE(result) = procedureObject;
		PROC(result) = createProcedure();
		PROC_TYPE(result) = compoundProc;
		PROC_COMP_ARGS(result) = copyObject(CAR(parameters));
		PROC_COMP_BODY(result) = copyObject(CDR(parameters));
		PROC_COMP_ENV(result) = currentEnv;
	}

	return result;
}

object define(object parameters, env currentEnv)
{
	object result;
	if (listLength(parameters) == 0)
	{
		TYPE(result) = errorObject;
		ERR(result) = argumentNumberError;
	}
	else if (TYPE(CAR(parameters)) == symbolObject)
	{
		if (listLength(parameters) == 2)
		{
			result = copyObject(CAR(parameters));
			addSymbolVariable(SYM(result),
				eval(copyObject(CAR(CDR(parameters))),
					currentEnv),
				currentEnv);
		}
		else
		{
			TYPE(result) = errorObject;
			ERR(result) = argumentNumberError;
		}
	}
	else if (TYPE(CAR(parameters)) == consObject)
	{
		if (listLength(parameters) >= 2)
		{
			if (allSyms(CAR(parameters)))
			{
				result = copyObject(CAR(CAR(parameters)));
				object args = copyObject(CDR(CAR(parameters)));
				deleteObject(CAR(parameters));
				CAR(parameters) = copyObject(args);
				deleteObject(args);
				object proc = lambda(parameters, currentEnv);
				addSymbolVariable(SYM(result), proc,
					currentEnv);
			}
			else
			{
				TYPE(result) = errorObject;
				ERR(result) = typeError;
			}
		}
		else
		{
			TYPE(result) = errorObject;
			ERR(result) = argumentNumberError;
		}
	}
	else
	{
		TYPE(result) = errorObject;
		ERR(result) = typeError;
	}

	return result;
}

object less(object parameters)
{
	if (!allNums(parameters))
	{
		SIGERR(typeError);
	}

	if (listLength(parameters) == 0 || listLength(parameters) == 1)
	{
		return intToBool(1);
	}

	int resultInt = 1;
	object *current = &parameters;
	while (TYPE(CDR(*current)) != nilObject)
	{
		if (cmp(CAR(*current), CAR(CDR(*current))) >= 0)
		{
			resultInt = 0;
			break;
		}
		current = &CDR(*current);
	}

	object result;
	TYPE(result) = boolObject;
	BOOL(result) = resultInt;
	return result;
}

object greater(object parameters)
{
	if (!allNums(parameters))
	{
		SIGERR(typeError);
	}

	if (listLength(parameters) == 0 || listLength(parameters) == 1)
	{
		return intToBool(1);
	}

	int resultInt = 1;
	object *current = &parameters;
	while (TYPE(CDR(*current)) != nilObject)
	{
		if (cmp(CAR(*current), CAR(CDR(*current))) <= 0)
		{
			resultInt = 0;
			break;
		}
		current = &CDR(*current);
	}

	object result;
	TYPE(result) = boolObject;
	BOOL(result) = resultInt;
	return result;
}

object ifStatement(object parameters, env currentEnv)
{
	object predicate, result;
	switch (listLength(parameters))
	{
	case 2:
		predicate = eval(CAR(parameters), currentEnv);

		if (TYPE(predicate) == boolObject && BOOL(predicate) == 0)
		{
			TYPE(result) = unspecifiedObject;
		}
		else
		{
			result = eval(copyObject(CAR(CDR(parameters))),
				currentEnv);
		}
		break;
	case 3:
		predicate = eval(CAR(parameters), currentEnv);

		if (TYPE(predicate) == boolObject && BOOL(predicate) == 0)
		{
			result = eval(copyObject(CAR(CDR(CDR(parameters)))),
				currentEnv);
		}
		else
		{
			result = eval(copyObject(CAR(CDR(parameters))),
				currentEnv);
		}
		break;
	default:
		SIGERR(argumentNumberError);
	}

	return result;
}