gencode.c 12 KB

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