code.c 24 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270
  1. /* C O D E G E N E R A T I O N R O U T I N E S */
  2. #include "debug.h"
  3. #include <assert.h>
  4. #include <em.h>
  5. #include <em_reg.h>
  6. #include <em_abs.h>
  7. #include "LLlex.h"
  8. #include "Lpars.h"
  9. #include "def.h"
  10. #include "desig.h"
  11. #include "f_info.h"
  12. #include "idf.h"
  13. #include "main.h"
  14. #include "misc.h"
  15. #include "node.h"
  16. #include "required.h"
  17. #include "scope.h"
  18. #include "type.h"
  19. int fp_used;
  20. CodeFil()
  21. {
  22. if ( !options['L'] )
  23. C_fil_dlb((label) 1, (arith) 0);
  24. }
  25. routine_label(df)
  26. register struct def * df;
  27. {
  28. df->prc_label = ++data_label;
  29. C_df_dlb(df->prc_label);
  30. C_rom_scon(df->df_idf->id_text, (arith)(strlen(df->df_idf->id_text) + 1));
  31. }
  32. RomString(nd)
  33. register struct node *nd;
  34. {
  35. C_df_dlb(++data_label);
  36. /* A string of the string_type is null-terminated. */
  37. if( nd->nd_type == string_type )
  38. C_rom_scon(nd->nd_STR, nd->nd_SLE + 1); /* with trailing '\0' */
  39. else
  40. C_rom_scon(nd->nd_STR, nd->nd_SLE); /* no trailing '\0' */
  41. nd->nd_SLA = data_label;
  42. }
  43. RomReal(nd)
  44. register struct node *nd;
  45. {
  46. C_df_dlb(++data_label);
  47. C_rom_fcon(nd->nd_REL, nd->nd_type->tp_size);
  48. nd->nd_RLA = nd->nd_RIV->r_lab = data_label;
  49. }
  50. BssVar()
  51. {
  52. /* generate bss segments for global variables */
  53. register struct def *df = GlobalScope->sc_def;
  54. while( df ) {
  55. if( df->df_kind == D_VARIABLE ) {
  56. C_df_dnam(df->var_name);
  57. /* ??? undefined value ??? */
  58. C_bss_cst(df->df_type->tp_size, (arith) 0, 0);
  59. }
  60. df = df->df_nextinscope;
  61. }
  62. }
  63. arith
  64. CodeGtoDescr(sc)
  65. register struct scope *sc;
  66. {
  67. /* Create code for goto descriptors
  68. */
  69. register struct node *lb = sc->sc_lablist;
  70. int first = 1;
  71. while( lb ) {
  72. if( lb->nd_def->lab_descr ) {
  73. if( first ) {
  74. /* create local for target SP */
  75. sc->sc_off = -WA(pointer_size - sc->sc_off);
  76. C_ms_gto();
  77. first = 0;
  78. }
  79. C_df_dlb(lb->nd_def->lab_descr);
  80. C_rom_ilb(lb->nd_def->lab_no);
  81. C_rom_cst(sc->sc_off);
  82. }
  83. lb = lb->nd_next;
  84. }
  85. if( !first )
  86. return sc->sc_off;
  87. else
  88. return (arith) 0;
  89. }
  90. arith
  91. CodeBeginBlock(df)
  92. register struct def *df;
  93. {
  94. /* Generate code at the beginning of the main program,
  95. procedure or function.
  96. */
  97. arith StackAdjustment = 0;
  98. arith offset = 0; /* offset to save StackPointer */
  99. TmpOpen(df->prc_vis->sc_scope);
  100. if ( df->df_kind == D_MODULE) /* nothing */ ;
  101. else if (df->df_kind == D_PROGRAM ) {
  102. C_exp("_m_a_i_n");
  103. C_pro_narg("_m_a_i_n");
  104. C_ms_par((arith) 0);
  105. offset = CodeGtoDescr(df->prc_vis->sc_scope);
  106. CodeFil();
  107. /* initialize external files */
  108. call_ini();
  109. /* ignore floating point underflow */
  110. C_lim();
  111. C_loc((arith) (1 << EFUNFL));
  112. C_ior(int_size);
  113. C_sim();
  114. }
  115. else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
  116. struct type *tp;
  117. register struct paramlist *param;
  118. C_pro_narg(df->prc_name);
  119. C_ms_par(df->df_type->prc_nbpar);
  120. offset = CodeGtoDescr(df->prc_vis->sc_scope);
  121. CodeFil();
  122. if( options['t'] ) {
  123. C_lae_dlb(df->prc_label,(arith)0);
  124. C_cal("procentry");
  125. C_asp(pointer_size);
  126. }
  127. /* prc_bool is the local variable that indicates if the
  128. * function result is assigned. This and can be disabled
  129. * with the -R option. The variable, however, is always
  130. * allocated and initialized.
  131. */
  132. if( df->prc_res ) {
  133. C_zer((arith) int_size);
  134. C_stl(df->prc_bool);
  135. }
  136. for( param = ParamList(df->df_type); param; param = param->next) {
  137. if( !IsVarParam(param) ) {
  138. tp = TypeOfParam(param);
  139. if( IsConformantArray(tp) ) {
  140. /* Here, we have to make a copy of the
  141. array. We must also remember how much
  142. room is reserved for copies, because
  143. we have to adjust the stack pointer
  144. before we return.
  145. */
  146. if( !StackAdjustment ) {
  147. /* First time we get here
  148. */
  149. StackAdjustment = NewInt(0);
  150. C_loc((arith) 0);
  151. C_stl(StackAdjustment);
  152. }
  153. /* Address of array */
  154. C_lol(param->par_def->var_off);
  155. /* First compute size of the array */
  156. C_lol(tp->arr_cfdescr + word_size);
  157. C_inc();
  158. /* gives number of elements */
  159. C_lol(tp->arr_cfdescr + 2 * word_size);
  160. /* size of elements */
  161. C_mli(word_size);
  162. C_loc(word_size - 1);
  163. C_adi(word_size);
  164. C_loc(word_size);
  165. C_dvi(word_size);
  166. /* size in words */
  167. C_loc(word_size);
  168. C_mli(word_size);
  169. /* size in bytes */
  170. C_dup(word_size);
  171. C_lol(StackAdjustment);
  172. C_adi(word_size);
  173. C_stl(StackAdjustment);
  174. /* remember stack adjustments */
  175. C_los(word_size); /* copy */
  176. C_lor((arith) 1);
  177. /* push new address of array
  178. ... downwards ... ???
  179. */
  180. C_stl(param->par_def->var_off);
  181. }
  182. }
  183. }
  184. }
  185. else {
  186. crash("(CodeBeginBlock)");
  187. /*NOTREACHED*/
  188. }
  189. if( offset ) {
  190. /* save SP for non-local jump */
  191. C_lor((arith) 1);
  192. C_stl(offset);
  193. }
  194. return StackAdjustment;
  195. }
  196. CodeEndBlock(df, StackAdjustment)
  197. register struct def *df;
  198. arith StackAdjustment;
  199. {
  200. if( df->df_kind == D_PROGRAM) {
  201. C_loc((arith) 0);
  202. C_cal("_hlt");
  203. }
  204. else if (df->df_kind & (D_PROCEDURE | D_FUNCTION)) {
  205. struct type *tp;
  206. if( StackAdjustment ) {
  207. /* remove copies of conformant arrays */
  208. C_lol(StackAdjustment);
  209. C_ass(word_size);
  210. FreeInt(StackAdjustment);
  211. }
  212. if( !options['n'] )
  213. RegisterMessages(df->prc_vis->sc_scope->sc_def);
  214. if( options['t'] ) {
  215. C_lae_dlb(df->prc_label,(arith)0);
  216. C_cal("procexit");
  217. C_asp(pointer_size);
  218. }
  219. if( tp = ResultType(df->df_type) ) {
  220. if( !options['R'] ) {
  221. C_lin((arith)LineNumber);
  222. C_lol(df->prc_bool);
  223. C_cal("_nfa");
  224. C_asp(word_size);
  225. }
  226. if( tp->tp_size == word_size )
  227. C_lol(-tp->tp_size);
  228. else if( tp->tp_size == 2 * word_size )
  229. C_ldl(-tp->tp_size);
  230. else {
  231. C_lal(-tp->tp_size);
  232. C_loi(tp->tp_size);
  233. }
  234. C_ret(tp->tp_size);
  235. }
  236. else
  237. C_ret((arith) 0);
  238. }
  239. else {
  240. crash("(CodeEndBlock)");
  241. /*NOTREACHED*/
  242. }
  243. C_end(- df->prc_vis->sc_scope->sc_off);
  244. TmpClose();
  245. }
  246. CodeExpr(nd, ds, true_label)
  247. register struct node *nd;
  248. register struct desig *ds;
  249. label true_label;
  250. {
  251. register struct type *tp = nd->nd_type;
  252. if( tp->tp_fund == T_REAL ) fp_used = 1;
  253. switch( nd->nd_class ) {
  254. case Value:
  255. switch( nd->nd_symb ) {
  256. case INTEGER:
  257. C_loc(nd->nd_INT);
  258. break;
  259. case REAL:
  260. C_lae_dlb(nd->nd_RLA, (arith) 0);
  261. C_loi(tp->tp_size);
  262. if( nd->nd_RSI )
  263. C_ngf(tp->tp_size);
  264. break;
  265. case STRING:
  266. if( tp->tp_fund == T_CHAR )
  267. C_loc(nd->nd_INT);
  268. else
  269. C_lae_dlb(nd->nd_SLA, (arith) 0);
  270. break;
  271. case NIL:
  272. C_zer(pointer_size);
  273. break;
  274. default:
  275. crash("(CodeExpr Value)");
  276. /*NOTREACHED*/
  277. }
  278. ds->dsg_kind = DSG_LOADED;
  279. break;
  280. case Uoper:
  281. CodeUoper(nd);
  282. ds->dsg_kind = DSG_LOADED;
  283. break;
  284. case Boper:
  285. CodeBoper(nd, true_label);
  286. ds->dsg_kind = DSG_LOADED;
  287. true_label = NO_LABEL;
  288. break;
  289. case Set: {
  290. register arith *st = nd->nd_set;
  291. register int i;
  292. ds->dsg_kind = DSG_LOADED;
  293. if( !st ) {
  294. C_zer(tp->tp_size);
  295. break;
  296. }
  297. for( i = tp->tp_size / word_size, st += i; i > 0; i--)
  298. C_loc(*--st);
  299. }
  300. break;
  301. case Xset:
  302. CodeSet(nd);
  303. ds->dsg_kind = DSG_LOADED;
  304. break;
  305. case Call:
  306. CodeCall(nd);
  307. ds->dsg_kind = DSG_LOADED;
  308. break;
  309. case NameOrCall: {
  310. /* actual procedure/function parameter */
  311. struct node *left = nd->nd_left;
  312. struct def *df = left->nd_def;
  313. if( df->df_kind & D_ROUTINE ) {
  314. int level = df->df_scope->sc_level;
  315. if( level <= 0 || (df->df_flags & D_EXTERNAL) )
  316. C_zer(pointer_size);
  317. else
  318. C_lxl((arith) (proclevel - level));
  319. C_lpi(df->prc_name);
  320. ds->dsg_kind = DSG_LOADED;
  321. break;
  322. }
  323. assert(df->df_kind == D_VARIABLE);
  324. assert(df->df_type->tp_fund & T_ROUTINE);
  325. CodeDesig(left, ds);
  326. break;
  327. }
  328. case Arrow:
  329. case Arrsel:
  330. case Def:
  331. case LinkDef:
  332. CodeDesig(nd, ds);
  333. break;
  334. case Cast: {
  335. /* convert integer to real */
  336. struct node *right = nd->nd_right;
  337. CodePExpr(right);
  338. Int2Real(right->nd_type->tp_size);
  339. ds->dsg_kind = DSG_LOADED;
  340. break;
  341. }
  342. case IntCoerc: {
  343. /* convert integer to long integer */
  344. struct node *right = nd->nd_right;
  345. CodePExpr(right);
  346. Int2Long();
  347. ds->dsg_kind = DSG_LOADED;
  348. break;
  349. }
  350. case IntReduc: {
  351. /* convert a long to an integer */
  352. struct node *right = nd->nd_right;
  353. CodePExpr(right);
  354. Long2Int();
  355. ds->dsg_kind = DSG_LOADED;
  356. break;
  357. }
  358. default:
  359. crash("(CodeExpr : bad node type)");
  360. /*NOTREACHED*/
  361. } /* switch class */
  362. if( true_label ) {
  363. /* Only for boolean expressions
  364. */
  365. CodeValue(ds, tp);
  366. C_zeq(true_label);
  367. }
  368. }
  369. CodeUoper(nd)
  370. register struct node *nd;
  371. {
  372. register struct type *tp = nd->nd_type;
  373. CodePExpr(nd->nd_right);
  374. switch( nd->nd_symb ) {
  375. case '-':
  376. assert(tp->tp_fund & T_NUMERIC);
  377. if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG )
  378. C_ngi(tp->tp_size);
  379. else
  380. C_ngf(tp->tp_size);
  381. break;
  382. case NOT:
  383. C_teq();
  384. break;
  385. case '(':
  386. break;
  387. default:
  388. crash("(CodeUoper)");
  389. /*NOTREACHED*/
  390. }
  391. }
  392. Operands(leftop, rightop)
  393. register struct node *leftop, *rightop;
  394. {
  395. CodePExpr(leftop);
  396. CodePExpr(rightop);
  397. }
  398. CodeBoper(expr, true_label)
  399. register struct node *expr; /* the expression tree itself */
  400. label true_label; /* label to jump to in logical exprs */
  401. {
  402. register struct node *leftop = expr->nd_left;
  403. register struct node *rightop = expr->nd_right;
  404. register struct type *tp = expr->nd_type;
  405. switch( expr->nd_symb ) {
  406. case '+':
  407. Operands(leftop, rightop);
  408. switch( tp->tp_fund ) {
  409. case T_INTEGER:
  410. case T_LONG:
  411. C_adi(tp->tp_size);
  412. break;
  413. case T_REAL:
  414. C_adf(tp->tp_size);
  415. break;
  416. case T_SET:
  417. C_ior(tp->tp_size);
  418. break;
  419. default:
  420. crash("(CodeBoper: bad type +)");
  421. }
  422. break;
  423. case '-':
  424. Operands(leftop, rightop);
  425. switch( tp->tp_fund ) {
  426. case T_INTEGER:
  427. case T_LONG:
  428. C_sbi(tp->tp_size);
  429. break;
  430. case T_REAL:
  431. C_sbf(tp->tp_size);
  432. break;
  433. case T_SET:
  434. C_com(tp->tp_size);
  435. C_and(tp->tp_size);
  436. break;
  437. default:
  438. crash("(CodeBoper: bad type -)");
  439. }
  440. break;
  441. case '*':
  442. Operands(leftop, rightop);
  443. switch( tp->tp_fund ) {
  444. case T_INTEGER:
  445. case T_LONG:
  446. C_mli(tp->tp_size);
  447. break;
  448. case T_REAL:
  449. C_mlf(tp->tp_size);
  450. break;
  451. case T_SET:
  452. C_and(tp->tp_size);
  453. break;
  454. default:
  455. crash("(CodeBoper: bad type *)");
  456. }
  457. break;
  458. case '/':
  459. Operands(leftop, rightop);
  460. if( tp->tp_fund == T_REAL )
  461. C_dvf(tp->tp_size);
  462. else
  463. crash("(CodeBoper: bad type /)");
  464. break;
  465. case DIV:
  466. Operands(leftop, rightop);
  467. if( tp->tp_fund == T_INTEGER || tp->tp_fund == T_LONG)
  468. C_dvi(tp->tp_size);
  469. else
  470. crash("(CodeBoper: bad type DIV)");
  471. break;
  472. case MOD:
  473. Operands(leftop, rightop);
  474. if( tp->tp_fund == T_INTEGER ) {
  475. C_cal("_mdi");
  476. C_asp(2 * tp->tp_size);
  477. C_lfr(tp->tp_size);
  478. }
  479. else if( tp->tp_fund == T_LONG) {
  480. C_cal("_mdil");
  481. C_asp(2 * tp->tp_size);
  482. C_lfr(tp->tp_size);
  483. }
  484. else
  485. crash("(CodeBoper: bad type MOD)");
  486. break;
  487. case '<':
  488. case LESSEQUAL:
  489. case '>':
  490. case GREATEREQUAL:
  491. case '=':
  492. case NOTEQUAL:
  493. CodePExpr(leftop);
  494. CodePExpr(rightop);
  495. tp = BaseType(rightop->nd_type);
  496. switch( tp->tp_fund ) {
  497. case T_INTEGER:
  498. case T_LONG:
  499. C_cmi(tp->tp_size);
  500. break;
  501. case T_REAL:
  502. C_cmf(tp->tp_size);
  503. break;
  504. case T_ENUMERATION:
  505. case T_CHAR:
  506. C_cmu(word_size);
  507. break;
  508. case T_POINTER:
  509. C_cmp();
  510. break;
  511. case T_SET:
  512. if( expr->nd_symb == GREATEREQUAL ) {
  513. /* A >= B is the same as A equals A + B
  514. */
  515. C_dup(2 * tp->tp_size);
  516. C_asp(tp->tp_size);
  517. C_ior(tp->tp_size);
  518. expr->nd_symb = '=';
  519. }
  520. else if( expr->nd_symb == LESSEQUAL ) {
  521. /* A <= B is the same as A - B = []
  522. */
  523. C_com(tp->tp_size);
  524. C_and(tp->tp_size);
  525. C_zer(tp->tp_size);
  526. expr->nd_symb = '=';
  527. }
  528. C_cms(tp->tp_size);
  529. break;
  530. case T_STRINGCONST:
  531. case T_ARRAY:
  532. C_loc((arith) IsString(tp));
  533. C_cal("_bcp");
  534. C_asp(2 * pointer_size + word_size);
  535. C_lfr(word_size);
  536. break;
  537. case T_STRING:
  538. C_cmp();
  539. break;
  540. default:
  541. crash("(CodeBoper : bad type COMPARE)");
  542. }
  543. truthvalue(expr->nd_symb);
  544. if( true_label != NO_LABEL )
  545. C_zeq(true_label);
  546. break;
  547. case IN:
  548. /* In this case, evaluate right hand side first! The INN
  549. instruction expects the bit number on top of the stack
  550. */
  551. CodePExpr(rightop);
  552. CodePExpr(leftop);
  553. if( rightop->nd_type == emptyset_type )
  554. C_and(rightop->nd_type->tp_size);
  555. else
  556. C_inn(rightop->nd_type->tp_size);
  557. if( true_label != NO_LABEL )
  558. C_zeq(true_label);
  559. break;
  560. case AND:
  561. case OR:
  562. Operands(leftop, rightop);
  563. if( expr->nd_symb == AND )
  564. C_and(tp->tp_size);
  565. else
  566. C_ior(tp->tp_size);
  567. if( true_label != NO_LABEL )
  568. C_zeq(true_label);
  569. break;
  570. default:
  571. crash("(CodeBoper Bad operator %s\n)",
  572. symbol2str(expr->nd_symb));
  573. }
  574. }
  575. /* truthvalue() serves as an auxiliary function of CodeBoper */
  576. truthvalue(relop)
  577. {
  578. switch( relop ) {
  579. case '<':
  580. C_tlt();
  581. break;
  582. case LESSEQUAL:
  583. C_tle();
  584. break;
  585. case '>':
  586. C_tgt();
  587. break;
  588. case GREATEREQUAL:
  589. C_tge();
  590. break;
  591. case '=':
  592. C_teq();
  593. break;
  594. case NOTEQUAL:
  595. C_tne();
  596. break;
  597. default:
  598. crash("(truthvalue)");
  599. /*NOTREACHED*/
  600. }
  601. }
  602. CodeSet(nd)
  603. register struct node *nd;
  604. {
  605. register struct type *tp = nd->nd_type;
  606. C_zer(tp->tp_size);
  607. nd = nd->nd_right;
  608. while( nd ) {
  609. assert(nd->nd_class == Link && nd->nd_symb == ',');
  610. CodeEl(nd->nd_left, tp);
  611. nd = nd->nd_right;
  612. }
  613. }
  614. CodeEl(nd, tp)
  615. register struct node *nd;
  616. register struct type *tp;
  617. {
  618. if( nd->nd_class == Link && nd->nd_symb == UPTO ) {
  619. Operands(nd->nd_left, nd->nd_right);
  620. C_loc(tp->tp_size); /* push size */
  621. C_cal("_bts"); /* library routine to fill set */
  622. C_asp(3 * word_size);
  623. }
  624. else {
  625. CodePExpr(nd);
  626. C_set(tp->tp_size);
  627. C_ior(tp->tp_size);
  628. }
  629. }
  630. struct type *
  631. CodeParameters(param, arg)
  632. struct paramlist *param;
  633. struct node *arg;
  634. {
  635. register struct type *tp, *left_tp, *last_tp = (struct type *) 0;
  636. struct node *left;
  637. struct desig ds;
  638. assert(param && arg);
  639. if( param->next )
  640. last_tp = CodeParameters(param->next, arg->nd_right);
  641. tp = TypeOfParam(param);
  642. left = arg->nd_left;
  643. left_tp = left->nd_type;
  644. if( IsConformantArray(tp) ) {
  645. if( last_tp != tp )
  646. /* push descriptors only once */
  647. CodeConfDescr(tp, left_tp);
  648. CodeDAddress(left);
  649. return tp;
  650. }
  651. if( IsVarParam(param) ) {
  652. CodeDAddress(left);
  653. return tp;
  654. }
  655. if( left_tp->tp_fund == T_STRINGCONST ) {
  656. CodePString(left, tp);
  657. return tp;
  658. }
  659. ds = InitDesig;
  660. CodeExpr(left, &ds, NO_LABEL);
  661. CodeValue(&ds, left_tp);
  662. RangeCheck(tp, left_tp);
  663. if( tp == real_type && BaseType(left_tp) == int_type )
  664. Int2Real(int_size);
  665. return tp;
  666. }
  667. CodeConfDescr(ftp, atp)
  668. register struct type *ftp, *atp;
  669. {
  670. struct type *elemtp = ftp->arr_elem;
  671. if( IsConformantArray(elemtp) )
  672. CodeConfDescr(elemtp, atp->arr_elem);
  673. if( atp->tp_fund == T_STRINGCONST ) {
  674. C_loc((arith) 1);
  675. C_loc(atp->tp_psize - 1);
  676. C_loc((arith) 1);
  677. }
  678. else if( IsConformantArray(atp) ) {
  679. if( atp->arr_sclevel < proclevel ) {
  680. C_lxa((arith) proclevel - atp->arr_sclevel);
  681. C_adp(atp->arr_cfdescr);
  682. }
  683. else
  684. C_lal(atp->arr_cfdescr);
  685. C_loi(3 * word_size);
  686. }
  687. else { /* normal array */
  688. assert(atp->tp_fund == T_ARRAY);
  689. assert(!IsConformantArray(atp));
  690. C_lae_dlb(atp->arr_ardescr, (arith) 0);
  691. C_loi( 3 * word_size);
  692. }
  693. }
  694. CodePString(nd, tp)
  695. struct node *nd;
  696. struct type *tp;
  697. {
  698. /* no null padding */
  699. C_lae_dlb(nd->nd_SLA, (arith) 0);
  700. C_loi(tp->tp_size);
  701. }
  702. CodeCall(nd)
  703. register struct node *nd;
  704. {
  705. /* Generate code for a procedure call. Checking of parameters
  706. and result is already done.
  707. */
  708. register struct node *left = nd->nd_left;
  709. register struct node *right = nd->nd_right;
  710. register struct def *df = left->nd_def;
  711. register struct type *result_tp;
  712. assert(IsProcCall(left));
  713. if( left->nd_type == std_type ) {
  714. CodeStd(nd);
  715. return;
  716. }
  717. if( right )
  718. (void) CodeParameters(ParamList(left->nd_type), right);
  719. assert(left->nd_class == Def);
  720. if( df->df_kind & D_ROUTINE ) {
  721. int level = df->df_scope->sc_level;
  722. if( level > 0 && !(df->df_flags & D_EXTERNAL) )
  723. C_lxl((arith) (proclevel - level));
  724. C_cal(df->prc_name);
  725. C_asp(left->nd_type->prc_nbpar);
  726. }
  727. else {
  728. label l1 = ++text_label;
  729. label l2 = ++text_label;
  730. assert(df->df_kind == D_VARIABLE);
  731. /* Push value of procedure/function parameter */
  732. CodePExpr(left);
  733. /* Test if value is a global or local procedure/function */
  734. C_exg(pointer_size);
  735. C_dup(pointer_size);
  736. C_zer(pointer_size);
  737. C_cmp();
  738. C_zeq(l1);
  739. /* At this point, on top of the stack the LB */
  740. C_exg(pointer_size);
  741. /* Now, the name of the procedure/function */
  742. C_cai();
  743. C_asp(pointer_size + left->nd_type->prc_nbpar);
  744. C_bra(l2);
  745. /* value is a global procedure/function */
  746. C_df_ilb(l1);
  747. C_asp(pointer_size); /* no LB needed */
  748. C_cai();
  749. C_asp(left->nd_type->prc_nbpar);
  750. C_df_ilb(l2);
  751. }
  752. if( result_tp = ResultType(left->nd_type) )
  753. C_lfr(result_tp->tp_size);
  754. }
  755. CodeStd(nd)
  756. struct node *nd;
  757. {
  758. register struct node *arg = nd->nd_right;
  759. register struct node *left = arg->nd_left;
  760. register struct type *tp = BaseType(left->nd_type);
  761. int req = nd->nd_left->nd_def->df_value.df_reqname;
  762. assert(arg->nd_class == Link && arg->nd_symb == ',');
  763. switch( req ) {
  764. case R_ABS:
  765. CodePExpr(left);
  766. if( tp == int_type )
  767. C_cal("_abi");
  768. else if ( tp == long_type )
  769. C_cal("_abl");
  770. else
  771. C_cal("_abr");
  772. C_asp(tp->tp_size);
  773. C_lfr(tp->tp_size);
  774. break;
  775. case R_SQR:
  776. CodePExpr(left);
  777. C_dup(tp->tp_size);
  778. if( tp == int_type || tp == long_type )
  779. C_mli(tp->tp_size);
  780. else
  781. C_mlf(real_size);
  782. break;
  783. case R_SIN:
  784. case R_COS:
  785. case R_EXP:
  786. case R_LN:
  787. case R_SQRT:
  788. case R_ARCTAN:
  789. assert(tp == real_type);
  790. CodePExpr(left);
  791. switch( req ) {
  792. case R_SIN:
  793. C_cal("_sin");
  794. break;
  795. case R_COS:
  796. C_cal("_cos");
  797. break;
  798. case R_EXP:
  799. C_cal("_exp");
  800. break;
  801. case R_LN:
  802. C_cal("_log");
  803. break;
  804. case R_SQRT:
  805. C_cal("_sqt");
  806. break;
  807. case R_ARCTAN:
  808. C_cal("_atn");
  809. break;
  810. default:
  811. crash("(CodeStd)");
  812. /*NOTREACHED*/
  813. }
  814. C_asp(real_size);
  815. C_lfr(real_size);
  816. break;
  817. case R_TRUNC:
  818. assert(tp == real_type);
  819. CodePExpr(left);
  820. Real2Int();
  821. break;
  822. case R_ROUND:
  823. assert(tp == real_type);
  824. CodePExpr(left);
  825. C_cal("_rnd");
  826. C_asp(real_size);
  827. C_lfr(real_size);
  828. Real2Int();
  829. break;
  830. case R_ORD:
  831. CodePExpr(left);
  832. break;
  833. case R_CHR:
  834. CodePExpr(left);
  835. genrck(char_type);
  836. break;
  837. case R_SUCC:
  838. case R_PRED:
  839. CodePExpr(left);
  840. C_loc((arith)1);
  841. if( tp == long_type) Int2Long();
  842. if( req == R_SUCC )
  843. C_adi(tp->tp_size);
  844. else
  845. C_sbi(tp->tp_size);
  846. if( bounded(left->nd_type) )
  847. genrck(left->nd_type);
  848. break;
  849. case R_ODD:
  850. CodePExpr(left);
  851. C_loc((arith) 1);
  852. if( tp == long_type ) Int2Long();
  853. C_and(tp->tp_size);
  854. if( tp == long_type ) Long2Int(); /* bool_size == int_size */
  855. break;
  856. case R_EOF:
  857. case R_EOLN:
  858. CodeDAddress(left);
  859. if( req == R_EOF )
  860. C_cal("_efl");
  861. else
  862. C_cal("_eln");
  863. C_asp(pointer_size);
  864. C_lfr(word_size);
  865. break;
  866. case R_REWRITE:
  867. case R_RESET:
  868. CodeDAddress(left);
  869. if( tp == text_type )
  870. C_loc((arith) 0);
  871. else
  872. C_loc(tp->next->tp_psize);
  873. /* ??? elements of packed size ??? */
  874. if( req == R_REWRITE )
  875. C_cal("_cre");
  876. else
  877. C_cal("_opn");
  878. C_asp(pointer_size + word_size);
  879. break;
  880. case R_PUT:
  881. case R_GET:
  882. CodeDAddress(left);
  883. if( req == R_PUT )
  884. C_cal("_put");
  885. else
  886. C_cal("_get");
  887. C_asp(pointer_size);
  888. break;
  889. case R_PAGE:
  890. CodeDAddress(left);
  891. C_cal("_pag");
  892. C_asp(pointer_size);
  893. break;
  894. case R_PACK: {
  895. label lba = tp->arr_ardescr;
  896. CodeDAddress(left);
  897. arg = arg->nd_right;
  898. left = arg->nd_left;
  899. CodePExpr(left);
  900. arg = arg->nd_right;
  901. left = arg->nd_left;
  902. CodeDAddress(left);
  903. C_lae_dlb(left->nd_type->arr_ardescr, (arith) 0);
  904. C_lae_dlb(lba, (arith) 0);
  905. C_cal("_pac");
  906. C_asp(4 * pointer_size + word_size);
  907. break;
  908. }
  909. case R_UNPACK: {
  910. /* change sequence of arguments of the library routine
  911. _unp to merge code of R_PACK and R_UNPACK.
  912. */
  913. label lba, lbz = tp->arr_ardescr;
  914. tp = tp->arr_elem;
  915. if (tp->tp_fund == T_SUBRANGE &&
  916. tp->sub_lb >= 0) {
  917. C_loc((arith) 1);
  918. }
  919. else C_loc((arith) 0);
  920. CodeDAddress(left);
  921. arg = arg->nd_right;
  922. left = arg->nd_left;
  923. CodeDAddress(left);
  924. lba = left->nd_type->arr_ardescr;
  925. arg = arg->nd_right;
  926. left = arg->nd_left;
  927. CodePExpr(left);
  928. C_lae_dlb(lbz, (arith) 0);
  929. C_lae_dlb(lba, (arith) 0);
  930. C_cal("_unp");
  931. C_asp(4 * pointer_size + 2 * word_size);
  932. break;
  933. }
  934. case R_NEW:
  935. case R_DISPOSE:
  936. CodeDAddress(left);
  937. C_loc(PointedtoType(tp)->tp_size);
  938. if( req == R_NEW )
  939. C_cal("_new");
  940. else
  941. C_cal("_dis");
  942. C_asp(pointer_size + word_size);
  943. break;
  944. case R_MARK:
  945. case R_RELEASE:
  946. CodeDAddress(left);
  947. if( req == R_MARK )
  948. C_cal("_sav");
  949. else
  950. C_cal("_rst");
  951. C_asp(pointer_size);
  952. break;
  953. case R_HALT:
  954. if( left )
  955. CodePExpr(left);
  956. else
  957. C_zer(int_size);
  958. C_cal("_hlt"); /* can't return */
  959. C_asp(int_size); /* help the optimizer(s) */
  960. break;
  961. default:
  962. crash("(CodeStd)");
  963. /*NOTREACHED*/
  964. }
  965. }
  966. Long2Int()
  967. {
  968. /* convert a long to integer */
  969. if (int_size == long_size) return;
  970. C_loc(long_size);
  971. C_loc(int_size);
  972. C_cii();
  973. }
  974. Int2Long()
  975. {
  976. /* convert integer to long */
  977. if (int_size == long_size) return;
  978. C_loc(int_size);
  979. C_loc(long_size);
  980. C_cii();
  981. }
  982. Int2Real(size) /* size is different for integers and longs */
  983. arith size;
  984. {
  985. /* convert integer to real */
  986. C_loc(size);
  987. C_loc(real_size);
  988. C_cif();
  989. }
  990. Real2Int()
  991. {
  992. /* convert real to integer */
  993. C_loc(real_size);
  994. C_loc(int_size);
  995. C_cfi();
  996. }
  997. RangeCheck(tpl, tpr)
  998. register struct type *tpl, *tpr;
  999. {
  1000. /* Generate a range check if neccessary
  1001. */
  1002. arith llo, lhi, rlo, rhi;
  1003. if( bounded(tpl) ) {
  1004. /* in this case we might need a range check */
  1005. if( !bounded(tpr) )
  1006. /* yes, we need one */
  1007. genrck(tpl);
  1008. else {
  1009. /* both types are restricted. check the bounds to see
  1010. whether we need a range check. We don't need one
  1011. if the range of values of the right hand side is a
  1012. subset of the range of values of the left hand side.
  1013. */
  1014. getbounds(tpl, &llo, &lhi);
  1015. getbounds(tpr, &rlo, &rhi);
  1016. if( llo > rlo || lhi < rhi )
  1017. genrck(tpl);
  1018. }
  1019. }
  1020. }
  1021. genrck(tp)
  1022. register struct type *tp;
  1023. {
  1024. /* Generate a range check descriptor for type "tp" when
  1025. necessary. Return its label.
  1026. */
  1027. arith lb, ub;
  1028. register label o1;
  1029. int newlabel = 0;
  1030. if( options['R'] ) return;
  1031. getbounds(tp, &lb, &ub);
  1032. if( tp->tp_fund == T_SUBRANGE ) {
  1033. if( !(o1 = tp->sub_rck) ) {
  1034. tp->sub_rck = o1 = ++data_label;
  1035. newlabel = 1;
  1036. }
  1037. }
  1038. else if( !(o1 = tp->enm_rck) ) {
  1039. tp->enm_rck = o1 = ++data_label;
  1040. newlabel = 1;
  1041. }
  1042. if( newlabel ) {
  1043. C_df_dlb(o1);
  1044. C_rom_cst(lb);
  1045. C_rom_cst(ub);
  1046. }
  1047. C_lae_dlb(o1, (arith) 0);
  1048. C_rck(word_size);
  1049. }
  1050. CodePExpr(nd)
  1051. register struct node *nd;
  1052. {
  1053. /* Generate code to push the value of the expression "nd"
  1054. on the stack.
  1055. */
  1056. struct desig designator;
  1057. struct type *tp = BaseType(nd->nd_type);
  1058. designator = InitDesig;
  1059. CodeExpr(nd, &designator, NO_LABEL);
  1060. if( tp->tp_fund & (T_ARRAY | T_RECORD) )
  1061. CodeAddress(&designator);
  1062. else
  1063. CodeValue(&designator, nd->nd_type);
  1064. }
  1065. CodeDAddress(nd)
  1066. struct node *nd;
  1067. {
  1068. /* Generate code to push the address of the designator "nd"
  1069. on the stack.
  1070. */
  1071. struct desig designator;
  1072. designator = InitDesig;
  1073. CodeDesig(nd, &designator);
  1074. CodeAddress(&designator);
  1075. }
  1076. CodeDStore(nd)
  1077. register struct node *nd;
  1078. {
  1079. /* Generate code to store the expression on the stack
  1080. into the designator "nd".
  1081. */
  1082. struct desig designator;
  1083. designator = InitDesig;
  1084. CodeDesig(nd, &designator);
  1085. CodeStore(&designator, nd->nd_type);
  1086. }
  1087. RegisterMessages(df)
  1088. register struct def *df;
  1089. {
  1090. register struct type *tp;
  1091. for( ; df; df = df->df_nextinscope ) {
  1092. if( df->df_kind == D_VARIABLE && !(df->df_flags & D_NOREG) ) {
  1093. /* Examine type and size
  1094. */
  1095. tp = BaseType(df->df_type);
  1096. if( df->df_flags & D_VARPAR || tp->tp_fund & T_POINTER )
  1097. C_ms_reg(df->var_off, pointer_size,
  1098. reg_pointer, 0);
  1099. else if( df->df_flags & D_LOOPVAR )
  1100. C_ms_reg(df->var_off, tp->tp_size, reg_loop,2);
  1101. else if( tp->tp_fund & T_NUMERIC )
  1102. C_ms_reg(df->var_off, tp->tp_size,
  1103. tp->tp_fund == T_REAL ? reg_float : reg_any, 0);
  1104. }
  1105. }
  1106. }