code.c 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254
  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. * Author: Ceriel J.H. Jacobs
  6. */
  7. /* C O D E G E N E R A T I O N R O U T I N E S */
  8. /* $Id$ */
  9. /* Code generation for expressions and coercions
  10. */
  11. #include "debug.h"
  12. #include <em_arith.h>
  13. #include <em_label.h>
  14. #include <em_code.h>
  15. #include <em_abs.h>
  16. #include <assert.h>
  17. #include <alloc.h>
  18. #include "type.h"
  19. #include "LLlex.h"
  20. #include "def.h"
  21. #include "scope.h"
  22. #include "desig.h"
  23. #include "node.h"
  24. #include "Lpars.h"
  25. #include "standards.h"
  26. #include "walk.h"
  27. #include "bigresult.h"
  28. extern int proclevel;
  29. extern char options[];
  30. extern t_desig null_desig;
  31. int fp_used;
  32. CodeConst(cst, size)
  33. arith cst;
  34. int size;
  35. {
  36. /* Generate code to push constant "cst" with size "size"
  37. */
  38. if (size <= (int) word_size) {
  39. C_loc(cst);
  40. }
  41. else if (size == (int) dword_size) {
  42. C_ldc(cst);
  43. }
  44. else {
  45. crash("(CodeConst)");
  46. }
  47. }
  48. CodeString(nd)
  49. register t_node *nd;
  50. {
  51. if (nd->nd_type->tp_fund != T_STRING) {
  52. /* Character constant */
  53. CodeConst(nd->nd_INT, nd->nd_type->tp_size);
  54. return;
  55. }
  56. C_df_dlb(++data_label);
  57. C_rom_scon(nd->nd_STR, WA((arith)(nd->nd_SLE + 1)));
  58. c_lae_dlb(data_label);
  59. }
  60. CodeExpr(nd, ds, true_label, false_label)
  61. register t_node *nd;
  62. register t_desig *ds;
  63. label true_label, false_label;
  64. {
  65. register t_type *tp = nd->nd_type;
  66. DoLineno(nd);
  67. if (tp->tp_fund == T_REAL) fp_used = 1;
  68. switch(nd->nd_class) {
  69. case Def:
  70. if (nd->nd_def->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
  71. C_lpi(nd->nd_def->prc_name);
  72. ds->dsg_kind = DSG_LOADED;
  73. break;
  74. }
  75. /* Fall through */
  76. case Link:
  77. case Arrsel:
  78. case Arrow:
  79. CodeDesig(nd, ds);
  80. break;
  81. case Oper:
  82. CodeOper(nd, true_label, false_label);
  83. ds->dsg_kind = DSG_LOADED;
  84. true_label = NO_LABEL;
  85. break;
  86. case Uoper:
  87. CodeUoper(nd);
  88. ds->dsg_kind = DSG_LOADED;
  89. break;
  90. case Value:
  91. switch(nd->nd_symb) {
  92. case REAL:
  93. C_df_dlb(++data_label);
  94. if (! nd->nd_RSTR) {
  95. static char buf[FLT_STRLEN];
  96. flt_flt2str(&nd->nd_RVAL, buf, FLT_STRLEN);
  97. C_rom_fcon(buf, tp->tp_size);
  98. }
  99. else C_rom_fcon(nd->nd_RSTR, tp->tp_size);
  100. c_lae_dlb(data_label);
  101. C_loi(tp->tp_size);
  102. break;
  103. case STRING:
  104. CodeString(nd);
  105. break;
  106. case INTEGER:
  107. CodeConst(nd->nd_INT, (int) (tp->tp_size));
  108. break;
  109. default:
  110. crash("Value error");
  111. }
  112. ds->dsg_kind = DSG_LOADED;
  113. break;
  114. case Call:
  115. CodeCall(nd);
  116. ds->dsg_kind = DSG_LOADED;
  117. break;
  118. case Set: {
  119. register unsigned i = (unsigned) (tp->tp_size) / (int) word_size;
  120. register arith *st = nd->nd_set + i;
  121. int null_set = 1;
  122. ds->dsg_kind = DSG_LOADED;
  123. for (; i; i--) {
  124. if (*--st != 0) null_set = 0;
  125. }
  126. if (! null_set) {
  127. i = (unsigned) (tp->tp_size) / (int) word_size;
  128. st = nd->nd_set + i;
  129. for (; i; i--) {
  130. C_loc(*--st);
  131. }
  132. }
  133. FreeSet(nd->nd_set);
  134. CodeSet(nd, null_set);
  135. }
  136. break;
  137. default:
  138. crash("(CodeExpr) bad node type");
  139. }
  140. if (true_label != NO_LABEL) {
  141. /* Only for boolean expressions
  142. */
  143. CodeValue(ds, tp);
  144. C_zne(true_label);
  145. c_bra(false_label);
  146. }
  147. }
  148. CodeCoercion(t1, t2)
  149. t_type *t1, *t2;
  150. {
  151. int fund1, fund2;
  152. int sz1 = t1->tp_size;
  153. int sz2;
  154. t1 = BaseType(t1);
  155. t2 = BaseType(t2);
  156. sz2 = t2->tp_size;
  157. switch(fund1 = t1->tp_fund) {
  158. case T_WORD:
  159. fund1 = T_INTEGER;
  160. break;
  161. case T_CHAR:
  162. case T_ENUMERATION:
  163. case T_CARDINAL:
  164. case T_INTORCARD:
  165. if (sz1 < (int) word_size) sz1 = word_size;
  166. /* fall through */
  167. case T_EQUAL:
  168. case T_POINTER:
  169. fund1 = T_CARDINAL;
  170. break;
  171. }
  172. switch(fund2 = t2->tp_fund) {
  173. case T_WORD:
  174. fund2 = T_INTEGER;
  175. break;
  176. case T_CHAR:
  177. case T_ENUMERATION:
  178. sz2 = word_size;
  179. /* fall through */
  180. case T_EQUAL:
  181. case T_POINTER:
  182. fund2 = T_CARDINAL;
  183. break;
  184. }
  185. switch(fund1) {
  186. case T_INTEGER:
  187. if (sz1 < (int) word_size) {
  188. c_loc(sz1);
  189. c_loc((int) word_size);
  190. C_cii();
  191. sz1 = word_size;
  192. }
  193. c_loc(sz1);
  194. c_loc(sz2);
  195. switch(fund2) {
  196. case T_REAL:
  197. C_cif();
  198. break;
  199. case T_INTEGER:
  200. C_cii();
  201. break;
  202. case T_CARDINAL:
  203. C_ciu();
  204. break;
  205. default:
  206. crash("Funny integer conversion");
  207. }
  208. break;
  209. case T_CARDINAL:
  210. case T_INTORCARD:
  211. c_loc(sz1);
  212. c_loc(sz2);
  213. switch(fund2) {
  214. case T_REAL:
  215. C_cuf();
  216. break;
  217. case T_CARDINAL:
  218. case T_INTORCARD:
  219. C_cuu();
  220. break;
  221. case T_INTEGER:
  222. C_cui();
  223. break;
  224. default:
  225. crash("Funny cardinal conversion");
  226. }
  227. break;
  228. case T_REAL:
  229. switch(fund2) {
  230. case T_REAL:
  231. c_loc(sz1);
  232. c_loc(sz2);
  233. C_cff();
  234. break;
  235. case T_INTEGER:
  236. c_loc(sz1);
  237. c_loc(sz2);
  238. C_cfi();
  239. break;
  240. case T_CARDINAL:
  241. if (! options['R']) {
  242. label lb = ++text_label;
  243. arith asz1 = sz1;
  244. C_dup(asz1);
  245. C_zrf(asz1);
  246. C_cmf(asz1);
  247. C_zge(lb);
  248. c_loc(ECONV);
  249. C_trp();
  250. def_ilb(lb);
  251. }
  252. c_loc(sz1);
  253. c_loc(sz2);
  254. C_cfu();
  255. break;
  256. default:
  257. crash("Funny REAL conversion");
  258. }
  259. break;
  260. }
  261. }
  262. CodeCall(nd)
  263. register t_node *nd;
  264. {
  265. /* Generate code for a procedure call. Checking of parameters
  266. and result is already done.
  267. */
  268. register t_node *left = nd->nd_LEFT;
  269. t_type *result_tp;
  270. int needs_fn;
  271. if (left->nd_type == std_type) {
  272. CodeStd(nd);
  273. return;
  274. }
  275. assert(IsProc(left));
  276. result_tp = ResultType(left->nd_type);
  277. #ifdef BIG_RESULT_ON_STACK
  278. if (result_tp && TooBigForReturnArea(result_tp)) {
  279. C_asp(-WA(result_tp->tp_size));
  280. }
  281. #endif
  282. if (nd->nd_RIGHT) {
  283. CodeParameters(ParamList(left->nd_type), nd->nd_RIGHT);
  284. }
  285. switch(left->nd_class) {
  286. case Def: {
  287. register t_def *df = left->nd_def;
  288. if (df->df_kind == D_CONST) {
  289. /* a procedure address */
  290. df = df->con_const.tk_data.tk_def;
  291. }
  292. if (df->df_kind & (D_PROCEDURE|D_PROCHEAD)) {
  293. int level = df->df_scope->sc_level;
  294. if (level > 0) {
  295. C_lxl((arith) (proclevel - level));
  296. }
  297. needs_fn = df->df_scope->sc_defmodule;
  298. C_cal(df->prc_name);
  299. break;
  300. }}
  301. /* Fall through */
  302. default:
  303. needs_fn = 1;
  304. CodePExpr(left);
  305. C_cai();
  306. }
  307. C_asp(left->nd_type->prc_nbpar);
  308. if (result_tp) {
  309. arith sz = WA(result_tp->tp_size);
  310. if (TooBigForReturnArea(result_tp)) {
  311. #ifndef BIG_RESULT_ON_STACK
  312. C_lfr(pointer_size);
  313. C_loi(sz);
  314. #endif
  315. }
  316. else C_lfr(sz);
  317. }
  318. DoFilename(needs_fn);
  319. DoLineno(nd);
  320. }
  321. CodeParameters(param, arg)
  322. t_param *param;
  323. register t_node *arg;
  324. {
  325. register t_type *tp;
  326. register t_type *arg_type;
  327. assert(param != 0 && arg != 0);
  328. if (param->par_next) {
  329. CodeParameters(param->par_next, arg->nd_RIGHT);
  330. }
  331. tp = TypeOfParam(param);
  332. arg = arg->nd_LEFT;
  333. arg_type = arg->nd_type;
  334. if (IsConformantArray(tp)) {
  335. register t_type *elem = tp->arr_elem;
  336. C_loc(tp->arr_elsize);
  337. if (IsConformantArray(arg_type)) {
  338. DoHIGH(arg->nd_def);
  339. if (elem->tp_size != arg_type->arr_elem->tp_size) {
  340. /* This can only happen if the formal type is
  341. ARRAY OF (WORD|BYTE)
  342. */
  343. C_loc(arg_type->arr_elem->tp_size);
  344. C_mlu(word_size);
  345. if (elem == word_type) {
  346. c_loc((int) word_size - 1);
  347. C_adu(word_size);
  348. c_loc((int) word_size - 1);
  349. C_and(word_size);
  350. }
  351. else {
  352. assert(elem == byte_type);
  353. }
  354. }
  355. }
  356. else if (arg->nd_symb == STRING) {
  357. c_loc((int) arg->nd_SLE - 1);
  358. }
  359. else if (elem == word_type) {
  360. C_loc((arg_type->tp_size+word_size-1) / word_size - 1);
  361. }
  362. else if (elem == byte_type) {
  363. C_loc(arg_type->tp_size - 1);
  364. }
  365. else {
  366. C_loc(arg_type->arr_high - arg_type->arr_low);
  367. }
  368. c_loc(0);
  369. }
  370. if (IsConformantArray(tp) || IsVarParam(param)) {
  371. if (arg->nd_symb == STRING) {
  372. CodeString(arg);
  373. }
  374. else switch(arg->nd_class) {
  375. case Arrsel:
  376. case Arrow:
  377. case Def:
  378. CodeDAddress(arg, IsVarParam(param));
  379. break;
  380. default:{
  381. arith tmp, TmpSpace();
  382. arith sz = WA(arg->nd_type->tp_size);
  383. CodePExpr(arg);
  384. tmp = TmpSpace(sz, arg->nd_type->tp_align);
  385. STL(tmp, sz);
  386. C_lal(tmp);
  387. }
  388. break;
  389. }
  390. return;
  391. }
  392. if (arg_type->tp_fund == T_STRING) {
  393. CodePString(arg, tp);
  394. return;
  395. }
  396. CodePExpr(arg);
  397. }
  398. CodePString(nd, tp)
  399. t_node *nd;
  400. t_type *tp;
  401. {
  402. arith szarg = WA(nd->nd_type->tp_size);
  403. register arith zersz = WA(tp->tp_size) - szarg;
  404. if (zersz) {
  405. /* null padding required */
  406. assert(zersz > 0);
  407. C_zer(zersz);
  408. }
  409. CodeString(nd); /* push address of string */
  410. C_loi(szarg);
  411. }
  412. static
  413. subu(sz)
  414. int sz;
  415. {
  416. if (! options['R']) {
  417. C_cal(sz == (int) word_size ? "subuchk" : "subulchk");
  418. }
  419. C_sbu((arith) sz);
  420. }
  421. static
  422. addu(sz)
  423. int sz;
  424. {
  425. if (! options['R']) {
  426. C_cal(sz == (int) word_size ? "adduchk" : "addulchk");
  427. }
  428. C_adu((arith)sz);
  429. }
  430. static int
  431. complex_lhs(nd)
  432. register t_node *nd;
  433. {
  434. switch(nd->nd_class) {
  435. case Value:
  436. case Name:
  437. case Set:
  438. case Def:
  439. return 0;
  440. case Select:
  441. return complex_lhs(nd->nd_NEXT);
  442. default:
  443. return 1;
  444. }
  445. }
  446. CodeStd(nd)
  447. t_node *nd;
  448. {
  449. register t_node *arg = nd->nd_RIGHT;
  450. register t_node *left = 0;
  451. register t_type *tp = 0;
  452. int std = nd->nd_LEFT->nd_def->df_value.df_stdname;
  453. if (arg) {
  454. left = arg->nd_LEFT;
  455. tp = BaseType(left->nd_type);
  456. arg = arg->nd_RIGHT;
  457. }
  458. switch(std) {
  459. case S_ORD:
  460. case S_VAL:
  461. CodePExpr(left);
  462. break;
  463. case S_ABS:
  464. CodePExpr(left);
  465. if (tp->tp_fund == T_INTEGER) {
  466. CAL((int)(tp->tp_size) == (int)int_size ? "absi" : "absl", (int)(tp->tp_size));
  467. }
  468. else if (tp->tp_fund == T_REAL) {
  469. CAL((int)(tp->tp_size) == (int)float_size ? "absf" : "absd", (int)(tp->tp_size));
  470. }
  471. C_lfr(tp->tp_size);
  472. break;
  473. case S_CAP:
  474. CodePExpr(left);
  475. C_cal("cap");
  476. break;
  477. case S_HIGH:
  478. assert(IsConformantArray(tp));
  479. DoHIGH(left->nd_def);
  480. break;
  481. case S_SIZE:
  482. case S_TSIZE:
  483. assert(IsConformantArray(tp));
  484. DoHIGH(left->nd_def);
  485. C_inc();
  486. C_loc(tp->arr_elem->tp_size);
  487. C_mlu(word_size);
  488. break;
  489. case S_ODD:
  490. CodePExpr(left);
  491. if ((int) tp->tp_size == (int) word_size) {
  492. c_loc(1);
  493. C_and(word_size);
  494. }
  495. else {
  496. assert(tp->tp_size == dword_size);
  497. C_ldc((arith) 1);
  498. C_and(dword_size);
  499. C_ior(word_size);
  500. }
  501. break;
  502. case S_ADR:
  503. CodeDAddress(left, 1);
  504. break;
  505. case S_DEC:
  506. case S_INC: {
  507. register arith size;
  508. int compl = complex_lhs(left);
  509. arith tmp = 0;
  510. size = left->nd_type->tp_size;
  511. if ((int) size < (int) word_size) size = word_size;
  512. if (compl) {
  513. tmp = NewPtr();
  514. CodeDAddress(left, 1);
  515. STL(tmp, pointer_size);
  516. LOL(tmp, pointer_size);
  517. C_loi(left->nd_type->tp_size);
  518. }
  519. else CodePExpr(left);
  520. CodeCoercion(left->nd_type, tp);
  521. if (arg) {
  522. CodePExpr(arg->nd_LEFT);
  523. CodeCoercion(arg->nd_LEFT->nd_type, tp);
  524. }
  525. else {
  526. c_loc(1);
  527. CodeCoercion(intorcard_type, tp);
  528. }
  529. if (std == S_DEC) {
  530. if (tp->tp_fund == T_INTEGER) C_sbi(size);
  531. else subu((int) size);
  532. }
  533. else {
  534. if (tp->tp_fund == T_INTEGER) C_adi(size);
  535. else addu((int) size);
  536. }
  537. if ((int) size == (int) word_size) {
  538. RangeCheck(left->nd_type, tp->tp_fund == T_INTEGER ?
  539. int_type : card_type);
  540. }
  541. if (compl) {
  542. LOL(tmp, pointer_size);
  543. C_sti(left->nd_type->tp_size);
  544. FreePtr(tmp);
  545. }
  546. else CodeDStore(left);
  547. break;
  548. }
  549. case S_HALT:
  550. C_cal("halt");
  551. break;
  552. case S_INCL:
  553. case S_EXCL: {
  554. int compl = complex_lhs(left);
  555. arith tmp = 0;
  556. if (compl) {
  557. tmp = NewPtr();
  558. CodeDAddress(left, 1);
  559. STL(tmp, pointer_size);
  560. LOL(tmp, pointer_size);
  561. C_loi(left->nd_type->tp_size);
  562. }
  563. else CodePExpr(left);
  564. CodePExpr(arg->nd_LEFT);
  565. C_loc(tp->set_low);
  566. C_sbi(word_size);
  567. C_set(tp->tp_size);
  568. if (std == S_INCL) {
  569. C_ior(tp->tp_size);
  570. }
  571. else {
  572. C_com(tp->tp_size);
  573. C_and(tp->tp_size);
  574. }
  575. if (compl) {
  576. LOL(tmp, pointer_size);
  577. C_sti(left->nd_type->tp_size);
  578. FreePtr(tmp);
  579. }
  580. else CodeDStore(left);
  581. break;
  582. }
  583. default:
  584. crash("(CodeStd)");
  585. }
  586. }
  587. int
  588. needs_rangecheck(tpl, tpr)
  589. register t_type *tpl, *tpr;
  590. {
  591. arith rlo, rhi;
  592. if (bounded(tpl)) {
  593. /* In this case we might need a range check.
  594. If both types are restricted. check the bounds
  595. to see wether we need a range check.
  596. We don't need one if the range of values of the
  597. right hand side is a subset of the range of values
  598. of the left hand side.
  599. */
  600. if (bounded(tpr)) {
  601. getbounds(tpr, &rlo, &rhi);
  602. if (in_range(rlo, tpl) && in_range(rhi, tpl)) {
  603. return 0;
  604. }
  605. }
  606. return 1;
  607. }
  608. return 0;
  609. }
  610. RangeCheck(tpl, tpr)
  611. register t_type *tpl, *tpr;
  612. {
  613. /* Generate a range check if neccessary
  614. */
  615. arith rlo, rhi;
  616. if (options['R']) return;
  617. if (needs_rangecheck(tpl, tpr)) {
  618. genrck(tpl);
  619. return;
  620. }
  621. tpr = BaseType(tpr);
  622. if ((tpl->tp_fund == T_INTEGER && tpr->tp_fund == T_CARDINAL) ||
  623. (tpr->tp_fund == T_INTEGER && tpl->tp_fund == T_CARDINAL)) {
  624. label lb = ++text_label;
  625. C_dup(tpr->tp_size);
  626. C_zer(tpr->tp_size);
  627. C_cmi(tpr->tp_size);
  628. C_zge(lb);
  629. c_loc(ECONV);
  630. C_trp();
  631. def_ilb(lb);
  632. }
  633. }
  634. Operands(nd)
  635. register t_node *nd;
  636. {
  637. CodePExpr(nd->nd_LEFT);
  638. CodePExpr(nd->nd_RIGHT);
  639. DoLineno(nd);
  640. }
  641. CodeOper(expr, true_label, false_label)
  642. register t_node *expr; /* the expression tree itself */
  643. label true_label;
  644. label false_label; /* labels to jump to in logical expr's */
  645. {
  646. register t_node *leftop = expr->nd_LEFT;
  647. register t_node *rightop = expr->nd_RIGHT;
  648. int fund = expr->nd_type->tp_fund;
  649. arith size = expr->nd_type->tp_size;
  650. switch (expr->nd_symb) {
  651. case '+':
  652. Operands(expr);
  653. switch (fund) {
  654. case T_INTEGER:
  655. C_adi(size);
  656. break;
  657. case T_REAL:
  658. C_adf(size);
  659. break;
  660. case T_POINTER:
  661. case T_EQUAL:
  662. C_ads(rightop->nd_type->tp_size);
  663. break;
  664. case T_CARDINAL:
  665. case T_INTORCARD:
  666. addu((int) size);
  667. break;
  668. case T_SET:
  669. C_ior(size);
  670. break;
  671. default:
  672. crash("bad type +");
  673. }
  674. break;
  675. case '-':
  676. Operands(expr);
  677. switch (fund) {
  678. case T_INTEGER:
  679. C_sbi(size);
  680. break;
  681. case T_REAL:
  682. C_sbf(size);
  683. break;
  684. case T_POINTER:
  685. case T_EQUAL:
  686. if (rightop->nd_type == address_type) {
  687. C_sbs(size);
  688. break;
  689. }
  690. C_ngi(rightop->nd_type->tp_size);
  691. C_ads(rightop->nd_type->tp_size);
  692. break;
  693. case T_INTORCARD:
  694. case T_CARDINAL:
  695. subu((int) size);
  696. break;
  697. case T_SET:
  698. C_com(size);
  699. C_and(size);
  700. break;
  701. default:
  702. crash("bad type -");
  703. }
  704. break;
  705. case '*':
  706. Operands(expr);
  707. switch (fund) {
  708. case T_INTEGER:
  709. C_mli(size);
  710. break;
  711. case T_POINTER:
  712. case T_EQUAL:
  713. case T_CARDINAL:
  714. case T_INTORCARD:
  715. if (! options['R']) {
  716. C_cal((int)(size) <= (int)word_size ?
  717. "muluchk" :
  718. "mululchk");
  719. }
  720. C_mlu(size);
  721. break;
  722. case T_REAL:
  723. C_mlf(size);
  724. break;
  725. case T_SET:
  726. C_and(size);
  727. break;
  728. default:
  729. crash("bad type *");
  730. }
  731. break;
  732. case '/':
  733. Operands(expr);
  734. switch (fund) {
  735. case T_REAL:
  736. C_dvf(size);
  737. break;
  738. case T_SET:
  739. C_xor(size);
  740. break;
  741. default:
  742. crash("bad type /");
  743. }
  744. break;
  745. case DIV:
  746. Operands(expr);
  747. switch(fund) {
  748. case T_INTEGER:
  749. C_cal((int)(size) == (int)word_size
  750. ? "dvi"
  751. : "dvil");
  752. C_asp(2*size);
  753. C_lfr(size);
  754. break;
  755. case T_POINTER:
  756. case T_EQUAL:
  757. case T_CARDINAL:
  758. case T_INTORCARD:
  759. C_dvu(size);
  760. break;
  761. default:
  762. crash("bad type DIV");
  763. }
  764. break;
  765. case MOD:
  766. Operands(expr);
  767. switch(fund) {
  768. case T_INTEGER:
  769. C_cal((int)(size) == (int)word_size
  770. ? "rmi"
  771. : "rmil");
  772. C_asp(2*size);
  773. C_lfr(size);
  774. break;
  775. case T_POINTER:
  776. case T_EQUAL:
  777. case T_CARDINAL:
  778. case T_INTORCARD:
  779. C_rmu(size);
  780. break;
  781. default:
  782. crash("bad type MOD");
  783. }
  784. break;
  785. case '<':
  786. case LESSEQUAL:
  787. case '>':
  788. case GREATEREQUAL:
  789. case '=':
  790. case '#': {
  791. t_type *tp;
  792. Operands(expr);
  793. tp = BaseType(leftop->nd_type);
  794. if (tp->tp_fund == T_INTORCARD) tp = BaseType(rightop->nd_type);
  795. size = tp->tp_size;
  796. switch (tp->tp_fund) {
  797. case T_INTEGER:
  798. C_cmi(size);
  799. break;
  800. case T_POINTER:
  801. case T_HIDDEN:
  802. case T_EQUAL:
  803. C_cmp();
  804. break;
  805. case T_CARDINAL:
  806. case T_INTORCARD:
  807. C_cmu(size);
  808. break;
  809. case T_ENUMERATION:
  810. case T_CHAR:
  811. C_cmu(word_size);
  812. break;
  813. case T_REAL:
  814. C_cmf(size);
  815. break;
  816. case T_SET:
  817. if (expr->nd_symb == GREATEREQUAL) {
  818. /* A >= B is the same as A equals A + B
  819. */
  820. C_dup(size << 1);
  821. C_asp(size);
  822. C_ior(size);
  823. expr->nd_symb = '=';
  824. }
  825. else if (expr->nd_symb == LESSEQUAL) {
  826. /* A <= B is the same as A - B = {}
  827. */
  828. C_com(size);
  829. C_and(size);
  830. C_zer(size);
  831. expr->nd_symb = '=';
  832. }
  833. C_cms(size);
  834. break;
  835. default:
  836. crash("bad type COMPARE");
  837. }
  838. if (true_label != NO_LABEL) {
  839. compare(expr->nd_symb, true_label);
  840. c_bra(false_label);
  841. break;
  842. }
  843. truthvalue(expr->nd_symb);
  844. break;
  845. }
  846. case IN: {
  847. /* In this case, evaluate right hand side first! The
  848. INN instruction expects the bit number on top of the
  849. stack
  850. */
  851. label l_toolarge = NO_LABEL, l_cont = NO_LABEL;
  852. t_type *ltp = leftop->nd_type;
  853. if (leftop->nd_symb == COERCION) {
  854. /* Could be coercion to word_type. */
  855. ltp = leftop->nd_RIGHT->nd_type;
  856. }
  857. if (leftop->nd_class == Value) {
  858. if (! in_range(leftop->nd_INT, ElementType(rightop->nd_type))) {
  859. if (true_label != NO_LABEL) {
  860. c_bra(false_label);
  861. }
  862. else c_loc(0);
  863. break;
  864. }
  865. CodePExpr(rightop);
  866. C_loc(leftop->nd_INT - rightop->nd_type->set_low);
  867. }
  868. else {
  869. CodePExpr(rightop);
  870. CodePExpr(leftop);
  871. C_loc(rightop->nd_type->set_low);
  872. C_sbu(word_size);
  873. if (needs_rangecheck(ElementType(rightop->nd_type), ltp)) {
  874. l_toolarge = ++text_label;
  875. C_dup(word_size);
  876. C_loc(rightop->nd_type->tp_size*8);
  877. C_cmu(word_size);
  878. C_zge(l_toolarge);
  879. }
  880. }
  881. C_inn(rightop->nd_type->tp_size);
  882. if (true_label != NO_LABEL) {
  883. C_zne(true_label);
  884. c_bra(false_label);
  885. }
  886. else {
  887. l_cont = ++text_label;
  888. c_bra(l_cont);
  889. }
  890. if (l_toolarge != NO_LABEL) {
  891. def_ilb(l_toolarge);
  892. C_asp(word_size+rightop->nd_type->tp_size);
  893. if (true_label != NO_LABEL) {
  894. c_bra(false_label);
  895. }
  896. else c_loc(0);
  897. }
  898. if (l_cont != NO_LABEL) {
  899. def_ilb(l_cont);
  900. }
  901. break;
  902. }
  903. case OR:
  904. case AND: {
  905. label l_maybe = ++text_label, l_end = NO_LABEL;
  906. t_desig Des;
  907. Des = null_desig;
  908. if (true_label == NO_LABEL) {
  909. true_label = ++text_label;
  910. false_label = ++text_label;
  911. l_end = ++text_label;
  912. }
  913. if (expr->nd_symb == OR) {
  914. CodeExpr(leftop, &Des, true_label, l_maybe);
  915. }
  916. else CodeExpr(leftop, &Des, l_maybe, false_label);
  917. def_ilb(l_maybe);
  918. Des = null_desig;
  919. CodeExpr(rightop, &Des, true_label, false_label);
  920. if (l_end != NO_LABEL) {
  921. def_ilb(true_label);
  922. c_loc(1);
  923. c_bra(l_end);
  924. def_ilb(false_label);
  925. c_loc(0);
  926. def_ilb(l_end);
  927. }
  928. break;
  929. }
  930. default:
  931. crash("(CodeOper) Bad operator");
  932. }
  933. }
  934. /* compare() serves as an auxiliary function of CodeOper */
  935. compare(relop, lbl)
  936. int relop;
  937. register label lbl;
  938. {
  939. switch (relop) {
  940. case '<':
  941. C_zlt(lbl);
  942. break;
  943. case LESSEQUAL:
  944. C_zle(lbl);
  945. break;
  946. case '>':
  947. C_zgt(lbl);
  948. break;
  949. case GREATEREQUAL:
  950. C_zge(lbl);
  951. break;
  952. case '=':
  953. C_zeq(lbl);
  954. break;
  955. case '#':
  956. C_zne(lbl);
  957. break;
  958. default:
  959. crash("(compare)");
  960. }
  961. }
  962. /* truthvalue() serves as an auxiliary function of CodeOper */
  963. truthvalue(relop)
  964. int relop;
  965. {
  966. switch (relop) {
  967. case '<':
  968. C_tlt();
  969. break;
  970. case LESSEQUAL:
  971. C_tle();
  972. break;
  973. case '>':
  974. C_tgt();
  975. break;
  976. case GREATEREQUAL:
  977. C_tge();
  978. break;
  979. case '=':
  980. C_teq();
  981. break;
  982. case '#':
  983. C_tne();
  984. break;
  985. default:
  986. crash("(truthvalue)");
  987. }
  988. }
  989. CodeUoper(nd)
  990. register t_node *nd;
  991. {
  992. register t_type *tp = nd->nd_type;
  993. CodePExpr(nd->nd_RIGHT);
  994. switch(nd->nd_symb) {
  995. case NOT:
  996. C_teq();
  997. break;
  998. case '-':
  999. switch(tp->tp_fund) {
  1000. case T_INTEGER:
  1001. case T_INTORCARD:
  1002. C_ngi(tp->tp_size);
  1003. break;
  1004. case T_REAL:
  1005. C_ngf(tp->tp_size);
  1006. break;
  1007. default:
  1008. crash("Bad operand to unary -");
  1009. }
  1010. break;
  1011. case COERCION:
  1012. CodeCoercion(nd->nd_RIGHT->nd_type, tp);
  1013. RangeCheck(tp, nd->nd_RIGHT->nd_type);
  1014. break;
  1015. case CAST:
  1016. break;
  1017. default:
  1018. crash("Bad unary operator");
  1019. }
  1020. }
  1021. CodeSet(nd, null_set)
  1022. register t_node *nd;
  1023. {
  1024. register t_type *tp = nd->nd_type;
  1025. nd = nd->nd_NEXT;
  1026. while (nd) {
  1027. assert(nd->nd_class == Link && nd->nd_symb == ',');
  1028. if (nd->nd_LEFT) {
  1029. CodeEl(nd->nd_LEFT, tp, null_set);
  1030. null_set = 0;
  1031. }
  1032. nd = nd->nd_RIGHT;
  1033. }
  1034. if (null_set) C_zer(tp->tp_size);
  1035. }
  1036. CodeEl(nd, tp, null_set)
  1037. register t_node *nd;
  1038. register t_type *tp;
  1039. {
  1040. register t_type *eltype = ElementType(tp);
  1041. if (nd->nd_class == Link && nd->nd_symb == UPTO) {
  1042. if (null_set) C_zer(tp->tp_size);
  1043. C_loc(tp->set_low);
  1044. C_loc(tp->tp_size); /* push size */
  1045. if (eltype->tp_fund == T_SUBRANGE) {
  1046. C_loc(eltype->sub_ub);
  1047. }
  1048. else C_loc(eltype->enm_ncst - 1);
  1049. Operands(nd);
  1050. CAL("LtoUset", 5 * (int) word_size);
  1051. /* library routine to fill set */
  1052. }
  1053. else {
  1054. CodePExpr(nd);
  1055. C_loc(tp->set_low);
  1056. C_sbi(word_size);
  1057. C_set(tp->tp_size);
  1058. if (! null_set) C_ior(tp->tp_size);
  1059. }
  1060. }
  1061. CodePExpr(nd)
  1062. register t_node *nd;
  1063. {
  1064. /* Generate code to push the value of the expression "nd"
  1065. on the stack.
  1066. */
  1067. t_desig designator;
  1068. designator = null_desig;
  1069. CodeExpr(nd, &designator, NO_LABEL, NO_LABEL);
  1070. CodeValue(&designator, nd->nd_type);
  1071. }
  1072. CodeDAddress(nd, chk_controlvar)
  1073. t_node *nd;
  1074. {
  1075. /* Generate code to push the address of the designator "nd"
  1076. on the stack.
  1077. */
  1078. t_desig designator;
  1079. int chkptr;
  1080. designator = null_desig;
  1081. if (chk_controlvar) ChkForFOR(nd);
  1082. CodeDesig(nd, &designator);
  1083. chkptr = designator.dsg_kind==DSG_PLOADED ||
  1084. designator.dsg_kind==DSG_PFIXED;
  1085. CodeAddress(&designator);
  1086. /* Generate dummy use of pointer, to get possible error message
  1087. as soon as possible
  1088. */
  1089. if (chkptr && ! options['R']) {
  1090. C_dup(pointer_size);
  1091. C_loi((arith) 1);
  1092. C_asp(word_size);
  1093. }
  1094. }
  1095. CodeDStore(nd)
  1096. register t_node *nd;
  1097. {
  1098. /* Generate code to store the expression on the stack into the
  1099. designator "nd".
  1100. */
  1101. t_desig designator;
  1102. designator = null_desig;
  1103. ChkForFOR(nd);
  1104. CodeDesig(nd, &designator);
  1105. CodeStore(&designator, nd->nd_type);
  1106. }
  1107. DoHIGH(df)
  1108. register t_def *df;
  1109. {
  1110. /* Get the high index of a conformant array, indicated by "nd".
  1111. The high index is the second field in the descriptor of
  1112. the array, so it is easily found.
  1113. */
  1114. register arith highoff;
  1115. assert(df->df_kind == D_VARIABLE);
  1116. assert(IsConformantArray(df->df_type));
  1117. highoff = df->var_off /* base address and descriptor */
  1118. + word_size + pointer_size;
  1119. /* skip base and first field of
  1120. descriptor
  1121. */
  1122. if (df->df_scope->sc_level < proclevel) {
  1123. C_lxa((arith) (proclevel - df->df_scope->sc_level));
  1124. C_lof(highoff);
  1125. }
  1126. else C_lol(highoff);
  1127. }
  1128. #ifdef SQUEEZE
  1129. c_bra(l)
  1130. label l;
  1131. {
  1132. C_bra((label) l);
  1133. }
  1134. c_loc(n)
  1135. {
  1136. C_loc((arith) n);
  1137. }
  1138. c_lae_dlb(l)
  1139. label l;
  1140. {
  1141. C_lae_dlb(l, (arith) 0);
  1142. }
  1143. CAL(name, ssp)
  1144. char *name;
  1145. int ssp;
  1146. {
  1147. C_cal(name);
  1148. C_asp((arith) ssp);
  1149. }
  1150. #endif