code.c 24 KB

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