123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705 |
- /*
- * (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[] = "$Id$" ;
- #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);
- }
|