code.c 21 KB

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