kolibrios/programs/cmm/experimental/lisp/lisp.c

/*
 * Author Pavel Iakovlev by PaulCodeman
*/

#define MEMSIZE 4096*10

#include "../lib/io.h"
#include "../lib/obj/console.h"

#define TString 1
#define TSymbol 2
#define TNumber 3
#define TList   4
#define Proc    5
#define Lambda  6
#define TObject 7

#define sizeStruct 4*4

byte initConsole = 0;
dword maxLoop = 100;
dword buffer = 0;
dword bufferSize = 1000;
dword variable = 0;
dword key = 0;
dword treeItem = 0;
dword NIL = 0;

void consoleInit()
{
	IF(!initConsole)
	{
		load_dll(libConsole, #con_init, 0);
		con_init stdcall (-1, -1, -1, -1, "Lisp interpreter");
		initConsole = 0xFF;
	}
}

dword error_message(dword text)
{
	con_printf stdcall (text);
	ExitProcess();
}

dword crc32Table = 0;
dword makeCRCTable(void)
{
	dword i = 0;
	dword c = 0;
	dword ii = 0;
	dword crcTable = 0;
	IF (crc32Table) RETURN 0;
	crc32Table = malloc(4*256);
	crcTable = crc32Table;
	WHILE (i < 256)
	{
		c = i;
		ii = 0;
		WHILE (ii < 8)
		{
			IF (c&1)
			{
				c >>= 1;
				c ^= 0xEDB88320;
			}
			ELSE c >>= 1;
			ii++;
		}
		DSDWORD[crcTable] = c;
		crcTable += 4;
		i++;
	}
}
dword crc32(dword bytes)
{
	dword crc = 0;
	byte b = 0;
	IF (!crc32Table) makeCRCTable();
	crc = 0xFFFFFFFF;
	WHILE (DSBYTE[bytes])
	{
		b = DSBYTE[bytes];
		bytes++;
		EDX = crc^b;
		EDX &= 0xFF;
		EDX <<= 2;
		EDX += crc32Table;
		crc >>= 8;
		crc ^= DSDWORD[EDX];
	}
	RETURN crc ^ 0xFFFFFFFF;
}

dword indexArray(dword address, key)
{
	dword offset = key&11b;
	dword offsetAddress = offset*4+address;
	IF (key==offset) RETURN 4*4+offsetAddress;
	IF (!DSDWORD[offsetAddress]) DSDWORD[offsetAddress] = malloc(4*4*2);
	RETURN indexArray(DSDWORD[offsetAddress], key>>2);
}

void set_procedure(dword name, address)
{
	dword data = 0;
	data = malloc(sizeStruct);
	DSDWORD[data] = Proc;
	DSDWORD[data+4] = address;
	indexArray(variable, crc32(name));
	DSDWORD[EAX] = data;
}

void set_variable(dword name, data)
{
	indexArray(variable, crc32(name));
	DSDWORD[EAX] = data;
}

dword string(dword lisp)
{
	dword buffer = 0;
	if (DSDWORD[lisp] == TList)
	{
		
		return "";
	}
	switch (DSDWORD[lisp])
	{
		case TString:
		case TSymbol:
			return DSDWORD[lisp+4];
		case TNumber:
			
			return itoa(DSDWORD[lisp+4]);
		case Lambda:
			return "[LAMBDA]";
		case Proc:
			return "[PROC]";
		case TObject:
			return "[OBJECT]";
		case TList:
			return "[LIST]";
	}
}

dword number(dword lisp)
{
	if (DSDWORD[lisp] == TNumber)
	{
		return DSDWORD[lisp+4];
	}
	if (DSDWORD[lisp] == TString)
	{
		//return atoi(DSDWORD[lisp+4]);
	}
	return 0;
}

dword lexer(dword code)
{
	byte s = 0;
	dword alloc = 0;
	dword buffer = 0;
	dword position = 0;
	dword key = 0;
	alloc = malloc(32);
	//con_printf stdcall(code);
	while(DSBYTE[code])
	{
		s = DSBYTE[code];
		code++;
		if (s == ' ') || (s == '\n') || (s == '\t') || (s == '\r') continue;
		if (s == '(') || (s == ')')
		{
			buffer = malloc(2);
			DSBYTE[buffer] = s;
			indexArray(alloc, key);
			DSDWORD[EAX] = buffer;
			key++;
			continue;
		}
		buffer = malloc(25);
		position = buffer;
		DSBYTE[position] = s;
		if (s == '"')
		{
			while(DSBYTE[code])
			{
				s = DSBYTE[code];
				position++;
				DSBYTE[position] = s;
				code++;
				if (s == '"') && (DSBYTE[code-2] != '\\') break;
			}
		}
		else
		{
			while(DSBYTE[code])
			{
				s = DSBYTE[code];
				if (s == ' ') || (s == '\n') || (s == '\t') || (s == '\r') || (s == '(') || (s == ')') break;
				position++;
				DSBYTE[position] = s;
				code++;
			}
		}
		indexArray(alloc, key);
		DSDWORD[EAX] = buffer;
		key++;
	}
	indexArray(alloc, key);
	DSDWORD[EAX] = 0;
	/*key = 0;
	do {
	buffer = indexArray(alloc, key);
	if (!DSDWORD[buffer]) break;
	con_printf stdcall ("\r\n");
	con_printf stdcall (DSDWORD[buffer]);key++;
	} while(1);*/
	return alloc;
}


dword tree(dword alloc)
{
	dword token = 0;
	dword list = 0;
	dword buffer = 0;
	dword temp = 0;
	dword listBuffer = 0;
	dword i = 0;
	token = indexArray(alloc, treeItem);
	treeItem++;
	buffer = DSDWORD[token];

	if (DSBYTE[buffer] == '(')
	{
		list = malloc(32);
		while(1) {
			token = indexArray(alloc, treeItem);
			token = DSDWORD[token];
			if (!token) || (DSBYTE[token] == ')') break;
			buffer = indexArray(list, i);
			DSDWORD[buffer] = tree(alloc);
			i++;
		}
		treeItem++;
		indexArray(list, i);
		DSDWORD[EAX] = 0;
		malloc(sizeStruct);
		DSDWORD[EAX] = TList;
		DSDWORD[EAX+4] = list;
		return EAX;
	}
	return atom(DSDWORD[token]);
}

dword hexdec2(dword buffer, length)
{
	dword r = 0;
	length += buffer;
	while (length != buffer)
	{
		length--;
		r <<= 4;
		if (DSBYTE[length] >= 'A') && (DSBYTE[length] <= 'F') r |= DSBYTE[length]-'A'+10;
		else if (DSBYTE[length] >= 'a') && (DSBYTE[length] <= 'f') r |= DSBYTE[length]-'a'+10;
		else if (DSBYTE[length] >= '0') && (DSBYTE[length] <= '9') r |= '9'-DSBYTE[length];
	}
	return r;
}

dword atom(dword token)
{
	dword buffer = 0;
	dword pos = 0;
	dword data = 0;
	if (DSBYTE[token] == '-') && (DSBYTE[token+1] >= '0') && (DSBYTE[token+1] <= '9')
	{
		malloc(sizeStruct);
		DSDWORD[EAX] = TNumber;
		DSDWORD[EAX+4] = atoi(token);
		return EAX;
	}
	if (DSBYTE[token] >= '0') && (DSBYTE[token] <= '9')
	{
		while (DSBYTE[token]) && (DSBYTE[token] >= '0') && (DSBYTE[token] <= '9')
		{
			data *= 10;
			data += DSBYTE[token]-'0';
			token++;
		}

		malloc(sizeStruct);
		DSDWORD[EAX] = TNumber;
		DSDWORD[EAX+4] = data;
		return EAX;
	}
	if (DSBYTE[token] == '"')
	{	
		pos = token;
		buffer = token;
		pos++;
		while (DSBYTE[pos]) && (DSBYTE[pos] != '"')
		{
			if (DSBYTE[pos] == '\\')
			{
				pos++;
				switch (DSBYTE[pos])
				{
					case 'n': DSBYTE[buffer] = 13; break; 
					case 'r': DSBYTE[buffer] = 10; break; 
					case 't': DSBYTE[buffer] = 9;  break; 
					case 'x':
						pos++;
						DSBYTE[buffer] = hexdec2(pos, 2);
						pos++;
					break; 
					default:
						DSBYTE[buffer] = DSBYTE[pos];
				}
			}
			else DSBYTE[buffer] = DSBYTE[pos];
			buffer++;
			pos++;
		}
		DSBYTE[buffer] = 0;
		malloc(sizeStruct);
		DSDWORD[EAX] = TString;
		DSDWORD[EAX+4] = token;
		DSDWORD[EAX+8] = token-buffer;
		return EAX;
	}
	pos = token;
	while (DSBYTE[pos])
	{
		if (DSBYTE[pos] >= 'a') && (DSBYTE[pos] <= 'z') DSBYTE[pos] = DSBYTE[pos]-'a'+'A';
		pos++;
	}
	malloc(sizeStruct);
	DSDWORD[EAX] = TSymbol;
	DSDWORD[EAX+4] = token;
	return EAX;
}

dword lisp(dword tree)
{
	dword buffer = 0;
	dword list = 0;
	dword args = 0;
	dword key = 0;
	dword item = 0;

	switch (DSDWORD[tree])
	{
		case TSymbol:
			buffer = indexArray(variable, crc32(DSDWORD[tree+4]));
			IF (!DSDWORD[buffer]) return tree;
			return DSDWORD[buffer];
		case TNumber:
		case TString:
			return tree;	
		case TList:
			list = DSDWORD[tree+4];
			buffer = indexArray(list, 0);
			if (!buffer) {
				malloc(sizeStruct);
				DSDWORD[buffer] = TSymbol;
				DSDWORD[buffer+4] = NIL;
				return buffer;
			}
			
			buffer = DSDWORD[buffer];
			if (DSDWORD[buffer] == TSymbol) || (DSDWORD[buffer] == TList)
			{
				buffer = DSDWORD[buffer+4];
				if (DSBYTE[buffer] == '\'') return tree;

				args = malloc(32);
				key = 0;
				while (1)
				{
					buffer = indexArray(list, key);
					buffer = DSDWORD[buffer];
					if (!buffer) break;
					item = indexArray(args, key);
					DSDWORD[item] = lisp(buffer);
					key++;
				}
				item = indexArray(args, 0);
				item = DSDWORD[item];
				if (DSDWORD[item] == Proc)
				{
					EAX = DSDWORD[item+4];
					EAX(args);
					if (!EAX)
					{
						malloc(sizeStruct);
						DSDWORD[EAX] = TSymbol;
						DSDWORD[EAX+4] = NIL;
						return EAX;
					}
					return EAX;
				}
				malloc(sizeStruct);
				DSDWORD[EAX] = TSymbol;
				DSDWORD[EAX+4] = NIL;
				return EAX;
			}

			malloc(sizeStruct);
				DSDWORD[EAX] = TSymbol;
				DSDWORD[EAX+4] = NIL;
				return EAX;
	}
}

#include "stdcall.h"

void main()
{
	dword xxx = 0;
	dword item = 0;
	dword data = 0;
	
	buffer = malloc(bufferSize);

	variable = malloc(32);
	NIL = "NIL";

	initFunctionLisp();
	
	if(DSBYTE[I_Param])
	{
		IF(io.read(I_Param))
		{
			lisp(tree(lexer(EAX)));
		}
	}
	else
	{
		consoleInit();
		con_printf stdcall ("Lisp v2.0\r\n");
		while(maxLoop)
		{
			treeItem = 0;
			con_printf stdcall ("\r\n$ ");
			con_gets stdcall(buffer+1, bufferSize);
			DSBYTE[buffer] = '(';
			xxx= lisp(tree(lexer(buffer)));
			con_printf stdcall (string(xxx));
			maxLoop--;
		}
	}

	IF(initConsole) con_exit stdcall (1);
	ExitProcess();
}