cirilisp/internals.c

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

#include "util.h"
#include "read.h"
#include "eval.h"
#include "print.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 allStrings(object list)
{
	object *currentCell = &list;
	while (TYPE(*currentCell) != nilObject)
	{
		if (TYPE(CAR(*currentCell)) != stringObject)
		{
			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 fractionPart(object parameters, int part)
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	if (TYPE(CAR(parameters)) != numberObject ||
		NUM_TYPE(CAR(parameters)) != fractionNum)
	{
		SIGERR(typeError);
	}
	object result;
	TYPE(result) = numberObject;
	NUM_TYPE(result) = fractionNum;
	NUM_DENOM(result) = 1;
	NUM_NUMER(result) = !part ? NUM_NUMER(CAR(parameters)) :
		NUM_DENOM(CAR(parameters));
	return result;
}

object numeratorInt(object parameters)
{
	return fractionPart(parameters, 0);
}

object denominatorInt(object parameters)
{
	return fractionPart(parameters, 1);
}

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_SPECIAL(result) = 0;
		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)
			{
				CPYERR(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);
				deleteObject(proc);
			}
			else
			{
				SIGERR(typeError);
			}
		}
		else
		{
			SIGERR(argumentNumberError);
		}
	}
	else
	{
		SIGERR(typeError);
	}

	return result;
}

object defineMacroInt(object parameters, env currentEnv)
{
	object result;
	if (listLength(parameters) < 2)
	{
		SIGERR(argumentNumberError);
	}
	else if (TYPE(CAR(parameters)) != consObject)
	{
		SIGERR(typeError);
	}
	else
	{
		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);
			PROC_SPECIAL(proc) = 1;
			addSymbolVariable(SYM(result), proc, currentEnv);
			deleteObject(proc);
		}
		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)
		{
			CPYERR(ERR(predicate));
		}

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

		if (TYPE(result) == errorObject)
		{
			CPYERR(ERR(result));
		}
		break;
	case 3:
		predicate = Eval(copyObject(CAR(parameters)), currentEnv);
		if (TYPE(predicate) == errorObject)
		{
			CPYERR(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)
		{
			CPYERR(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 checkNumType(object parameters, numType type)
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	object result;
	TYPE(result) = boolObject;
	BOOL(result) = TYPE(CAR(parameters)) == numberObject &&
		(NUM_TYPE(CAR(parameters)) == type ? 1 : 0);
	return result;
}

object fractionQInt(object parameters)
{
	return checkNumType(parameters, fractionNum);
}

object realQInt(object parameters)
{
	return checkNumType(parameters, realNum);
}

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

int validAppendArgs(object parameters)
{
	int length = listLength(parameters);
	if (length == 0 || length == 1)
	{
		return 1;
	}
	else if (!properList(CAR(parameters)))
	{
		return 0;
	}
	else
	{
		return validAppendArgs(CDR(parameters));
	}
}

object appendAux(object parameters)
{
	object result;
	if (listLength(parameters) == 0)
	{
		TYPE(result) = nilObject;
	}
	else if (listLength(parameters) == 1)
	{
		result = copyObject(CAR(parameters));
	}
	else
	{
		object rest = appendAux(CDR(parameters));
		result = copyObject(CAR(parameters));
		object *end = &result;
		while (TYPE(*end) != nilObject)
		{
			end = &CDR(*end);
		}
		*end = rest;
	}
	return result;
}

object appendInt(object parameters)
{
	if (!validAppendArgs(parameters))
	{
		SIGERR(typeError);
	}
	return appendAux(parameters);
}

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 cellElement(object parameters, int part)
/* враћа car или cdr (сар или сдр) датог конс објекта у зависности од тога да
 * ли је part 0 или нешто друго (1) */
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	if (TYPE(CAR(parameters)) != consObject)
	{
		SIGERR(typeError);
	}
	return !part ? copyObject(CAR(CAR(parameters))) :
		copyObject(CDR(CAR(parameters)));
}

object carInt(object parameters)
{
	return cellElement(parameters, 0);
}

object cdrInt(object parameters)
{
	return cellElement(parameters, 1);
}

object eqvQInt(object parameters)
{
	if (listLength(parameters) != 2)
	{
		SIGERR(argumentNumberError);
	}
	object result;
	TYPE(result) = boolObject;
	BOOL(result) = 1;
	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 nilObject:
			BOOL(result) = 1;
			break;
		case consObject:
		case procedureObject:
		default:
			BOOL(result) = 0;
			break;
		}
	}
	return result;
}

object applyInt(object parameters, env currentEnv)
{
	object expression;

	if (listLength(parameters) != 2)
	{
		SIGERR(argumentNumberError);
	}
	if (!properList(CAR(CDR(parameters))) ||
			TYPE(CAR(parameters)) != procedureObject)
	{
		SIGERR(typeError);
	}
	/* ово извршавање "примени" функције се врши тако што се "наводи" сваки
	 * појединачни члан листе параметара, и потом ствара комплетан израз
	 * који се евалуира, што укључује и примену функције, ово се чини јер
	 * по тренутном дизајну интерпретера засебна "примени" функција као
	 * таква не постоји */
	TYPE(expression) = consObject;
	CONS(expression) = malloc(sizeof(cons));
	CAR(expression) = copyObject(CAR(parameters));
	CDR(expression) = copyObject(CAR(CDR(parameters)));

	object *current = &expression;
	while (TYPE(*current) != nilObject)
	{
		CAR(*current) = quoteExpression(CAR(*current));
		current = &CDR(*current);
	}

	return Eval(expression, currentEnv);
}

object displayInt(object parameters)
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}

	if (TYPE(CAR(parameters)) == stringObject)
	{
		printf("%s", STR(CAR(parameters)));
	}
	else if (TYPE(CAR(parameters)) == charObject)
	{
		putwchar(CHR(CAR(parameters)));
	}
	else
	{
		SIGERR(typeError);
	}
	return copyObject(CAR(parameters));
}

object printInt(object parameters)
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}

	printValue(CAR(parameters));
	return copyObject(CAR(parameters));
}

object readInt(object parameters)
{
	if (listLength(parameters) != 0)
	{
		SIGERR(argumentNumberError);
	}

	return Read("", stdin);
}

object beginInt(object parameters, env currentEnv)
{
	object last;
	if (listLength(parameters) == 0)
	{
		TYPE(last) = nilObject;
	}
	else
	{
		object *current = &parameters;
		object currentResult;
		while (TYPE(CDR(*current)) != nilObject)
		{
			currentResult = Eval(copyObject(CAR(*current)), currentEnv);
			if (TYPE(currentResult) == errorObject)
			{
				CPYERR(ERR(currentResult));
			}

			current = &CDR(*current);
		}
		last = Eval(copyObject(CAR(*current)), currentEnv);
		if (TYPE(last) == errorObject)
		{
			CPYERR(ERR(last));
		}
	}
	return last;
}

object throwInt(object parameters)
{
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	if (TYPE(CAR(parameters)) != stringObject)
	{
		SIGERR(typeError);
	}

	object result;
	TYPE(result) = errorObject;
	ERR(result) = malloc((strlen(STR(CAR(parameters))) + 1) *
			sizeof(char));
	strcpy(ERR(result), STR(CAR(parameters)));
	return result;
}

object makeStrInt(object parameters)
{
	object result;
	if (listLength(parameters) != 2)
	{
		SIGERR(argumentNumberError);
	}
	if (TYPE(CAR(parameters)) != numberObject || !integer(CAR(parameters))
		|| TYPE(CAR(CDR(parameters))) != charObject)
	{
		SIGERR(typeError);
	}
	TYPE(result) = stringObject;
	if (CHR(CAR(CDR(parameters))) == L'\0')
	{
		STR(result) = malloc(sizeof(char));
		STR(result)[0] = '\0';
		return result;
	}
	STR(result) = malloc((MB_CUR_MAX * NUM_NUMER(CAR(parameters)) + 1) *
		sizeof(char));
	if (STR(result) == NULL)
	{
		SIGERR(outOfMemoryError);
	}
	int i, index;
	for (i = 0, index = 0; i < NUM_NUMER(CAR(parameters)); ++i,
		index += wctomb(STR(result) + index,
			CHR(CAR(CDR(parameters)))))
		;
	STR(result)[index] = '\0';

	return result;
}

object charInt(object parameters)
{
	object result;
	if (listLength(parameters) != 2)
	{
		SIGERR(argumentNumberError);
	}
	if (TYPE(CAR(parameters)) != stringObject ||
		TYPE(CAR(CDR(parameters))) != numberObject ||
		!integer(CAR(CDR(parameters))))
	{
		SIGERR(typeError);
	}

	TYPE(result) = charObject;
	char *mbs = STR(CAR(parameters));
	int index = NUM_NUMER(CAR(CDR(parameters))), current = 0;
	for (current = 0; current < index && *mbs != '\0';
		mbs += mblen(mbs, MB_CUR_MAX), ++current)
		;
	mbtowc(&CHR(result), mbs, MB_CUR_MAX);

	return result;
}

object strLengthInt(object parameters)
{
	object result;
	if (listLength(parameters) != 1)
	{
		SIGERR(argumentNumberError);
	}
	if (TYPE(CAR(parameters)) != stringObject)
	{
		SIGERR(typeError);
	}
	TYPE(result) = numberObject;
	NUM_TYPE(result) = fractionNum;
	NUM_DENOM(result) = 1;

	wchar_t current;
	int i = 0, length = 0;
	int cLength;
	do
	{
		cLength =
			mbtowc(&current, &STR(CAR(parameters))[i], MB_CUR_MAX);
		i += cLength;
		++length;
	} while (current != L'\0');
	length -= 1; /* одузима се дужина нул карактера */
	NUM_NUMER(result) = length;

	return result;
}

object catInt(object parameters)
{
	if (!allStrings(parameters))
	{
		SIGERR(typeError);
	}

	object result;
	TYPE(result) = stringObject;
	int stringLength = 0;
	object *current = &parameters;
	while (TYPE(*current) != nilObject)
	{
		stringLength += strlen(STR(CAR(*current)));
		current = &CDR(*current);
	}
	STR(result) = malloc((stringLength + 1) * sizeof(char));
	STR(result)[0] = '\0';

	current = &parameters;
	while (TYPE(*current) != nilObject)
	{
		strcat(STR(result), STR(CAR(*current)));
		current = &CDR(*current);
	}

	return result;
}