/*
 * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
 * See the copyright notice in the ACK home directory, in the file "Copyright".
 */

#include "bem.h"

#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif


/* Here we find all routines dealing with pure EM code generation */

static int	emlabel=1;
label	err_goto_label;



genlabel()
{
	 return(emlabel++);
}



genemlabel()
{
	int l;

	l=genlabel();
	C_df_dlb((label)l);
	return(l);
}





int tronoff=0;
newemblock(nr)
int nr;
{
	C_df_ilb((label)currline->emlabel);
	C_lin((arith)nr);
	if ( tronoff || traceflag) {
		C_loc((arith)nr);
		C_cal("_trace");
		C_asp((arith)BEMINTSIZE);
	}
}





/* Handle data statements */
List	*datalist=0;
datastmt()
{
	List *l,*l1;
	extern long sys_filesize();

	/* NOSTRICT */ l= (List *) salloc(sizeof(List));
	l->linenr= currline->linenr;
        l->emlabel =  sys_filesize(datfname);
	if ( datalist==0) 
	{
		datalist=l;
	} else {
		l1= datalist;
		while (l1->nextlist) l1= l1->nextlist;
		l1->nextlist=l;
	}

}



datatable()
{
	List *l;
	int line=0;

	/* called at end to generate the data seek table */
	C_exa_dnam("_seektab");
	C_df_dnam("_seektab");       /* VRAAGTEKEN */
	l= datalist;
	while (l)
	{
		C_rom_cst((arith)(l->linenr));
		C_rom_cst((arith)(line++));
		l= l->nextlist;
	}
	C_rom_cst((arith)0);
	C_rom_cst((arith)0);
}



/* ERROR and exception handling */
exceptstmt(lab)
int lab;
{
	/* exceptions to subroutines are supported only */
	extern int gosubcnt;
	List	*l;

	C_loc((arith)gosubcnt);
	l= (List *) gosublabel();
	l->emlabel= gotolabel(lab);
	C_cal("_trpset");
	C_asp((arith)BEMINTSIZE);
}



errorstmt(exprtype)
int	exprtype;
{
	/* convert expression to a valid error number */
	/* obtain the message and print it */
	C_cal("error");
	C_asp((arith)typesize(exprtype));
}



/* BASIC IO */
openstmt(recsize)
int recsize;
{
	C_loc((arith)recsize);
	C_cal("_opnchn");
	C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
}



printstmt(exprtype)
int	exprtype;
{
	switch(exprtype)
	{
		case INTTYPE:
			C_cal("_prinum");
			C_asp((arith)typestring(INTTYPE));
			break;
		case FLOATTYPE:
		case DOUBLETYPE:
			C_cal("_prfnum");
			C_asp((arith)typestring(DOUBLETYPE));
			break;
		case STRINGTYPE:
			C_cal("_prstr");
			C_asp((arith)BEMPTRSIZE);
			break;
		case 0:	/* result of tab function etc */
			break;
		default:
			error("printstmt:unexpected");
	}
}



zone(i)
int i;
{
	if ( i) C_cal("_zone");
}



writestmt(exprtype,comma)
int	exprtype,comma;
{
	if ( comma) C_cal("_wrcomma");

	switch(exprtype)
	{
		case INTTYPE:
			C_cal("_wrint");
			break;
		case FLOATTYPE:
		case DOUBLETYPE:
			C_cal("_wrflt");
			break;
		case STRINGTYPE:
			C_cal("_wrstr");
			break;
		default:
			error("printstmt:unexpected");
	}
	C_asp((arith)BEMPTRSIZE);
}



restore(lab)
int lab;
{
	/* save this information too */

	C_loc((arith)0);
	C_cal("_setchan");
	C_asp((arith)BEMINTSIZE);
	C_loc((arith)lab);
	C_cal("_restore");
	C_asp((arith)BEMINTSIZE);
}



prompt(qst)
int qst;
{
	setchannel(-1);
	C_cal("_prstr");
	C_asp((arith)BEMPTRSIZE);
	if (qst) C_cal("_qstmark");
}



linestmt(type)
int type;
{
	if ( type!= STRINGTYPE)
		error("String variable expected");
	C_cal("_rdline");
	C_asp((arith)BEMPTRSIZE);
}



readelm(type)
int type;
{
	switch(type)
	{
		case INTTYPE:
			C_cal("_readint");
			break;
		case FLOATTYPE:
		case DOUBLETYPE:
			C_cal("_readflt");
			break;
		case STRINGTYPE:
			C_cal("_readstr");
			break;
		default:
			error("readelm:unexpected type");
	}
	C_asp((arith)BEMPTRSIZE);
}



/* Swap exchanges the variable values */
swapstmt(ltype,rtype)
int	ltype, rtype;
{
	if ( ltype!= rtype)
		error("Type mismatch");
	else
		switch(ltype)
		{
			case INTTYPE:
				C_cal("_intswap");
				break;
			case FLOATTYPE:
			case DOUBLETYPE:
				C_cal("_fltswap");
				break;
			case STRINGTYPE:
				C_cal("_strswap");
				break;
			default:
				error("swap:unexpected");
		}

	C_asp((arith)(2*BEMPTRSIZE));
}



/* input/output handling */
setchannel(val)
int val;
{	/* obtain file descroption */
	C_loc((arith)val);
	C_cal("_setchan");
	C_asp((arith)BEMINTSIZE);
}



/* The if-then-else statements */
ifstmt(type)
int type;
{
	/* This BASIC follows the True= -1 rule */
	int nr;

	nr= genlabel();
	if ( type == INTTYPE)
		C_zeq((label)nr);
	else	
		if ( type == FLOATTYPE || type == DOUBLETYPE )
		{
			C_lae_dnam("fltnull",(arith)0);
			C_loi((arith)BEMFLTSIZE);
			C_cmf((arith)BEMFLTSIZE);
			C_zeq((label)nr);
		}
		else error("Integer or Float expected");

	return(nr);
}



thenpart( elselab)
int elselab;
{
	int nr;

	nr=genlabel();
	C_bra((label)nr);
	C_df_ilb((label)elselab);
	return(nr);
}



elsepart(lab)int lab;
{
	C_df_ilb((label)lab);
}



/* generate code for the for-statement */
#define MAXFORDEPTH 20

struct FORSTRUCT{
	Symbol	*loopvar;	/* loop variable */
	int	initaddress;
	int	limitaddress;
	int	stepaddress;
	int	fortst;		/* variable limit test */
	int	forinc;		/* variable increment code */
	int	forout;		/* end of loop */
} fortable[MAXFORDEPTH];

int	forcnt= -1;



forinit(s)
Symbol *s;
{
	int type;
	struct FORSTRUCT *f;

	dcltype(s);
	type= s->symtype;
	forcnt++;
	if ( (type!=INTTYPE && type!=FLOATTYPE && type!=DOUBLETYPE) ||
	    s->dimensions)
		error("Illegal loop variable");
	if ( forcnt >=MAXFORDEPTH)
		error("too many for statements");
	else {
		f=fortable+forcnt; 
		f->loopvar=s;
		f->fortst=genlabel();
		f->forinc=genlabel();
		f->forout=genlabel();
		/* generate space for temporary objects */
		f->initaddress= dclspace(type);
		f->limitaddress= dclspace(type);
		f->stepaddress= dclspace(type);
	}
}



forexpr(type)
int type;
{
	/* save start value of loop variable in a save place*/
	/* to avoid clashing with final value and step expression */
	int result;

	result= fortable[forcnt].loopvar->symtype;
	conversion(type,result);
	storevar(fortable[forcnt].initaddress, result);
}



forlimit(type)
int type;
{
	/* save the limit value too*/
	int result;

	result= fortable[forcnt].loopvar->symtype;
	conversion(type,result);
	storevar(fortable[forcnt].limitaddress, result);
}



forskipped(f)
struct FORSTRUCT *f;
{
	int type;

	type= f->loopvar->symtype;
	/* evaluate lower bound times sign of step */
	C_lae_dlb((label)f->initaddress,(arith)0);
	loadvar(type);
	conversion(type,DOUBLETYPE);
	C_lae_dlb((label)f->stepaddress,(arith)0);
	loadvar(type);
	conversion(type,DOUBLETYPE);
	C_cal("_forsgn");
	C_asp((arith)BEMFLTSIZE);
	C_lfr((arith)BEMINTSIZE);
	conversion(INTTYPE,DOUBLETYPE);
	C_mlf((arith)BEMFLTSIZE);
	/* evaluate higher bound times sign of step */
	C_lae_dlb((label)f->limitaddress,(arith)0);
	loadvar(type);
	conversion(type,DOUBLETYPE);
	C_lae_dlb((label)f->stepaddress,(arith)0);
	loadvar(type);
	conversion(type,DOUBLETYPE);
	C_cal("_forsgn");
	C_asp((arith)BEMFLTSIZE);
	C_lfr((arith)BEMINTSIZE);
	conversion(INTTYPE,DOUBLETYPE);
	C_mlf((arith)BEMFLTSIZE);
	/* skip condition */
	C_cmf((arith)BEMFLTSIZE);
	C_zgt((label)f->forout);
}



forstep(type)
int type;
{
	int result;
	int varaddress;
	struct FORSTRUCT *f;

	f= fortable+forcnt;
	result= f->loopvar->symtype;
	varaddress= f->loopvar->symalias;
	conversion(type,result);
	storevar(f->stepaddress, result);
	/* all information available, generate for-loop head */
	/* test for ingoring loop */
	forskipped(f);
	/* set initial value */
	C_lae_dlb((label)f->initaddress,(arith)0);
	loadvar(result);
	C_lae_dlb((label)varaddress,(arith)0);
	C_sti((arith)typestring(result));
	C_bra((label)f->fortst);
	/* increment loop variable */
	C_df_ilb((label)f->forinc);
	C_lae_dlb((label)varaddress,(arith)0);
	loadvar(result);
	C_lae_dlb((label)f->stepaddress,(arith)0);
	loadvar(result);
	if (result == INTTYPE)
		C_adi((arith)BEMINTSIZE);
	else	C_adf((arith)BEMFLTSIZE);
	C_lae_dlb((label)varaddress,(arith)0);
	C_sti((arith)typestring(result));
	/* test boundary */
	C_df_ilb((label)f->fortst);
	C_lae_dlb((label)varaddress,(arith)0);
	loadvar(result);
        /* Start of NEW code */
	C_lae_dlb((label)f->stepaddress,(arith)0); 
	loadvar(result);                           
	conversion(result,DOUBLETYPE);            
	C_cal("_forsgn");                           
	C_asp((arith)BEMFLTSIZE);               
	C_lfr((arith)BEMINTSIZE);              
	conversion(INTTYPE,result);           
	if ( result == INTTYPE )
		C_mli((arith)BEMINTSIZE);
	else	C_mlf((arith)BEMFLTSIZE);    
        /* End of NEW code */
	C_lae_dlb((label)f->limitaddress,(arith)0);
	loadvar(result);
        /* Start NEW code */
	C_lae_dlb((label)f->stepaddress,(arith)0); 
	loadvar(result);                    
	conversion(result,DOUBLETYPE);     
	C_cal("_forsgn");                    
	C_asp((arith)BEMFLTSIZE);        
	C_lfr((arith)BEMINTSIZE);       
	conversion(INTTYPE,result);    
	if ( result == INTTYPE )
		C_mli((arith)BEMINTSIZE);
	else	C_mlf((arith)BEMFLTSIZE);
        /* End NEW code */
	if (result == INTTYPE)
		C_cmi((arith)BEMINTSIZE);
	else	C_cmf((arith)BEMFLTSIZE);
	C_zgt((label)f->forout);
}



nextstmt(s)
Symbol *s;
{
	if (forcnt>MAXFORDEPTH || forcnt<0 || 
	    (s && s!= fortable[forcnt].loopvar))
		error("NEXT without FOR");
	else {
		/* address of variable is on top of stack ! */
		C_bra((label)fortable[forcnt].forinc);
		C_df_ilb((label)fortable[forcnt].forout);
		forcnt--;
	}
}



pokestmt(type1,type2)
int	type1,type2;
{
	conversion(type1,INTTYPE);
	conversion(type2,INTTYPE);
	C_asp((arith)(2*BEMINTSIZE));
}



/* generate code for the while statement */
#define MAXDEPTH 20

int	whilecnt, whilelabels[MAXDEPTH][2]; /*0=head,1=out */

whilestart()
{
	whilecnt++;
	if ( whilecnt==MAXDEPTH)
		fatal("too many nestings");
	/* gendummy label in graph */
	newblock(-1);
	whilelabels[whilecnt][0]= currline->emlabel;
	whilelabels[whilecnt][1]= genlabel();
	C_df_ilb((label)whilelabels[whilecnt][0]);
}



whiletst(exprtype)
int exprtype;
{
	/* test expression type */
	conversion(exprtype,INTTYPE);
	C_zeq((label)whilelabels[whilecnt][1]);
}



wend()
{
	if ( whilecnt<1)
		error("not part of while statement");
	else {
		C_bra((label)whilelabels[whilecnt][0]);
		C_df_ilb((label)whilelabels[whilecnt][1]);
		whilecnt--;
	}
}



/* generate code for the final version */
prologcode()
{
	/* generate the EM prolog code */
	C_df_dnam("fltnull");
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	C_df_dnam("dummy2");
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	/* NEW variable we make */
	C_df_dnam("dummy3");
	C_bss_dnam((arith)BEMPTRSIZE,"dummy3",(arith)0,0);
	C_df_dnam("tronoff");
	C_con_cst((arith)0);
	C_df_dnam("dummy1");
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	C_con_cst((arith)0);
	C_con_cst((arith)0);
        C_exa_dnam("_iomode");
        C_df_dnam("_iomode");
        C_rom_scon("O",(arith)2); 
	C_exa_dnam("_errsym");
	C_df_dnam("_errsym");
	C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
	C_exa_dnam("_erlsym");
	C_df_dnam("_erlsym");
	C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
}



prolog2()
{
	int result;
	label l = genlabel(), l2;

	err_goto_label = genlabel();
	C_exp("main");
	C_pro("main",(arith)0);
	C_ms_par((arith)0);
	/* Trap handling */
	C_cal("_ini_trp");

	l2 = genemlabel();
	C_rom_ilb(l);
	C_lae_dlb(l2, (arith) 0);
	C_loi((arith) BEMPTRSIZE);
	C_exa_dnam("trpbuf");
	C_lae_dnam("trpbuf",(arith)0);
	C_cal("setjmp");
	C_df_ilb(l);
	C_asp((arith)(BEMPTRSIZE+BEMPTRSIZE));
	C_lfr((arith)BEMINTSIZE);
	C_dup((arith)BEMINTSIZE);
	C_zeq((label)0);
	C_lae_dnam("returns",(arith)0);
	C_csa((arith)BEMINTSIZE);
	C_df_ilb((label)0);
	C_asp((arith)BEMINTSIZE);
	result= sys_open(datfname, OP_WRITE, &datfile);
	if ( result==0 ) fatal("improper file creation permission");
        gendata();
}



/* NEW */
gendata() 
{
	C_loc((arith)0);
	C_cal("_setchan");
	C_asp((arith)BEMINTSIZE);
	C_df_dnam("datfname");
	C_rom_scon(datfname,(arith)strlen(datfname) + 1);	/* EHB */
	C_df_dnam("dattyp");
	C_rom_scon("i\\0",(arith)4);
	C_df_dnam("datfdes");
	C_rom_dnam("datfname",(arith)0);
	C_rom_cst((arith)1);
	C_rom_cst((arith)(itoa(strlen(datfname))));
	C_df_dnam("dattdes");
	C_rom_dnam("dattyp",(arith)0);
	C_rom_cst((arith)1);
	C_rom_cst((arith)1);
	C_lae_dnam("dattdes",(arith)0);
	C_lae_dnam("datfdes",(arith)0);
	C_loc((arith)0);
	C_cal("_opnchn");
	C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
}



epilogcode()
{
	/* finalization code */
	int nr;
	nr= genlabel();
	C_bra((label)nr);
	genreturns();
	C_df_ilb((label)nr);
	datatable(); /* NEW */
	C_loc((arith)0);
	C_cal("_hlt");
	C_df_ilb(err_goto_label);
	C_cal("_goto_err");
	C_end((arith)0);
}