gencode.c 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705
  1. /*
  2. * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
  3. * See the copyright notice in the ACK home directory, in the file "Copyright".
  4. */
  5. #include "bem.h"
  6. #ifndef NORSCID
  7. static char rcs_id[] = "$Id$" ;
  8. #endif
  9. /* Here we find all routines dealing with pure EM code generation */
  10. static int emlabel=1;
  11. label err_goto_label;
  12. genlabel()
  13. {
  14. return(emlabel++);
  15. }
  16. genemlabel()
  17. {
  18. int l;
  19. l=genlabel();
  20. C_df_dlb((label)l);
  21. return(l);
  22. }
  23. int tronoff=0;
  24. newemblock(nr)
  25. int nr;
  26. {
  27. C_df_ilb((label)currline->emlabel);
  28. C_lin((arith)nr);
  29. if ( tronoff || traceflag) {
  30. C_loc((arith)nr);
  31. C_cal("_trace");
  32. C_asp((arith)BEMINTSIZE);
  33. }
  34. }
  35. /* Handle data statements */
  36. List *datalist=0;
  37. datastmt()
  38. {
  39. List *l,*l1;
  40. extern long sys_filesize();
  41. /* NOSTRICT */ l= (List *) salloc(sizeof(List));
  42. l->linenr= currline->linenr;
  43. l->emlabel = sys_filesize(datfname);
  44. if ( datalist==0)
  45. {
  46. datalist=l;
  47. } else {
  48. l1= datalist;
  49. while (l1->nextlist) l1= l1->nextlist;
  50. l1->nextlist=l;
  51. }
  52. }
  53. datatable()
  54. {
  55. List *l;
  56. int line=0;
  57. /* called at end to generate the data seek table */
  58. C_exa_dnam("_seektab");
  59. C_df_dnam("_seektab"); /* VRAAGTEKEN */
  60. l= datalist;
  61. while (l)
  62. {
  63. C_rom_cst((arith)(l->linenr));
  64. C_rom_cst((arith)(line++));
  65. l= l->nextlist;
  66. }
  67. C_rom_cst((arith)0);
  68. C_rom_cst((arith)0);
  69. }
  70. /* ERROR and exception handling */
  71. exceptstmt(lab)
  72. int lab;
  73. {
  74. /* exceptions to subroutines are supported only */
  75. extern int gosubcnt;
  76. List *l;
  77. C_loc((arith)gosubcnt);
  78. l= (List *) gosublabel();
  79. l->emlabel= gotolabel(lab);
  80. C_cal("_trpset");
  81. C_asp((arith)BEMINTSIZE);
  82. }
  83. errorstmt(exprtype)
  84. int exprtype;
  85. {
  86. /* convert expression to a valid error number */
  87. /* obtain the message and print it */
  88. C_cal("error");
  89. C_asp((arith)typesize(exprtype));
  90. }
  91. /* BASIC IO */
  92. openstmt(recsize)
  93. int recsize;
  94. {
  95. C_loc((arith)recsize);
  96. C_cal("_opnchn");
  97. C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
  98. }
  99. printstmt(exprtype)
  100. int exprtype;
  101. {
  102. switch(exprtype)
  103. {
  104. case INTTYPE:
  105. C_cal("_prinum");
  106. C_asp((arith)typestring(INTTYPE));
  107. break;
  108. case FLOATTYPE:
  109. case DOUBLETYPE:
  110. C_cal("_prfnum");
  111. C_asp((arith)typestring(DOUBLETYPE));
  112. break;
  113. case STRINGTYPE:
  114. C_cal("_prstr");
  115. C_asp((arith)BEMPTRSIZE);
  116. break;
  117. case 0: /* result of tab function etc */
  118. break;
  119. default:
  120. error("printstmt:unexpected");
  121. }
  122. }
  123. zone(i)
  124. int i;
  125. {
  126. if ( i) C_cal("_zone");
  127. }
  128. writestmt(exprtype,comma)
  129. int exprtype,comma;
  130. {
  131. if ( comma) C_cal("_wrcomma");
  132. switch(exprtype)
  133. {
  134. case INTTYPE:
  135. C_cal("_wrint");
  136. break;
  137. case FLOATTYPE:
  138. case DOUBLETYPE:
  139. C_cal("_wrflt");
  140. break;
  141. case STRINGTYPE:
  142. C_cal("_wrstr");
  143. break;
  144. default:
  145. error("printstmt:unexpected");
  146. }
  147. C_asp((arith)BEMPTRSIZE);
  148. }
  149. restore(lab)
  150. int lab;
  151. {
  152. /* save this information too */
  153. C_loc((arith)0);
  154. C_cal("_setchan");
  155. C_asp((arith)BEMINTSIZE);
  156. C_loc((arith)lab);
  157. C_cal("_restore");
  158. C_asp((arith)BEMINTSIZE);
  159. }
  160. prompt(qst)
  161. int qst;
  162. {
  163. setchannel(-1);
  164. C_cal("_prstr");
  165. C_asp((arith)BEMPTRSIZE);
  166. if (qst) C_cal("_qstmark");
  167. }
  168. linestmt(type)
  169. int type;
  170. {
  171. if ( type!= STRINGTYPE)
  172. error("String variable expected");
  173. C_cal("_rdline");
  174. C_asp((arith)BEMPTRSIZE);
  175. }
  176. readelm(type)
  177. int type;
  178. {
  179. switch(type)
  180. {
  181. case INTTYPE:
  182. C_cal("_readint");
  183. break;
  184. case FLOATTYPE:
  185. case DOUBLETYPE:
  186. C_cal("_readflt");
  187. break;
  188. case STRINGTYPE:
  189. C_cal("_readstr");
  190. break;
  191. default:
  192. error("readelm:unexpected type");
  193. }
  194. C_asp((arith)BEMPTRSIZE);
  195. }
  196. /* Swap exchanges the variable values */
  197. swapstmt(ltype,rtype)
  198. int ltype, rtype;
  199. {
  200. if ( ltype!= rtype)
  201. error("Type mismatch");
  202. else
  203. switch(ltype)
  204. {
  205. case INTTYPE:
  206. C_cal("_intswap");
  207. break;
  208. case FLOATTYPE:
  209. case DOUBLETYPE:
  210. C_cal("_fltswap");
  211. break;
  212. case STRINGTYPE:
  213. C_cal("_strswap");
  214. break;
  215. default:
  216. error("swap:unexpected");
  217. }
  218. C_asp((arith)(2*BEMPTRSIZE));
  219. }
  220. /* input/output handling */
  221. setchannel(val)
  222. int val;
  223. { /* obtain file descroption */
  224. C_loc((arith)val);
  225. C_cal("_setchan");
  226. C_asp((arith)BEMINTSIZE);
  227. }
  228. /* The if-then-else statements */
  229. ifstmt(type)
  230. int type;
  231. {
  232. /* This BASIC follows the True= -1 rule */
  233. int nr;
  234. nr= genlabel();
  235. if ( type == INTTYPE)
  236. C_zeq((label)nr);
  237. else
  238. if ( type == FLOATTYPE || type == DOUBLETYPE )
  239. {
  240. C_lae_dnam("fltnull",(arith)0);
  241. C_loi((arith)BEMFLTSIZE);
  242. C_cmf((arith)BEMFLTSIZE);
  243. C_zeq((label)nr);
  244. }
  245. else error("Integer or Float expected");
  246. return(nr);
  247. }
  248. thenpart( elselab)
  249. int elselab;
  250. {
  251. int nr;
  252. nr=genlabel();
  253. C_bra((label)nr);
  254. C_df_ilb((label)elselab);
  255. return(nr);
  256. }
  257. elsepart(lab)int lab;
  258. {
  259. C_df_ilb((label)lab);
  260. }
  261. /* generate code for the for-statement */
  262. #define MAXFORDEPTH 20
  263. struct FORSTRUCT{
  264. Symbol *loopvar; /* loop variable */
  265. int initaddress;
  266. int limitaddress;
  267. int stepaddress;
  268. int fortst; /* variable limit test */
  269. int forinc; /* variable increment code */
  270. int forout; /* end of loop */
  271. } fortable[MAXFORDEPTH];
  272. int forcnt= -1;
  273. forinit(s)
  274. Symbol *s;
  275. {
  276. int type;
  277. struct FORSTRUCT *f;
  278. dcltype(s);
  279. type= s->symtype;
  280. forcnt++;
  281. if ( (type!=INTTYPE && type!=FLOATTYPE && type!=DOUBLETYPE) ||
  282. s->dimensions)
  283. error("Illegal loop variable");
  284. if ( forcnt >=MAXFORDEPTH)
  285. error("too many for statements");
  286. else {
  287. f=fortable+forcnt;
  288. f->loopvar=s;
  289. f->fortst=genlabel();
  290. f->forinc=genlabel();
  291. f->forout=genlabel();
  292. /* generate space for temporary objects */
  293. f->initaddress= dclspace(type);
  294. f->limitaddress= dclspace(type);
  295. f->stepaddress= dclspace(type);
  296. }
  297. }
  298. forexpr(type)
  299. int type;
  300. {
  301. /* save start value of loop variable in a save place*/
  302. /* to avoid clashing with final value and step expression */
  303. int result;
  304. result= fortable[forcnt].loopvar->symtype;
  305. conversion(type,result);
  306. storevar(fortable[forcnt].initaddress, result);
  307. }
  308. forlimit(type)
  309. int type;
  310. {
  311. /* save the limit value too*/
  312. int result;
  313. result= fortable[forcnt].loopvar->symtype;
  314. conversion(type,result);
  315. storevar(fortable[forcnt].limitaddress, result);
  316. }
  317. forskipped(f)
  318. struct FORSTRUCT *f;
  319. {
  320. int type;
  321. type= f->loopvar->symtype;
  322. /* evaluate lower bound times sign of step */
  323. C_lae_dlb((label)f->initaddress,(arith)0);
  324. loadvar(type);
  325. conversion(type,DOUBLETYPE);
  326. C_lae_dlb((label)f->stepaddress,(arith)0);
  327. loadvar(type);
  328. conversion(type,DOUBLETYPE);
  329. C_cal("_forsgn");
  330. C_asp((arith)BEMFLTSIZE);
  331. C_lfr((arith)BEMINTSIZE);
  332. conversion(INTTYPE,DOUBLETYPE);
  333. C_mlf((arith)BEMFLTSIZE);
  334. /* evaluate higher bound times sign of step */
  335. C_lae_dlb((label)f->limitaddress,(arith)0);
  336. loadvar(type);
  337. conversion(type,DOUBLETYPE);
  338. C_lae_dlb((label)f->stepaddress,(arith)0);
  339. loadvar(type);
  340. conversion(type,DOUBLETYPE);
  341. C_cal("_forsgn");
  342. C_asp((arith)BEMFLTSIZE);
  343. C_lfr((arith)BEMINTSIZE);
  344. conversion(INTTYPE,DOUBLETYPE);
  345. C_mlf((arith)BEMFLTSIZE);
  346. /* skip condition */
  347. C_cmf((arith)BEMFLTSIZE);
  348. C_zgt((label)f->forout);
  349. }
  350. forstep(type)
  351. int type;
  352. {
  353. int result;
  354. int varaddress;
  355. struct FORSTRUCT *f;
  356. f= fortable+forcnt;
  357. result= f->loopvar->symtype;
  358. varaddress= f->loopvar->symalias;
  359. conversion(type,result);
  360. storevar(f->stepaddress, result);
  361. /* all information available, generate for-loop head */
  362. /* test for ingoring loop */
  363. forskipped(f);
  364. /* set initial value */
  365. C_lae_dlb((label)f->initaddress,(arith)0);
  366. loadvar(result);
  367. C_lae_dlb((label)varaddress,(arith)0);
  368. C_sti((arith)typestring(result));
  369. C_bra((label)f->fortst);
  370. /* increment loop variable */
  371. C_df_ilb((label)f->forinc);
  372. C_lae_dlb((label)varaddress,(arith)0);
  373. loadvar(result);
  374. C_lae_dlb((label)f->stepaddress,(arith)0);
  375. loadvar(result);
  376. if (result == INTTYPE)
  377. C_adi((arith)BEMINTSIZE);
  378. else C_adf((arith)BEMFLTSIZE);
  379. C_lae_dlb((label)varaddress,(arith)0);
  380. C_sti((arith)typestring(result));
  381. /* test boundary */
  382. C_df_ilb((label)f->fortst);
  383. C_lae_dlb((label)varaddress,(arith)0);
  384. loadvar(result);
  385. /* Start of NEW code */
  386. C_lae_dlb((label)f->stepaddress,(arith)0);
  387. loadvar(result);
  388. conversion(result,DOUBLETYPE);
  389. C_cal("_forsgn");
  390. C_asp((arith)BEMFLTSIZE);
  391. C_lfr((arith)BEMINTSIZE);
  392. conversion(INTTYPE,result);
  393. if ( result == INTTYPE )
  394. C_mli((arith)BEMINTSIZE);
  395. else C_mlf((arith)BEMFLTSIZE);
  396. /* End of NEW code */
  397. C_lae_dlb((label)f->limitaddress,(arith)0);
  398. loadvar(result);
  399. /* Start NEW code */
  400. C_lae_dlb((label)f->stepaddress,(arith)0);
  401. loadvar(result);
  402. conversion(result,DOUBLETYPE);
  403. C_cal("_forsgn");
  404. C_asp((arith)BEMFLTSIZE);
  405. C_lfr((arith)BEMINTSIZE);
  406. conversion(INTTYPE,result);
  407. if ( result == INTTYPE )
  408. C_mli((arith)BEMINTSIZE);
  409. else C_mlf((arith)BEMFLTSIZE);
  410. /* End NEW code */
  411. if (result == INTTYPE)
  412. C_cmi((arith)BEMINTSIZE);
  413. else C_cmf((arith)BEMFLTSIZE);
  414. C_zgt((label)f->forout);
  415. }
  416. nextstmt(s)
  417. Symbol *s;
  418. {
  419. if (forcnt>MAXFORDEPTH || forcnt<0 ||
  420. (s && s!= fortable[forcnt].loopvar))
  421. error("NEXT without FOR");
  422. else {
  423. /* address of variable is on top of stack ! */
  424. C_bra((label)fortable[forcnt].forinc);
  425. C_df_ilb((label)fortable[forcnt].forout);
  426. forcnt--;
  427. }
  428. }
  429. pokestmt(type1,type2)
  430. int type1,type2;
  431. {
  432. conversion(type1,INTTYPE);
  433. conversion(type2,INTTYPE);
  434. C_asp((arith)(2*BEMINTSIZE));
  435. }
  436. /* generate code for the while statement */
  437. #define MAXDEPTH 20
  438. int whilecnt, whilelabels[MAXDEPTH][2]; /*0=head,1=out */
  439. whilestart()
  440. {
  441. whilecnt++;
  442. if ( whilecnt==MAXDEPTH)
  443. fatal("too many nestings");
  444. /* gendummy label in graph */
  445. newblock(-1);
  446. whilelabels[whilecnt][0]= currline->emlabel;
  447. whilelabels[whilecnt][1]= genlabel();
  448. C_df_ilb((label)whilelabels[whilecnt][0]);
  449. }
  450. whiletst(exprtype)
  451. int exprtype;
  452. {
  453. /* test expression type */
  454. conversion(exprtype,INTTYPE);
  455. C_zeq((label)whilelabels[whilecnt][1]);
  456. }
  457. wend()
  458. {
  459. if ( whilecnt<1)
  460. error("not part of while statement");
  461. else {
  462. C_bra((label)whilelabels[whilecnt][0]);
  463. C_df_ilb((label)whilelabels[whilecnt][1]);
  464. whilecnt--;
  465. }
  466. }
  467. /* generate code for the final version */
  468. prologcode()
  469. {
  470. /* generate the EM prolog code */
  471. C_df_dnam("fltnull");
  472. C_con_cst((arith)0);
  473. C_con_cst((arith)0);
  474. C_con_cst((arith)0);
  475. C_con_cst((arith)0);
  476. C_df_dnam("dummy2");
  477. C_con_cst((arith)0);
  478. C_con_cst((arith)0);
  479. C_con_cst((arith)0);
  480. C_con_cst((arith)0);
  481. /* NEW variable we make */
  482. C_df_dnam("dummy3");
  483. C_bss_dnam((arith)BEMPTRSIZE,"dummy3",(arith)0,0);
  484. C_df_dnam("tronoff");
  485. C_con_cst((arith)0);
  486. C_df_dnam("dummy1");
  487. C_con_cst((arith)0);
  488. C_con_cst((arith)0);
  489. C_con_cst((arith)0);
  490. C_con_cst((arith)0);
  491. C_exa_dnam("_iomode");
  492. C_df_dnam("_iomode");
  493. C_rom_scon("O",(arith)2);
  494. C_exa_dnam("_errsym");
  495. C_df_dnam("_errsym");
  496. C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
  497. C_exa_dnam("_erlsym");
  498. C_df_dnam("_erlsym");
  499. C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
  500. }
  501. prolog2()
  502. {
  503. int result;
  504. label l = genlabel(), l2;
  505. err_goto_label = genlabel();
  506. C_exp("main");
  507. C_pro("main",(arith)0);
  508. C_ms_par((arith)0);
  509. /* Trap handling */
  510. C_cal("_ini_trp");
  511. l2 = genemlabel();
  512. C_rom_ilb(l);
  513. C_lae_dlb(l2, (arith) 0);
  514. C_loi((arith) BEMPTRSIZE);
  515. C_exa_dnam("trpbuf");
  516. C_lae_dnam("trpbuf",(arith)0);
  517. C_cal("setjmp");
  518. C_df_ilb(l);
  519. C_asp((arith)(BEMPTRSIZE+BEMPTRSIZE));
  520. C_lfr((arith)BEMINTSIZE);
  521. C_dup((arith)BEMINTSIZE);
  522. C_zeq((label)0);
  523. C_lae_dnam("returns",(arith)0);
  524. C_csa((arith)BEMINTSIZE);
  525. C_df_ilb((label)0);
  526. C_asp((arith)BEMINTSIZE);
  527. result= sys_open(datfname, OP_WRITE, &datfile);
  528. if ( result==0 ) fatal("improper file creation permission");
  529. gendata();
  530. }
  531. /* NEW */
  532. gendata()
  533. {
  534. C_loc((arith)0);
  535. C_cal("_setchan");
  536. C_asp((arith)BEMINTSIZE);
  537. C_df_dnam("datfname");
  538. C_rom_scon(datfname,(arith)strlen(datfname) + 1); /* EHB */
  539. C_df_dnam("dattyp");
  540. C_rom_scon("i\\0",(arith)4);
  541. C_df_dnam("datfdes");
  542. C_rom_dnam("datfname",(arith)0);
  543. C_rom_cst((arith)1);
  544. C_rom_cst((arith)(itoa(strlen(datfname))));
  545. C_df_dnam("dattdes");
  546. C_rom_dnam("dattyp",(arith)0);
  547. C_rom_cst((arith)1);
  548. C_rom_cst((arith)1);
  549. C_lae_dnam("dattdes",(arith)0);
  550. C_lae_dnam("datfdes",(arith)0);
  551. C_loc((arith)0);
  552. C_cal("_opnchn");
  553. C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
  554. }
  555. epilogcode()
  556. {
  557. /* finalization code */
  558. int nr;
  559. nr= genlabel();
  560. C_bra((label)nr);
  561. genreturns();
  562. C_df_ilb((label)nr);
  563. datatable(); /* NEW */
  564. C_loc((arith)0);
  565. C_cal("_hlt");
  566. C_df_ilb(err_goto_label);
  567. C_cal("_goto_err");
  568. C_end((arith)0);
  569. }