////////////////////////////////
//PaScheme            PaScheme//
////////////////////////////////
//                            //
//  Distribute under GPL v.2  //
//         or later           //
//  (c)2002  Petr Cermak      //
//       xgxg@seznam.cz       //
////////////////////////////////


#include <stdlib.h>
#include <string.h>
#include "functions.h"
#include "consts.h"

Object* global_position;	//for error printing

Object* execute(char* code)
{
	create_bifobjs();
	return ev_list(parse_list(code), NULL);
}

/*
 * Parsing text input into object
 */

void create_bifobjs()
{
	int i;
	Object* pobj;

	for (i=0; i<NBIFS; i++)
	{
		pobj=create_object(BIF);
		pobj->data.bif.pfunc=functions[i];
		pobj->data.bif.str=fcstr[i];
		bif_objects[i]=pobj;
	}
}

Object* parse_list(char* code)
{
	Object* pobjfirst;
	Object* pobj;
	Object* pobjprev=NULL;

	code=get_first_item(code);

	if (*code==RP) 
		return create_object(NIL);

	do {
		pobj=create_object(CONS);
		pobj->data.cons.car=parse(code);
		if (pobjprev==NULL) {
			pobjfirst=pobj;
		}
		else {
			pobjprev->data.cons.cdr=pobj;
		}
		pobjprev=pobj;
	} while(code=get_next_item(code));
	pobjprev->data.cons.cdr=create_object(NIL);

	return pobjfirst;
}

Object* parse(char* code)
{
	Object* pobj;
	Object* pobj1;
	int i;

	if (*code==LP)
		return parse_list(code+1);

	if (isnumeric(*code)) {
		pobj=create_object(INTEGER);
		sscanf(code, "%d", &pobj->data.integer);
		return pobj;
	}

	if (*code==AP) {
		pobj=create_object(CONS);
		
		pobj1=create_object(BIF);
		pobj1->data.bif.pfunc=&quote_f;
		pobj1->data.bif.str=fcstr[QUOTEF];
		pobj->data.cons.car=pobj1;

		code=get_first_item(code+1);
		
		pobj1=create_object(CONS);
		pobj1->data.cons.car=parse(code);
		pobj1->data.cons.cdr=create_object(NIL);

		pobj->data.cons.cdr=pobj1;

		return pobj;
	}

	if (*code==QU) {
		pobj=create_object(STRING);
		pobj->data.string=code;
		return pobj;
	}

	if (strpcmp(code, DEFINE))
		return create_object(DEF);

	for(i=0; i<NBIFS; i++) {
		if (strpcmp(code, bif_objects[i]->data.bif.str))
			return bif_objects[i];
	}
	
	//Unknown identifier

	pobj=create_object(CODE);
	pobj->data.code=code;
	return pobj;
}

/*
 * Evaluating
 */

// Evaluate list of objects (whole program, body of function)
Object* ev_list(Object* object, HDef* defs)
{
	Object* pobj;	
	Object* pretobj=NULL;

	do {
		pobj=car(object);
		global_position=pobj;
		if (pobj->type==CONS && car(pobj)->type==DEF) {
			if (defs==NULL) {
				defs=create_defs();
			}
			add_def(cdr(pobj), defs);
		}
		else {
			pretobj=eval(pobj, defs);
		}
	} while((object=cdr(object))->type!=NIL);
	
	if (pretobj==NULL) {
		global_position=NULL;
		error(SEDNCALLED, EDEBUG);
	}
	return pretobj;
}

// Evaluate one object
Object* eval(Object* object, HDef* defs) 
{
	Object* pobj;
	Object* pobj2;
	Object* pcodeobj;
	Object* pretobj;
	char errmsg[256];


	switch (object->type){
	case INTEGER:
	case STRING:
	case NIL:
		return create_object_o(object);
		break;
	case CODE:
		if ((pobj=find_object(object->data.code, defs))!=NULL) {
			return pobj;
		}
		else {
			sprintf(errmsg, SENAMEID);
			err_paste_id(errmsg, object->data.code);
			error(errmsg, ENAME);
			return NULL;
		}
		break;
	case CONS:
		pobj=object->data.cons.car;
		switch(pobj->type) {
		case BIF:
			return (*pobj->data.bif.pfunc)(cdr(object), defs);
			break;
		case CONS: 
			pobj2=eval(pobj, defs);
			pcodeobj=NULL;			//Unnamed lambda can't call itself
			break;
		case CODE:
			pobj2=find_object(pobj->data.code, defs);
			if (pobj2==NULL) {
				sprintf(errmsg, SENAMEFC);
				err_paste_id(errmsg, pobj->data.code);
				error(errmsg, ENAME);
				return NULL;
			}
			pcodeobj=pobj;
			break;
		default:
			error(SESYNTAX, ESYNTAX);
			return NULL;
			break;
		}
		if (pobj2->type!=LAMBDA) {
			error(SETNFUNC, ETYPE);
			return NULL;
		}
		pretobj=call_func(pobj2, object->data.cons.cdr, defs, pcodeobj);
		erase_object(pobj2);
		return pretobj;
		break;

	default:
		error(SESYNTAX, ESYNTAX);
		return NULL;
		break;
	}
}


Object* call_func(Object* function, Object* args, HDef* defs, Object* codeobj)
/*
defs are for future use -
for example MIT Scheme can do this:
(define f (lambda () (+ c d)))
(define c 5)
(define d 8)
(f)
13

PaScheme allows only to use already known identifiers when function was defined
*/
{	
	HDef* plocdefs=create_defs();
	int noargs=function->data.lambda.nargs;
	Object* names=function->data.lambda.names;
	Object* pretobj;
	Object* parg;
	Def* rekurdef;

	//eval & make define on all args - will be deallocated in eval.

	create_defs_from(function->data.lambda.defs, plocdefs);
	
	//add argument defs
	if (args==NULL && noargs>=1) {
		error(SEUFARGS, EARGS);
		return NULL;
	}
	parg=args;
	while(parg->type!=NIL && noargs>=1) {
		add_def_arg(car(parg), car(names), defs, plocdefs);
		noargs--;
		names=cdr(names);
		parg=cdr(parg);
	}

	if (parg->type!=NIL || noargs!=0) {
		error(SEUFARGS, EARGS);
		return NULL;
	}
	
	//add def for recursion
	if (codeobj!=NULL) {
		rekurdef=create_def();
		rekurdef->object=create_object(CONS);
		rekurdef->object->data.cons.car=codeobj;  //name
		rekurdef->object->data.cons.cdr=create_object_o(function);
		add_to_hash(rekurdef, plocdefs);
	}

	pretobj=ev_list(function->data.lambda.code, plocdefs);
	free_defs(plocdefs);
	return pretobj;
}


/*
 * Built-in functions
 */

Object* quote_f(Object* args, HDef* defs)
{
	return create_object_o(car(args));
}


//list functions


Object* eval_f(Object* args, HDef* defs)
{
	if (n_args(args)!=1) {
		error(SEEVARGS, EARGS);
		return NULL;
	}
	return (eval(eval(car(args), defs), defs));
}

Object* cons_f(Object* args, HDef* defs)
{
	Object* pobj1;
	Object* pobj2; 
	Object* pretobj;
	
	if (n_args(args)!=2) {
		error(SECOARGS, EARGS);
		return NULL;
	}

	pobj1=eval(car(args), defs);
	pobj2=eval(car(cdr(args)), defs);
	
	pretobj=create_object(CONS);
	pretobj->data.cons.car=pobj1;
	pretobj->data.cons.cdr=pobj2;
	return pretobj;
}

Object* list_f(Object* args, HDef* defs)
{
	Object* pobj; 
	Object* pretobj;

	if (args==NULL || args->type==NIL)
		return create_object(NIL);
	
	pobj=eval(car(args), defs);

	pretobj=create_object(CONS);
	pretobj->data.cons.car=pobj;
	pretobj->data.cons.cdr=list_f(cdr(args), defs);
	
	return pretobj;
}

Object* null_f(Object* args, HDef* defs)
{
	Object* pobj; 
	Object* pretobj;
	
	if (n_args(args)!=1) {
		error(SENUARGS, EARGS);
		return NULL;
	}

	pobj=eval(car(args), defs);
	
	if (pobj->type!=CONS && pobj->type!=NIL) {
		erase_object(pobj);
		error(SETYPENU, ETYPE);
		return NULL;
	}

	pretobj=create_object(INTEGER);
	
	if (pobj->type==NIL) {
		pretobj->data.integer=1;
		return pretobj;
	}

	pretobj->data.integer=0;
	return pretobj;
}

Object* car_f(Object* args, HDef* defs)
{
	Object* pobj;
	Object* pretobj;

	if (n_args(args)!=1) {
		error(SECAARGS, EARGS);
		return NULL;
	}

	pobj=eval(car(args), defs);
	
	if (pobj->type!=CONS) {
		erase_object(pobj);
		error(SETYPECA, ETYPE);
		return NULL;
	}
	
	pretobj=create_object_o(car(pobj));
	erase_object(pobj);
	return pretobj;
}

Object* cdr_f(Object* args, HDef* defs)
{
	Object* pobj;
	Object* pretobj;
	
	if (n_args(args)!=1) {
		error(SECDARGS, EARGS);
		return NULL;
	}

	pobj=eval(car(args), defs);
	
	if (pobj->type!=CONS) {
		erase_object(pobj);
		error(SETYPECD, ETYPE);
		return NULL;
	}
	
	pretobj=create_object_o(cdr(pobj));
	erase_object(pobj);
	return pretobj;
}


//condition
Object* cond_f(Object* args, HDef* defs)
{
	Object* pobj;
	
	if (n_args(args)<1) {
		error(SECDARGS, EARGS);
		return NULL;
	}
	
	do {
		pobj=eval(car(car(args)), defs);
		if (pobj->type!=INTEGER) {
			erase_object(pobj);
			error(SETYPEINT, ETYPE);
			return NULL;
		}
		if (pobj->data.integer!=0) {
			erase_object(pobj);
			pobj=cdr(car(args));

			if (pobj->type!=CONS) {
				error(SERETARGS, EARGS);
				return NULL;
			}
			
			return eval(car(pobj), defs);
			break;
		}
		erase_object(pobj);
		args=cdr(args);
	} while (args->type!=NIL);
	pobj=create_object(INTEGER);
	pobj->data.integer=0;
	return pobj;
}
	

Object* if_f(Object* args, HDef* defs)
{
	Object* pobj;
	
	if (n_args(args)!=3) {
		error(SEIFARGS, EARGS);
		return NULL;
	}

	pobj=eval(car(args), defs);
	if (pobj->type!=INTEGER) {
		erase_object(pobj);
		error(SETYPEINT, ETYPE);
		return NULL;
	}

	if (pobj->data.integer!=0) {	//TRUE
		erase_object(pobj);
		return eval(car(cdr(args)), defs);
	} 
	else {							//FALSE
		erase_object(pobj);
		return eval(car(cdr(cdr(args))), defs);
	} 
}

//creating lambda function
Object* lambda_f(Object* args, HDef* defs)
{
	Object* pobj;
	
	if (n_args(args)<=1) {
		error(SELAARGS, EARGS);
		return NULL;
	}

	Object* cargs=car(args);

	if (cargs->type!=NIL && cargs->type!=CONS) {
		error(SELASYNT, ESYNTAX);
		return NULL;
	}

	pobj=create_object(LAMBDA);	
	
	pobj->data.lambda.nargs=n_args(cargs);

	pobj->data.lambda.names=cargs;
	pobj->data.lambda.defs=create_defs();
	create_defs_from(defs, pobj->data.lambda.defs);
	pobj->data.lambda.code=cdr(args);
	
	return pobj;
}


// binary built-in functions
// relations
#define BIF_FUNC(fname, func, fstr)								\
Object* fname(Object* args, HDef* defs)							\
{																\
	Object* pobj1;												\
	Object* pobj2;												\
	Object* pretobj;											\
	char buf[256];												\
																\
	if (n_args(args)!=2) {										\
		sprintf(buf, SEARARGS, fstr);							\
		error(buf, EARGS);										\
		return NULL;											\
	}															\
																\
	pobj1=eval(car(args), defs);								\
	pobj2=eval(car(cdr(args)), defs);							\
																\
	if (pobj1->type!=INTEGER || pobj2->type!=INTEGER) {			\
		sprintf(buf, SETYPEAR, fstr);							\
		error(buf, ETYPE);										\
		return NULL;											\
	}															\
																\
	pretobj=create_object(INTEGER);								\
	if (pobj1->data.integer func pobj2->data.integer) {			\
		pretobj->data.integer=1;								\
	}															\
	else {														\
		pretobj->data.integer=0;								\
	}															\
	erase_object(pobj1);										\
	erase_object(pobj2);										\
	return pretobj;												\
}

BIF_FUNC(g_f, >, ">")
BIF_FUNC(l_f, <, "<")
BIF_FUNC(ge_f, >=, ">=")
BIF_FUNC(le_f, <=, "<=")
BIF_FUNC(ne_f, !=, "!=")
BIF_FUNC(eq_f, ==, "=")

//arithmetic operations

Object* plus_f(Object* args, HDef* defs)
{
	Object* pobj1;
	Object* pobj2;
	Object* pretobj;

	if (n_args(args)!=2) {
		error(SEPLARGS, EARGS);
		return NULL;
	}
	
	pobj1=eval(car(args), defs);
	pobj2=eval(car(cdr(args)), defs);
	
	if (pobj1->type!=INTEGER || pobj2->type!=INTEGER) {
		error(SETYPEPL, ETYPE);
		return NULL;
	}
	
	pretobj=create_object(INTEGER);
	pretobj->data.integer=pobj1->data.integer + pobj2->data.integer;
	erase_object(pobj1);
	erase_object(pobj2);
	return pretobj;
}

Object* minus_f(Object* args, HDef* defs)
{
	Object* pobj1;
	Object* pobj2;
	Object* pretobj;
	int nargs=n_args(args);

	if (nargs<1 || nargs>2) {
		error(SEMIARGS, EARGS);
		return NULL;
	}

	pobj1=eval(car(args), defs);
	if (nargs==2) {
		pobj2=eval(car(cdr(args)), defs);
		if (pobj1->type!=INTEGER || pobj2->type!=INTEGER) {
			error(SETYPEMI, ETYPE);
			return NULL;
		}
		pretobj=create_object(INTEGER);
		pretobj->data.integer=pobj1->data.integer - pobj2->data.integer;
		erase_object(pobj1);
		erase_object(pobj2);
	}
	else {
		if (pobj1->type!=INTEGER) {
			error(SETYPEMI, ETYPE);
			return NULL;
		}
		pretobj=create_object(INTEGER);
		pretobj->data.integer=-pobj1->data.integer;
		erase_object(pobj1);
	}
	return pretobj;
}

Object* mult_f(Object* args, HDef* defs)
{
	Object* pobj1;
	Object* pobj2;
	Object* pretobj;

	if (n_args(args)!=2) {
		error(SEMUARGS, EARGS);
		return NULL;
	}
	
	pobj1=eval(car(args), defs);
	pobj2=eval(car(cdr(args)), defs);
	
	if (pobj1->type!=INTEGER || pobj2->type!=INTEGER) {
		error(SETYPEMU, ETYPE);
		return NULL;
	}
	
	pretobj=create_object(INTEGER);
	pretobj->data.integer=pobj1->data.integer * pobj2->data.integer;
	erase_object(pobj1);
	erase_object(pobj2);
	return pretobj;
}

Object* div_f(Object* args, HDef* defs)
{
	Object* pobj1;
	Object* pobj2;
	Object* pretobj;

	if (n_args(args)!=2) {
		error(SEARGSDI, EARGS);
		return NULL;
	}
	
	pobj1=eval(car(args), defs);
	pobj2=eval(car(cdr(args)), defs);
	
	if (pobj1->type!=INTEGER || pobj2->type!=INTEGER) {
		error(SEDITYPE, ETYPE);
		return NULL;
	}
	
	if (pobj2->data.integer==0) {
		error(SEDIZERO, EDIV);
		return NULL;
	}

	pretobj=create_object(INTEGER);
	pretobj->data.integer=pobj1->data.integer / pobj2->data.integer;
	erase_object(pobj1);
	erase_object(pobj2);
	return pretobj;
}

Object* spy_f(Object* args, HDef* defs)
{
	Object* pobj; 

	if (n_args(args)!=1) {
		error(SESPARGS, EARGS);
		return NULL;
	}
	
	pobj=eval(car(args), defs);

#ifdef PRINTSPY
	printf("spy: ");
#endif
	print_object(pobj), printf("\n");
	
	return pobj;
}

/*
 * Defs functions
 */

void add_def_arg(Object* object, Object* name, HDef* calldefs, HDef* defs)
{
	Object* pobj=create_object(CONS);
	Def* newdef=create_def();

	pobj->data.cons.car=name;
	pobj->data.cons.cdr=eval(object, calldefs);

	newdef->object=pobj;
	add_to_hash(newdef, defs);
}
	
void add_def(Object* object, HDef* defs)
{
	Object* pobj=create_object(CONS);
	Def* newdef=create_def();

	if (cdr(object)->type!=CONS || cdr(cdr(object))->type!=NIL) {
		error(SEDEFSYNT, ESYNTAX);
	}

	pobj->data.cons.car=car(object);
	pobj->data.cons.cdr=eval(car(cdr(object)), defs);

	newdef->object=pobj;

	/*if (pobj->data.cons.cdr->type==LAMBDA) {		//add def for recursion
		Def* rekurdef=create_def();
		rekurdef->object=create_object(CONS);
		rekurdef->object->data.cons.car=car(object);  //name
		rekurdef->object->data.cons.cdr=create_object_o(cdr(pobj));
		add_to_hash(rekurdef, pobj->data.cons.cdr->data.lambda.defs);  //lambda has defs always allocated
	}*/
	add_to_hash(newdef, defs);
}

Object* find_object(char* name_pos, HDef* defs)
{
	Def* def;

	if (defs==NULL) {
		return NULL;
	}

	def=find_in_hash(name_pos, defs);
	if (def==NULL) {
		return NULL;
	}
	else {
		return create_object_o(cdr(def->object));
	}
}

void create_defs_from(HDef* source, HDef* destination)
{

	join_hash(source, destination);	
}

Def* create_def(void) 
{
	Def* pdef=(Def*) malloc(sizeof(struct sdef));
	if (!pdef)
		error(SEMEM, EMEM);
	return pdef;
}

HDef* create_defs(void)
{
	return create_hash();
}

void free_defs(HDef* defs)
{
	free_hash(defs);
}


/*
 * Object & list functions
 */


Object* create_object(Holding type) 
{
	Object* objectp=(Object*) malloc(sizeof(struct sobject));
	if (!objectp)
		error(SEMEM, EMEM);
	objectp->type=type;
	return objectp;
}

Object* create_object_o(Object* old) 
{
	Object* objectp=(Object*) malloc(sizeof(struct sobject));
	if (!objectp)
		error(SEMEM, EMEM);
	*objectp=*old;		//copy simple items
	switch (old->type) {
	case CONS:
		objectp->data.cons.car=create_object_o(old->data.cons.car);
		objectp->data.cons.cdr=create_object_o(old->data.cons.cdr);
		break;
	case LAMBDA:
		objectp->data.lambda.defs=create_defs();
		create_defs_from(old->data.lambda.defs, objectp->data.lambda.defs);
		break;
	}
	return objectp;
}

void erase_object(Object* object)
{
	switch(object->type) {
	case LAMBDA:
		free_defs(object->data.lambda.defs);
		free(object);
		break;
	case CONS:
		erase_object(object->data.cons.car);
		erase_object(object->data.cons.cdr);
		free(object);
		break;
	case INTEGER:
	case STRING:
	case NIL:
		free(object);
		break;
	case DEF:			//These should be never deallocated
	case BIF:
	case CODE:
		break;
	}
	object=NULL;
}

Object* car(Object* object)
{
	if (object->type!=CONS) {
		error(SEDCONS, EDEBUG);
		return NULL;
	}
	return object->data.cons.car;
}

Object* cdr(Object* object)
{
	if (object->type!=CONS) {
		error(SEDCONS, EDEBUG);
		return NULL;
	}
	return object->data.cons.cdr;
}

int n_args(Object* object)
{
	int i=0;
	if (object->type!=CONS) {
		return 0;
	}
	
	while (object->type!=NIL) {
		object=cdr(object);
		i++;
	}
	return i;
}

/*
 * Hash functions
 */

HDef* create_hash()
{
	int i;
	HDef* hash = (HDef*) malloc(sizeof(HDef));
	for(i=0; i<HSIZE; i++) {
		(*hash)[i]=NULL;
	}
	return hash;
}

void free_def(Def* def)
{
	erase_object(def->object->data.cons.cdr);	//value
	free(def->object);
	free(def);
}

void free_hash(HDef* hash)
{
	int i;
	Def* pnextdef;
	Def* pdef;
	
	for(i=0; i<HSIZE; i++) {
		pdef=(*hash)[i];
		while(pdef!=NULL) {
			pnextdef=pdef->next;
			free_def(pdef);		//!
			pdef=pnextdef;
		}
	}
	free(hash);
}

void join_hash(HDef* source, HDef* destination)
{
	int i;
	Def* pdef;
	Def* newdef;

	for(i=0; i<HSIZE; i++) {
		pdef=(*source)[i];
		while(pdef!=NULL) {
			newdef=create_def();
			newdef->object=create_object(CONS);
			newdef->object->data.cons.car=pdef->object->data.cons.car;   //!
			newdef->object->data.cons.cdr=create_object_o(pdef->object->data.cons.cdr);
			add_to_hash(newdef, destination);
			pdef=pdef->next;
		}
	}
}

void add_to_hash(Def* pdef, HDef* phash)
{
	Def* phdef;
	Def* phprevdef=NULL;
	char* name;
	int cmp=FALSE, i;

	if (pdef->object->type!=CONS && car(pdef->object)->type!=CODE) {
		error(SEDHASH, EDEBUG);
	}
	
	name=car(pdef->object)->data.code;
	i=hash_func(name);

	phdef=(*phash)[i];

	while(phdef!=NULL && (cmp=strpcmp(car(phdef->object)->data.code, name))==FALSE) {
		phprevdef=phdef;
		phdef=phdef->next;
	}

	if (phdef==NULL && phprevdef==NULL) {
		(*phash)[i]=pdef;
		pdef->next=NULL;
		return;
	}
	
	if (cmp==TRUE) {
		erase_object(phdef->object);	//!
		phdef->object=pdef->object;		//TODO: Substitute defs??

		return;
	}
	
	// phprevdef!=NULL && cmp==FALSE && phdef==NULL -> add new def

	phprevdef->next=pdef;
	pdef->next=NULL;
}

int hash_func(char* name)
{
	if (!isidentifier(name[1])) {
		return name[0] % HSIZE;
	} 
	else {
		return (name[0]*27+name[1]) % HSIZE;   //the name[1] is at least \0
	}
}

Def* find_in_hash(char* name, HDef* phash)
{
	Def* phdef;
	int cmp=FALSE, i=hash_func(name);

	phdef=(*phash)[i];

	while(phdef!=NULL && (cmp=strpcmp(car(phdef->object)->data.code, name))==FALSE) {
		phdef=phdef->next;
	}

	return (cmp==FALSE) ? NULL : phdef;
}


/* 
 * String functions
 */

char* get_first_item(char* code)
{
	while (isspace(*code)) 
		code++;
	if (!code) {
		error(SEUEOF, EEOF);
		return NULL;
	}
	return code;
}

char* get_next_item(char* code)
{
	int lvl=0;

	if (code==NULL)
		return NULL;
	
	if (*code==AP) 
		code++;

	if (*code==QU) {
		code++;
		while (*code!=QU && *code!=0)
			code++;
	}
	else
	if (*code!=LP) {
		while (isidentifier(*code))
			code++;
		code--;
	}
	else {
		lvl++, code++;
		while (*code && lvl>0) {
			switch (*code) {
				case LP:	lvl++; break;
				case RP:	lvl--; break;
			}
			code++;
		}
		code--;
	}
	
	if (*code) {
		code++;
		code=get_first_item(code);
		if (code && (isidentifier(*code) || *code==LP))
			return code;
		else
			if (lvl>0)
				error(SEPEOF, EEOF);
			return NULL;
		}
	else 
		return NULL;
}

int strpcmp(char* where, char* what)
{
	if ((!isidentifier(*where)) || (!isidentifier(*what)))
		return FALSE;
	while(isidentifier(*where) && *where==*what) 
		where++, what++;
	return (isidentifier(*what) || isidentifier(*where)) ? FALSE : TRUE;
}

int isspace(char c)
{
	return (c==CR || c==LF || c==SP || c==TB);
}

int isidentifier(char c)
{
	return (c!= TB && c!=CR && c!=LF && c!=LP && c!=RP && c!=SP && c);
}

int isnumeric(char c)
{
	return (c=='0' || c=='1' || c=='2' || c=='3' || c=='4' ||
		    c=='5' || c=='6' || c=='7' || c=='8' || c=='9');
}


/* 
 * IO functions
 */

void printid(char* code)
{
	while (isidentifier(*code)) {
		printf("%c", *code);
		code++;
	}
}


void print_object(Object* object)
{
	if(object->type==CONS || object->type==NIL) {
		printf("(");
	}
	print_o(object);
}

void print_o(Object* object)
{

	switch (object->type) {
	case NIL: 
		printf(")");
		break;
	case INTEGER:
		printf("%d", object->data.integer);
		break;
	case STRING:
		char* s;
		s=object->data.string;
		s++;
		while ((*s)!=QU) {
			printf("%c", *s);
			s++;
		}
		break;
	case CONS:
		print_object(object->data.cons.car);
		if (cdr(object)->type!=CONS && cdr(object)->type!=NIL) {
			printf(".");
			print_o(cdr(object));
			printf(")");
		}
		else {
			if (cdr(object)->type!=NIL) printf(" ");
			print_o(cdr(object));
		}
		break;
	case LAMBDA:
		printf("![(lambda) func.\nparams: ");
		print_object(object->data.lambda.names);
		printf("\nbody: ");
		print_object(object->data.lambda.code);
		printf("]!\n");
		break;
	case BIF:
		printf("%s", object->data.bif.str);
		break;
	case DEF:
		printf("define");
		break;
	case CODE:
		//printf("id: ");
		printid(object->data.code);
		break;
	}
}

/* 
 * System functions
 */


void err_paste_id(char* errmsg, char* code)
{
	char* s;
	char* t;
	for(s=errmsg; *s!='\0'; s++);
	for(t=code; *t!=SP && *t!=CR && *t!=LF && *t!=RP && *t!='\0'; *s=*t, s++, t++);
	*s='\n';
	*(s+1)='\0';
}

void error(char* message, int retcode)
{ 
	printf(message); 
	if (global_position!=NULL) {
		printf("--> ");
		print_object(global_position);
		printf("\n");
	}
#ifdef WAINTENTER
	getchar();
#endif
	exit(retcode); 
}