schemelike.cpp

#include <vector>
#include <string>
#include <map>
#include <exception>

#pragma warning( push )
#pragma warning( disable : 4702 )

namespace sl
{

	struct except : public std::exception
	{
		std::string reason;
	public:
		except( std::string const &r ) : reason( r )
		{
		}
	};

#define CHECK_SLPARAM(p,t,msg) \
	do { \
		if ( (p) == NULL || (p)->type != t ) \
		{ \
			throw sl::except( (msg) ); \
		} \
	} while (0);

#define CHECK_SLPARAM_RET(p,t,msg,r)  \
	do { \
		if ( (p) == NULL || (p)->type != t ) \
		{ \
			throw sl::except( (msg) ); \
			return (r); \
		} \
	} while (0);

#define CHECK_SLPARAMTEST_RET(p,msg,r)  \
	do { \
		if ( !(p) ) \
		{ \
			throw sl::except( (msg) ); \
			return (r); \
		} \
	} while (0);

#define CHECK_SLPARAM_COUNT(p,bp,c,msg) \
	do { \
		if ( (p) == NULL || ((p)->type != sl::CT_LIST && (p)->e->size() <= ((bp)+(c)))) \
		{ \
			throw sl::except( (msg) ); \
		} \
	} while (0);

#define CHECK_SLPARAM_COUNT_RET(p,bp,c,msg,r) \
	do { \
		if ( (p) == NULL || ((p)->type != sl::CT_LIST && (p)->e->size() <= ((bp)+(c)))) \
		{ \
			throw sl::except( (msg) ); \
			return (r); \
		} \
	} while (0);

struct env;
struct cell;
typedef cell *(*nativefunc)( env &e, unsigned int p0, cell *c );

enum celltype
{
	CT_NUMBER,
	CT_STRINGALLOC,
	CT_LIST,
	CT_POINTER,
	CT_NATIVE,
	CT_NUMBER3,
	CT_POINTER3,
	CT_STRINGSMALL,
};

struct cell
{
	short type;
	short marked;
	union
	{
		double n;
		char *sptr;
		void *p;
		std::vector<cell*> *e;
		nativefunc f;
		double n3[3];
		void *p3[3];
		char ss[sizeof(double)*3];
	};

	void mark()
	{
		if ( marked )
			return;

		marked = 1;
		if ( type == CT_LIST )
		{
			for (unsigned int i=0; i<e->size(); i++)
			{
				e->operator[](i)->mark();
			}
		}
	}

	void sweep()
	{
		if ( type == CT_LIST )
		{
			delete e;
		} else
		if ( type == CT_STRINGALLOC )
		{
			delete sptr;
		}
		type = -1;
	}
};



struct cellmem
{
	std::vector< cell* > _cells;
	std::vector< cell* > _gccells;
	std::vector< cell* > freecells;

	~cellmem()
	{
		free();
	}

	void free()
	{
		for (unsigned int i=0; i<_cells.size(); i++)
		{
			_cells[i]->sweep();
			delete _cells[i];
		}
		_cells.clear();
		for (unsigned int i=0; i<_gccells.size(); i++)
		{
			_gccells[i]->sweep();
			delete _gccells[i];
		}
		_gccells.clear();
	}

	void freetemp( cell *c )
	{
		c->sweep();
		freecells.push_back( c );
	}

	void sweep()
	{
		for (unsigned int i=0; i<_gccells.size(); i++)
		{
			if ( _gccells[i]->marked == 0 )
			{
				freetemp( _gccells[i] );
			}
			_gccells[i]->marked = 0;
		}
	}
};

struct env
{
	cellmem *mem;
	std::map<std::string, cell*> lookup;
	env *parent;
	void *user;
	std::vector< cell* > protectedcells;

	env( cellmem *m, void *u ) : mem(m), parent( NULL ), user(u) {}

	~env()
	{
	}

	cell *alloc()
	{
		cell *c = new cell;
		c->type = -1;
		c->marked = 0;
		mem->_cells.push_back( c );
		return c;
	}

	cell *alloctemp()
	{
		if ( mem->freecells.size() )
		{
			cell *c = mem->freecells.back();
			mem->freecells.pop_back();
			return c;
		}
		cell *c = new cell;
		c->type = -1;
		c->marked = 0;
		mem->_gccells.push_back( c );
		return c;
	}

	unsigned int protectindex()
	{
		return protectedcells.size();
	}

	cell* protectcell( cell *c )
	{
		protectedcells.push_back( c );
		return c;
	}

	void protectrewind( unsigned int v )
	{
		protectedcells.resize( v );
	}

	void mark()
	{
		for (unsigned int i=0; i<protectedcells.size(); i++)
		{
			protectedcells[i]->mark();
		}
		for (std::map<std::string, cell*>::iterator it=lookup.begin(); it!=lookup.end(); it++)
		{
			it->second->mark();
		}
		if ( parent )
		{
			parent->mark();
		}
	}

	void sweep()
	{
		mem->sweep();
	}

	void gc()
	{
		mark();
		sweep();
	}
};

struct autoprotect
{
	env &e;
	unsigned int index;

	autoprotect( env &_e ) : e(_e)
	{
		index = e.protectindex();
	}

	~autoprotect()
	{
		e.protectrewind(index);
	}
};

cell _T = {};
cell _F = {};
cell _Nil = {};

char *allocstring( const char *s, int len )
{
	char *cpy = new char[len+1];
	memset( cpy, 0, len+1 );
	memcpy( cpy, s, len );
	return cpy;
}

std::vector<cell*> *allocsubcells()
{
	std::vector<cell*> *sc = new std::vector<cell*>();
	return sc;
}

cell *makeNumber( env &e, double d, bool temp )
{
	cell *c = temp ? e.alloctemp() : e.alloc();
	c->type = CT_NUMBER;
	c->n = d;
	return c;
}

cell *makeNumber3( env &e, double d0, double d1, double d2, bool temp )
{
	cell *c = temp ? e.alloctemp() : e.alloc();
	c->type = CT_NUMBER3;
	c->n3[0] = d0;
	c->n3[1] = d1;
	c->n3[2] = d2;
	return c;
}

cell *makeString( env &e, const char *cstr, bool temp )
{
	cell *c = temp ? e.alloctemp() : e.alloc();
	int len = strlen( cstr );
	if ( len < (sizeof(double)*3-1) )
	{
		c->type = CT_STRINGSMALL;
		strcpy( c->ss, cstr );
	} else
	{
		c->type = CT_STRINGALLOC;
		c->sptr = allocstring( cstr, len );
	}
	return c;
}

cell *makeString( env &e, const char *cstr, int len, bool temp )
{
	cell *c = temp ? e.alloctemp() : e.alloc();
	if ( len < (sizeof(double)*3-1) )
	{
		c->type = CT_STRINGSMALL;
		strncpy( c->ss, cstr, len );
		c->ss[len]=0;
	} else
	{
		c->type = CT_STRINGALLOC;
		c->sptr = allocstring( cstr, len );
	}
	return c;
}

cell *makePtr( env &e, void *p, bool temp )
{
	cell *c = temp ? e.alloctemp() : e.alloc();
	c->type = CT_POINTER;
	c->p = p;
	return c;
}

cell *makePtr3( env &e, void *p0, void *p1, void *p2, bool temp )
{
	cell *c = temp ? e.alloctemp() : e.alloc();
	c->type = CT_POINTER3;
	c->p3[0] = p0;
	c->p3[1] = p1;
	c->p3[2] = p2;
	return c;
}

cell *makeNative( env &e, nativefunc f )
{
	cell *c = e.alloc();
	c->type = CT_NATIVE;
	c->f = f;
	return c;
}

cell* lookup( env &e, const std::string &name )
{
	std::map<std::string, cell*>::iterator f = e.lookup.find( name );
	if ( f != e.lookup.end() )
	{
		return f->second;
	}
	if ( !e.parent )
	{
		return NULL;
	} else
	{
		return lookup( *e.parent, name );
	}
}

// (func p0 ... pn)
//

static bool isnumber( std::string::size_type c, std::string::size_type e, std::string const &s )
{
	while ( c < e )
	{
		if ( (s[c] < '0' || s[c] > '9') && s[c] != '.' )
			return false;
		c++;
	}
	return true;
}

cell *atom( env &e, std::string::size_type &c, std::string const &s )
{
	if ( s[c] == '"' )
	{
		std::string::size_type end = s.find_first_of( "\"", c );
		if ( end == std::string::npos )
			return &_Nil;
		cell *cl = makeString( e, &s[c], (end-c), false );
		c = end+1;
		return cl;
	};
	std::string::size_type end = s.find_first_of( " ()\t\n\r", c );
	if ( end == std::string::npos )
		return &_Nil;
	if ( isnumber( c, end, s ) )
	{
		cell *cl = e.alloc();
		cl->type = CT_NUMBER;
		cl->n = atof( s.substr( c, end-c ).c_str() );
		c = end+1;
		return cl;
	} else
	{
		cell *cl = makeString( e, &s[c], (end-c), false );
		c = end+1;
		return cl;
	}
	return &_Nil;
}

void replace( std::string &s, std::string const &f, std::string const &t )
{
	std::string::size_type c = s.find( f );
	while ( c != std::string::npos )
	{
		s.replace( c, f.size(), t );
		c = s.find( f, c+((int)t.size()-(int)f.size()) );
	}
}

cell* tokenise( env &e, std::string::size_type &c, std::string const &s )
{
	cell *cl = e.alloc();
	cl->type = CT_LIST;
	cl->e = allocsubcells();
	c = s.find_first_not_of( " \t\n\r", c );
	if ( c == std::string::npos )
		return cl;

	while ( s[c] != ')' )
	{
		if ( s[c] == '(' )
		{
			c++;
			cl->e->push_back( tokenise( e, c, s ) );
		} else
		{
			cl->e->push_back( atom(e, c,s) );
		}
		c = s.find_first_not_of( " \t\n\r", c );
		if ( c == std::string::npos )
		{
			throw sl::except( "tokenise: Unexpected end of string" );
			return NULL;
		}
	}
	c++;
	return cl;
}

cell* tokenise( env &e, std::string s )
{
	replace( s, "(", " ( " );
	replace( s, ")", " ) " );
	std::string::size_type c = 0;
	c = s.find_first_not_of( " \t\n\r", c );
	if ( c == std::string::npos )
	{
		throw sl::except( "tokenise: Unexpected end of string" );
		return NULL;
	}
	{
		cell *cl = e.alloc();
		cl->type = CT_LIST;

		cl->e = allocsubcells();
		while ( 1 )
		{
			if ( s[c] == '(' )
			{
				c++;
				cl->e->push_back( tokenise( e, c, s ) );
			} else
			{
				throw sl::except( std::string("tokenise: '(' expected but got '")+s[c]+std::string("'") );
				return NULL;
			}
			c = s.find_first_not_of( " \t\n\r", c );
			if ( c == std::string::npos )
				return cl;
		}
		return cl;
	}
}

bool IsString( cell *c )
{
	return c && (c->type == CT_STRINGALLOC || c->type == CT_STRINGSMALL);
}

char *ResolveString( cell *c )
{
	if ( c->type == CT_STRINGALLOC )
		return c->sptr;
	if ( c->type == CT_STRINGSMALL )
		return c->ss;
	return NULL;
}

cell * eval( env &e, cell *c )
{
	autoprotect protect( e );
	if ( c->type == CT_NUMBER )
		return c;
	if ( IsString( c ) )
	{
		const char *s = ResolveString( c );
		cell *car = lookup( e, s );
		return car ? car : c;
	} else
	if ( c->type == CT_LIST )
	{
		if ( c->e->size() == 0 )
			return &_Nil;
		if ( IsString( c->e->operator[](0) ) )//->type == CT_STRING )
		{
			const char *s = ResolveString( c->e->operator[](0) );//->s;
			cell *car = lookup( e, s );
			if ( car && car->type == CT_NATIVE )
			{
				return car->f( e, 1, c );
			} else
			{
				return c;
			}
		} else
		if ( c->e->operator[](0)->type == CT_LIST )
		{
			for ( unsigned int i=0; i<c->e->size(); i++ )
			{
				eval( e, c->e->operator[](i) );
			}
			return &_Nil;
		}
		throw sl::except( "Eval: Param 0 of list is not string or list" );
	}
	return &_Nil;
}

cell *if_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	CHECK_SLPARAM_COUNT_RET( c, bp, 2, "if_func: insufficient param count", &sl::_Nil );
	cell *p0 = e.protectcell( eval( e, c->e->operator[](bp+0) ) );
	if ( p0 == &_T )
	{
		return eval( e, c->e->operator[](bp+1) );
	} else
	if ( c->e->size() > 3 )
	{
		return eval( e, c->e->operator[](bp+2) );
	} else
	{
		return &_Nil;
	}
}

cell *gr_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	CHECK_SLPARAM_COUNT_RET( c, bp, 2, "gr_func: insufficient param count", &sl::_Nil );
	cell *p0 = e.protectcell( eval( e, c->e->operator[](bp+0) ) );
	cell *p1 = e.protectcell( eval( e, c->e->operator[](bp+1) ) );
	CHECK_SLPARAM_RET( p0, CT_NUMBER, "gr_func: Param 0 of list is not number", &_Nil );
	CHECK_SLPARAM_RET( p1, CT_NUMBER, "gr_func: Param 1 of list is not number", &_Nil );
	return p0->n > p1->n ? &_T : &_F;
}

cell *ls_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	CHECK_SLPARAM_COUNT_RET( c, bp, 2, "ls_func: insufficient param count", &sl::_Nil );
	cell *p0 = e.protectcell( eval( e, c->e->operator[](bp+0) ) );
	cell *p1 = e.protectcell( eval( e, c->e->operator[](bp+1) ) );
	CHECK_SLPARAM_RET( p0, CT_NUMBER, "ls_func: Param 0 of list is not number", &_Nil );
	CHECK_SLPARAM_RET( p1, CT_NUMBER, "ls_func: Param 1 of list is not number", &_Nil );
	return p0->n < p1->n ? &_T : &_F;
}

cell *eq_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	CHECK_SLPARAM_COUNT_RET( c, bp, 2, "eq_func: insufficient param count", &sl::_Nil );
	cell *p0 = e.protectcell( eval( e, c->e->operator[](bp+0) ) );
	cell *p1 = e.protectcell( eval( e, c->e->operator[](bp+1) ) );
	CHECK_SLPARAM_RET( p0, CT_NUMBER, "eq_func: Param 0 of list is not number", &_Nil );
	CHECK_SLPARAM_RET( p1, CT_NUMBER, "eq_func: Param 1 of list is not number", &_Nil );
	return p0->n == p1->n ? &_T : &_F;
}

cell *loop_func( env &pe, unsigned int bp, cell *c )
{
	{
		autoprotect protect( pe );
		CHECK_SLPARAM_COUNT_RET( c, bp, 4, "loop_func: insufficient param count", &sl::_Nil );
		env e( pe.mem, pe.user );
		e.parent = &pe;
		cell *p0 = pe.protectcell( eval( e, c->e->operator[](bp+0) ) );
		cell *p1 = pe.protectcell( eval( e, c->e->operator[](bp+1) ) );
		cell *p2 = pe.protectcell( eval( e, c->e->operator[](bp+2) ) );
		cell *p3 = pe.protectcell( eval( e, c->e->operator[](bp+3) ) );
		CHECK_SLPARAMTEST_RET( IsString(p0), "loop_func: Param 0 of list is not string", &_Nil );
		CHECK_SLPARAM_RET( p1, CT_NUMBER, "loop_func: Param 1 of list is not number", &_Nil );
		CHECK_SLPARAM_RET( p2, CT_NUMBER, "loop_func: Param 2 of list is not number", &_Nil );
		CHECK_SLPARAM_RET( p3, CT_NUMBER, "loop_func: Param 3 of list is not number", &_Nil );
		cell *var = pe.protectcell( makeNumber( e, p1->n, true ) );
		e.lookup[ResolveString(p0)] = var;
	
		for ( double i = p1->n; i<p2->n; i+=p3->n )
		{
			var->n = i;
			for ( unsigned int j=bp+4; j<c->e->size(); j++)
			{
				eval( e, c->e->operator[](j) );
			}
		}
	}
	pe.gc();
	return &_T;
}

cell *add_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	double d = 0.0;
	for (unsigned int i=bp; i<c->e->size(); i++)
	{
		cell *p0 = e.protectcell( eval(e, c->e->operator[](i) ) );
		CHECK_SLPARAM_RET( p0, CT_NUMBER, "add_func: Param is not number", &_Nil );
		d += p0->n;
	}
	return makeNumber( e, d, true );
}

cell *max_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	double d = -DBL_MAX;
	for (unsigned int i=bp; i<c->e->size(); i++)
	{
		cell *p0 = e.protectcell( eval( e, c->e->operator[](i) ) );
		CHECK_SLPARAM_RET( p0, CT_NUMBER, "add_func: Param is not number", &_Nil );
		if ( p0->n > d )
			d = p0->n;
	}
	return makeNumber( e, d, true );
}

cell *min_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	double d = DBL_MAX;
	for (unsigned int i=bp; i<c->e->size(); i++)
	{
		cell *p0 = e.protectcell( eval( e, c->e->operator[](i) ) );
		CHECK_SLPARAM_RET( p0, CT_NUMBER, "add_func: Param is not number", &_Nil );
		if ( p0->n < d )
			d = p0->n;
	}
	return makeNumber( e, d, true );
}

cell *print_func( env &e, unsigned int bp, cell *c )
{
	autoprotect protect( e );
	for (unsigned int i=bp; i<c->e->size(); i++)
	{
		cell *p0 = e.protectcell( eval( e, c->e->operator[](i) ) );
		CHECK_SLPARAM_RET( p0, CT_NUMBER, "add_func: Param is not number", &_Nil );
		if ( p0->type == CT_NUMBER )
		{
			printf( "%lf\n", p0->n );
		}
	}
	return &_T;
}

cell *scope_func( env &pe, unsigned int bp, cell *c )
{
	{
		env e( pe.mem, pe.user );
		e.parent = &pe;
		autoprotect protect( e );

		for (unsigned int i=bp; i<c->e->size(); i++)
		{
			eval( e, c->e->operator[](i) );
		}
	}
	pe.gc();
	return &_Nil;
}

void registerCommon( env &e )
{
	e.lookup["if"] = makeNative( e, &if_func );
	e.lookup[">"] = makeNative( e, &gr_func );
	e.lookup["<"] = makeNative( e, &ls_func );
	e.lookup["=="] = makeNative( e, &eq_func );
	e.lookup["add"] = makeNative( e, &add_func );
	e.lookup["max"] = makeNative( e, &max_func );
	e.lookup["min"] = makeNative( e, &min_func );
	e.lookup["loop"] = makeNative( e, &loop_func );
	e.lookup["scope"] = makeNative( e, &scope_func );
}

#if 0
int _tmain(int argc, _TCHAR* argv[])
{
	cellmem mem;
	_T = makeNumber( mem, 1.0, false );
	_F = makeNumber( mem, 0.0, false );
	_Nil = makeNumber( mem, 0.0, false );
	env e;
	e.lookup["if"] = makeNative( mem, &if_func );
	e.lookup[">"] = makeNative( mem, &gr_func );
	e.lookup["<"] = makeNative( mem, &ls_func );
	e.lookup["=="] = makeNative( mem, &eq_func );
	e.lookup["add"] = makeNative( mem, &add_func );
	e.lookup["max"] = makeNative( mem, &max_func );
	e.lookup["min"] = makeNative( mem, &min_func );
	e.lookup["loop"] = makeNative( mem, &loop_func );
	e.lookup["print"] = makeNative( mem, &print_func );
	e.lookup["probecount"] = makeNumber( mem, 10.0, false);
	cell *c = tokenise( mem, "(if (> 1 2) (add 1 2) (add 2 2))" );
	cell *o = eval( mem, e, c );

	cell *c2 = tokenise( mem, "(loop index 0 probecount 1 (print index))" );
	cell *o2 = eval( mem, e, c2 );

	return 0;
}
#endif

#if 0

(loop index 0 (probecount) 1
	(print index)
	)

#endif

}

#pragma warning( pop )