705 lines
12 KiB
C
705 lines
12 KiB
C
/*
|
|
* (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;
|
|
|
|
/* 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);
|
|
}
|