cirilisp/internals.c

#include <string.h>
#include <stdlib.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) == consObject)
	{
		if (TYPE(CAR(*currentCell)) != symbolObject)
		{
			return 0;
		}
		currentCell = &CDR(*currentCell);
	}
	switch (TYPE(*currentCell))
	{
	case symbolObject:
	case nilObject:
		return 1;
	default:
		return 0;
	}
}

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

	if (!allNums(parameters))
	{
		SIGERR(typeError);
	}
	else if (listLength(parameters) == 0)
	{
		result = longlongToNumber(0LL);
	}
	else
	{
		object first, rest;
		first = CAR(parameters);
		rest = addInt(CDR(parameters));

		result = plusNum(first, rest);
	}

	return result;
}

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

	if (!allNums(parameters))
	{
		SIGERR(typeError);
	}
	else if (listLength(parameters) == 0)
	{
		SIGERR(argumentNumberError);
	}
	else if (listLength(parameters) == 1)
	{
		result = minusNum(CAR(parameters));
	}
	else
	{
		result = plusNum(CAR(parameters),
				minusNum(addInt(CDR(parameters))));
	}

	return result;
}

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

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

		result = timesNum(first,rest);
	}

	return result;
}

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

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

	return result;
}

object exactToInexactInt(object parameters)
{
	object result;

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

	return result;
}

object inexactToExactInt(object parameters)
{
	object result;

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

	return result;
}

object quoteInt(object parameters)
{
	object result;
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	else
	{
		result = copyObject(CAR(parameters));
	}
	return result;
}

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

object lambdaInt(object parameters, env currentEnv)
{
	object result;
	if (listLength(parameters) < 2)
	{
		SIGERR(argumentNumberError);
	}
	else if (!validArgumentList(CAR(parameters)))
	{
		SIGERR(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 defineInt(object parameters, env currentEnv)
{
	object result, value;
	if (listLength(parameters) == 0)
	{
		SIGERR(argumentNumberError);
	}
	else if (TYPE(CAR(parameters)) == symbolObject)
	{
		if (listLength(parameters) == 2)
		{
			result = copyObject(CAR(parameters));
			value = eval(copyObject(CAR(CDR(parameters))),
					currentEnv);
			if (TYPE(value) == errorObject)
			{
				SIGERR(ERR(value));
			}
			addSymbolVariable(SYM(result), value, currentEnv);
		}
		else
		{
			SIGERR(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 = lambdaInt(parameters,
					currentEnv);
				addSymbolVariable(SYM(result), proc,
					currentEnv);
			}
			else
			{
				SIGERR(typeError);
			}
		}
		else
		{
			SIGERR(argumentNumberError);
		}
	}
	else
	{
		SIGERR(typeError);
	}

	return result;
}

object cmpMultiple(object parameters, int flag)
/* проверава помоћу cmp функције у util.h хедеру, да ли је дата листа, листа
 * строго опадајућих, једнаких, или строго растућих бројева, у зависности од
 * тога да ли је "flag" 1, 0 или -1 респективно */
{
	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))) != flag)
		{
			resultInt = 0;
			break;
		}
		current = &CDR(*current);
	}

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

object lessInt(object parameters)
{
	return cmpMultiple(parameters, -1);
}

object eqNumInt(object parameters)
{
	return cmpMultiple(parameters, 0);
}

object greaterInt(object parameters)
{
	return cmpMultiple(parameters, 1);
}

object ifInt(object parameters, env currentEnv)
{
	object predicate, result;
	switch (listLength(parameters))
	{
	case 2:
		predicate = eval(copyObject(CAR(parameters)), currentEnv);
		if (TYPE(predicate) == errorObject)
		{
			SIGERR(ERR(predicate));
		}

		if (TYPE(predicate) == boolObject && BOOL(predicate) == 0)
		{
			TYPE(result) = nilObject;
		}
		else
		{
			result = eval(copyObject(CAR(CDR(parameters))),
				currentEnv);
		}

		if (TYPE(result) == errorObject)
		{
			SIGERR(ERR(result));
		}
		break;
	case 3:
		predicate = eval(copyObject(CAR(parameters)), currentEnv);
		if (TYPE(predicate) == errorObject)
		{
			SIGERR(ERR(predicate));
		}

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

		if (TYPE(result) == errorObject)
		{
			SIGERR(ERR(result));
		}
		break;
	default:
		SIGERR(argumentNumberError);
	}

	return result;
}

object checkType(object parameters, dataType type)
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	object result;
	TYPE(result) = boolObject;
	BOOL(result) = (type == TYPE(CAR(parameters)));
	return result;
}

object nilQInt(object parameters)
{
	return checkType(parameters, nilObject);
}

object consQInt(object parameters)
{
	return checkType(parameters, consObject);
}

object numberQInt(object parameters)
{
	return checkType(parameters, numberObject);
}

object symbolQInt(object parameters)
{
	return checkType(parameters, symbolObject);
}

object procedureQInt(object parameters)
{
	return checkType(parameters, procedureObject);
}

object boolQInt(object parameters)
{
	return checkType(parameters, boolObject);
}

object stringQInt(object parameters)
{
	return checkType(parameters, stringObject);
}

object charQInt(object parameters)
{
	return checkType(parameters, charObject);
}

object listQInt(object parameters)
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	object result;
	TYPE(result) = boolObject;
	BOOL(result) = properList(CAR(parameters));
	return result;
}

object listInt(object parameters)
{
	object result;
	result = copyObject(parameters);
	return result;
}

object consInt(object parameters)
{
	if (listLength(parameters) != 2)
	{
		SIGERR(argumentNumberError);
	}
	object result;
	TYPE(result) = consObject;
	CONS(result) = malloc(sizeof(cons));
	CAR(result) = copyObject(CAR(parameters));
	CDR(result) = copyObject(CAR(CDR(parameters)));
	return result;
}

object eqvQInt(object parameters)
{
	if (listLength(parameters) != 2)
	{
		SIGERR(argumentNumberError);
	}
	object result;
	TYPE(result) = boolObject;
	BOOL(result) = 0;
	if (TYPE(CAR(parameters)) != TYPE(CAR(CDR(parameters))))
	{
		BOOL(result) = 0;
	}
	else
	{
		switch (TYPE(CAR(parameters)))
		{
		case numberObject:
			if (NUM_TYPE(CAR(parameters)) !=
				NUM_TYPE(CAR(CDR(parameters))))
			{
				BOOL(result) = 0;
			}
			switch (NUM_TYPE(CAR(parameters)))
			{
			case fractionNum:
				BOOL(result) = NUM_NUMER(CAR(parameters)) ==
					NUM_NUMER(CAR(CDR(parameters))) &&
					NUM_DENOM(CAR(parameters)) ==
					NUM_DENOM(CAR(CDR(parameters)));
				break;
			case realNum:
				BOOL(result) = NUM_REAL(CAR(parameters)) ==
					NUM_REAL(CAR(CDR(parameters)));
				break;
			}
			break;
		case symbolObject:
			BOOL(result) = !strcmp(SYM(CAR(parameters)),
				SYM(CAR(CDR(parameters))));
			break;
		case boolObject:
			BOOL(result) = !BOOL(CAR(parameters)) ==
				!BOOL(CAR(CDR(parameters)));
			break;
		case stringObject:
			BOOL(result) = !strcmp(STR(CAR(parameters)),
				STR(CAR(CDR(parameters))));
			break;
		case charObject:
			BOOL(result) = CHR(CAR(parameters)) ==
				CHR(CAR(CDR(parameters)));
			break;
		case consObject:
		case procedureObject:
		default:
			BOOL(result) = 0;
			break;
		}
	}
	return result;
}