type.c 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702
  1. /* T Y P E D E F I N I T I O N M E C H A N I S M */
  2. #include "debug.h"
  3. #include <alloc.h>
  4. #include <assert.h>
  5. #include <em.h>
  6. #include <pc_file.h>
  7. #include "LLlex.h"
  8. #include "const.h"
  9. #include "def.h"
  10. #include "idf.h"
  11. #include "main.h"
  12. #include "node.h"
  13. #include "scope.h"
  14. #include "type.h"
  15. #ifndef NOCROSS
  16. #include "target_sizes.h"
  17. int
  18. word_align = AL_WORD,
  19. int_align = AL_INT,
  20. long_align = AL_LONG,
  21. pointer_align = AL_POINTER,
  22. real_align = AL_REAL,
  23. struct_align = AL_STRUCT;
  24. arith
  25. word_size = SZ_WORD,
  26. int_size = SZ_INT,
  27. long_size = SZ_LONG,
  28. pointer_size = SZ_POINTER,
  29. real_size = SZ_REAL;
  30. #endif NOCROSS
  31. extern arith max_int;
  32. struct type
  33. *bool_type,
  34. *char_type,
  35. *int_type,
  36. *long_type,
  37. *real_type,
  38. *string_type,
  39. *std_type,
  40. *text_type,
  41. *nil_type,
  42. *emptyset_type,
  43. *void_type,
  44. *error_type;
  45. CheckTypeSizes()
  46. {
  47. /* first, do some checking
  48. */
  49. if( int_size != word_size )
  50. fatal("integer size not equal to word size");
  51. if( word_size != 2 && word_size != 4 )
  52. fatal("illegal wordsize");
  53. if( pointer_size != 2 && pointer_size != 4 )
  54. fatal("illegal pointersize");
  55. if( options['d'] ) {
  56. if( long_size < int_size )
  57. fatal("longsize should be at least the integersize");
  58. if( long_size > 2 * int_size)
  59. fatal("longsize should be at most twice the integersize");
  60. }
  61. if( pointer_size < word_size )
  62. fatal("pointersize should be at least the wordsize");
  63. if( real_size != 4 && real_size != 8 )
  64. fatal("illegal realsize");
  65. }
  66. InitTypes()
  67. {
  68. /* First check the sizes of some basic EM-types
  69. */
  70. CheckTypeSizes();
  71. if( options['s'] ) {
  72. options['c'] = 0;
  73. options['d'] = 0;
  74. options['u'] = 0;
  75. options['C'] = 0;
  76. options['U'] = 0;
  77. }
  78. /* Initialize the predefined types
  79. */
  80. /* character type
  81. */
  82. char_type = standard_type(T_CHAR, 1, (arith) 1);
  83. char_type->enm_ncst = 128; /* only 7 bits ASCII characters */
  84. /* boolean type
  85. */
  86. bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
  87. bool_type->enm_ncst = 2;
  88. /* integer type
  89. */
  90. int_type = standard_type(T_INTEGER, int_align, int_size);
  91. /* real type
  92. */
  93. real_type = standard_type(T_REAL, real_align, real_size);
  94. /* long type
  95. */
  96. if( options['d'] )
  97. long_type = standard_type(T_LONG, long_align, long_size);
  98. /* string type
  99. */
  100. if( options['c'] )
  101. string_type = standard_type(T_STRING, pointer_align, pointer_size);
  102. /* an unique type for standard procedures and functions
  103. */
  104. std_type = construct_type(T_PROCEDURE, NULLTYPE);
  105. /* text (file of char) type
  106. */
  107. text_type = construct_type(T_FILE, char_type);
  108. text_type->tp_flags |= T_HASFILE;
  109. /* an unique type indicating an error
  110. */
  111. error_type = standard_type(T_ERROR, 1, (arith) 1);
  112. void_type = error_type;
  113. /* the nilvalue has an unique type
  114. */
  115. nil_type = construct_type(T_POINTER, error_type);
  116. /* the type of an empty set is generic
  117. */
  118. emptyset_type = construct_type(T_SET, error_type);
  119. emptyset_type->tp_size = word_size;
  120. emptyset_type->tp_align = word_align;
  121. }
  122. int
  123. fit(sz, nbytes)
  124. arith sz;
  125. {
  126. return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
  127. }
  128. struct type *
  129. standard_type(fund, algn, size)
  130. arith size;
  131. {
  132. register struct type *tp = new_type();
  133. tp->tp_fund = fund;
  134. tp->tp_palign = algn ? algn : 1;
  135. tp->tp_psize = size;
  136. tp->tp_align = word_align;
  137. tp->tp_size = WA(size);
  138. return tp;
  139. }
  140. struct type *
  141. construct_type(fund, tp)
  142. register struct type *tp;
  143. {
  144. /* fund must be a type constructor.
  145. * The pointer to the constructed type is returned.
  146. */
  147. register struct type *dtp = new_type();
  148. switch( dtp->tp_fund = fund ) {
  149. case T_PROCEDURE:
  150. case T_FUNCTION:
  151. dtp->tp_align = pointer_align;
  152. dtp->tp_size = 2 * pointer_size;
  153. break;
  154. case T_POINTER:
  155. dtp->tp_align = dtp->tp_palign = pointer_align;
  156. dtp->tp_size = dtp->tp_psize = pointer_size;
  157. break;
  158. case T_SET:
  159. case T_ARRAY:
  160. break;
  161. case T_FILE:
  162. dtp->tp_align = dtp->tp_palign = word_align;
  163. dtp->tp_size = dtp->tp_psize = sizeof(struct file);
  164. break;
  165. case T_SUBRANGE:
  166. assert(tp != 0);
  167. dtp->tp_align = tp->tp_align;
  168. dtp->tp_size = tp->tp_size;
  169. dtp->tp_palign = tp->tp_palign;
  170. dtp->tp_psize = tp->tp_psize;
  171. break;
  172. default:
  173. crash("funny type constructor");
  174. }
  175. dtp->next = tp;
  176. return dtp;
  177. }
  178. struct type *
  179. proc_type(parameters, n_bytes_params)
  180. struct paramlist *parameters;
  181. arith n_bytes_params;
  182. {
  183. register struct type *tp = construct_type(T_PROCEDURE, NULLTYPE);
  184. tp->prc_params = parameters;
  185. tp->prc_nbpar = n_bytes_params;
  186. return tp;
  187. }
  188. struct type *
  189. func_type(parameters, n_bytes_params, resulttype)
  190. struct paramlist *parameters;
  191. arith n_bytes_params;
  192. struct type *resulttype;
  193. {
  194. register struct type *tp = construct_type(T_FUNCTION, resulttype);
  195. tp->prc_params = parameters;
  196. tp->prc_nbpar = n_bytes_params;
  197. return tp;
  198. }
  199. chk_type_id(ptp, nd)
  200. register struct type **ptp;
  201. register struct node *nd;
  202. {
  203. register struct def *df;
  204. *ptp = error_type;
  205. if( ChkLinkOrName(nd) ) {
  206. if( nd->nd_class != Def )
  207. node_error(nd, "type expected");
  208. else {
  209. /* register struct def *df = nd->nd_def; */
  210. df = nd->nd_def;
  211. df->df_flags |= D_USED;
  212. if( df->df_kind & (D_TYPE | D_FTYPE | D_ERROR) ) {
  213. if( !df->df_type )
  214. node_error(nd, "type \"%s\" not declared",
  215. df->df_idf->id_text);
  216. else
  217. *ptp = df->df_type;
  218. }
  219. else
  220. node_error(nd,"identifier \"%s\" is not a type",
  221. df->df_idf->id_text);
  222. }
  223. }
  224. }
  225. struct type *
  226. subr_type(lb, ub)
  227. register struct node *lb, *ub;
  228. {
  229. /* Construct a subrange type from the constant expressions
  230. indicated by "lb" and "ub", but first perform some checks
  231. */
  232. register struct type *tp = lb->nd_type, *res;
  233. if( !TstTypeEquiv(lb->nd_type, ub->nd_type) ) {
  234. node_error(ub, "types of subrange bounds not equal");
  235. return error_type;
  236. }
  237. /* Check base type
  238. */
  239. if( !(tp->tp_fund & T_ORDINAL) ) {
  240. node_error(ub, "illegal base type for subrange");
  241. return error_type;
  242. }
  243. /* Check bounds
  244. */
  245. if( lb->nd_INT > ub->nd_INT )
  246. node_error(ub, "lower bound exceeds upper bound");
  247. /* Now construct resulting type
  248. */
  249. res = construct_type(T_SUBRANGE, tp);
  250. res->sub_lb = lb->nd_INT;
  251. res->sub_ub = ub->nd_INT;
  252. if (res->sub_lb >= 0) {
  253. if (ufit(res->sub_ub, 1)) {
  254. res->tp_psize = 1;
  255. res->tp_palign = 1;
  256. }
  257. else if (ufit(res->sub_ub, 2)) {
  258. res->tp_psize = 2;
  259. res->tp_palign = 2 < word_align ? 2 : word_align;
  260. }
  261. }
  262. else {
  263. if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
  264. res->tp_psize = 1;
  265. res->tp_palign = 1;
  266. }
  267. else if (fit(res->sub_lb, 2) && fit(res->sub_ub, 2)) {
  268. res->tp_psize = 2;
  269. res->tp_palign = 2 < word_align ? 2 : word_align;
  270. }
  271. }
  272. return res;
  273. }
  274. getbounds(tp, plo, phi)
  275. register struct type *tp;
  276. arith *plo, *phi;
  277. {
  278. /* Get the bounds of a bounded type
  279. */
  280. assert(bounded(tp));
  281. if( tp->tp_fund & T_SUBRANGE ) {
  282. *plo = tp->sub_lb;
  283. *phi = tp->sub_ub;
  284. }
  285. else if( tp->tp_fund & T_INTEGER ) {
  286. *plo = -max_int;
  287. *phi = max_int;
  288. }
  289. else {
  290. *plo = 0;
  291. *phi = tp->enm_ncst - 1;
  292. }
  293. }
  294. struct type *
  295. set_type(tp, packed)
  296. register struct type *tp;
  297. unsigned short packed;
  298. {
  299. /* Construct a set type with base type "tp", but first
  300. perform some checks
  301. */
  302. struct type *basetype;
  303. static struct type *int_set = 0;
  304. arith lb, ub;
  305. if( tp == int_type ) {
  306. /* SET OF INTEGER */
  307. if( !int_set ) {
  308. struct node *lbn = new_node();
  309. struct node *ubn = new_node();
  310. lbn->nd_type = ubn->nd_type = int_type;
  311. /* the bounds are implicit */
  312. lbn->nd_INT = 0;
  313. ubn->nd_INT = max_intset;
  314. int_set = subr_type(lbn, ubn);
  315. }
  316. lb = 0;
  317. ub = max_intset;
  318. tp = int_set;
  319. }
  320. else {
  321. /* SET OF subrange/enumeration/char */
  322. if( !bounded(tp) ) {
  323. error("illegal base type of set");
  324. return error_type;
  325. }
  326. basetype = BaseType(tp);
  327. if( basetype == int_type ) {
  328. /* subrange of integers */
  329. getbounds(tp, &lb, &ub);
  330. if( lb < 0 || ub > max_intset ) {
  331. error("illegal integer base type of set");
  332. return error_type;
  333. }
  334. lb = 0;
  335. ub = max_intset;
  336. }
  337. else getbounds(basetype, &lb, &ub);
  338. }
  339. assert(lb == 0);
  340. /* at this point lb and ub denote the bounds of the host-type of the
  341. * base-type of the set
  342. */
  343. tp = construct_type(T_SET, tp);
  344. tp->tp_flags |= packed;
  345. tp->tp_psize = (ub - lb + 8) >> 3;
  346. tp->tp_size = WA(tp->tp_psize);
  347. tp->tp_align = word_align;
  348. if( !packed || word_size % tp->tp_psize != 0 ) {
  349. tp->tp_psize = tp->tp_size;
  350. tp->tp_palign = word_align;
  351. }
  352. else tp->tp_palign = tp->tp_psize;
  353. return tp;
  354. }
  355. arith
  356. ArrayElSize(tp, packed)
  357. register struct type *tp;
  358. {
  359. /* Align element size to alignment requirement of element type.
  360. Also make sure that its size is either a dividor of the word_size,
  361. or a multiple of it.
  362. */
  363. register arith algn;
  364. if( tp->tp_fund & T_ARRAY && !(tp->tp_flags & T_CHECKED) )
  365. ArraySizes(tp);
  366. if( !packed )
  367. return tp->tp_size;
  368. algn = align(tp->tp_psize, tp->tp_palign);
  369. if( word_size % algn != 0 ) {
  370. /* algn is not a dividor of the word size, so make sure it
  371. is a multiple
  372. */
  373. algn = WA(algn);
  374. }
  375. if( !fit(algn, (int) word_size) ) {
  376. error("element of array too large");
  377. }
  378. return algn;
  379. }
  380. ArraySizes(tp)
  381. register struct type *tp;
  382. {
  383. /* Assign sizes to an array type, and check index type
  384. */
  385. register struct type *index_type = IndexType(tp);
  386. register struct type *elem_type = tp->arr_elem;
  387. arith lo, hi, diff;
  388. tp->tp_flags |= T_CHECKED;
  389. tp->arr_elsize = ArrayElSize(elem_type,(int) IsPacked(tp));
  390. /* check index type
  391. */
  392. if( !bounded(index_type) ) {
  393. error("illegal index type");
  394. tp->tp_psize = tp->tp_size = tp->arr_elsize;
  395. tp->tp_palign = tp->tp_align = elem_type->tp_align;
  396. tp->next = error_type;
  397. return;
  398. }
  399. getbounds(index_type, &lo, &hi);
  400. diff = hi - lo;
  401. if( diff < 0 || !fit(diff, (int) word_size) ) {
  402. error("too many elements in array");
  403. }
  404. if( (unsigned long)full_mask[(int) pointer_size]/(diff + 1) <
  405. tp->arr_elsize ) {
  406. error("array too large");
  407. }
  408. tp->tp_psize = (diff + 1) * tp->arr_elsize;
  409. tp->tp_palign = (word_size % tp->tp_psize) ? word_align : tp->tp_psize;
  410. tp->tp_size = WA(tp->tp_psize);
  411. tp->tp_align = word_align;
  412. /* generate descriptor and remember label.
  413. */
  414. tp->arr_ardescr = ++data_label;
  415. C_df_dlb(data_label);
  416. C_rom_cst(lo);
  417. C_rom_cst(diff);
  418. C_rom_cst(tp->arr_elsize);
  419. }
  420. FreeForward(for_type)
  421. register struct forwtype *for_type;
  422. {
  423. if( !for_type ) return;
  424. FreeForward(for_type->f_next);
  425. free_node(for_type->f_node);
  426. free_forwtype(for_type);
  427. }
  428. chk_forw_types()
  429. {
  430. /* check all forward references (in pointer types) */
  431. register struct def *df = CurrentScope->sc_def;
  432. register struct def *ldf = NULLDEF;
  433. struct type *tp;
  434. while( df ) {
  435. if( df->df_kind & (D_FORWTYPE | D_FTYPE) ) {
  436. register struct forwtype *fw_type = df->df_fortype;
  437. if( df->df_kind == D_FORWTYPE ) {
  438. /* forward type not in this scope declared */
  439. register struct scopelist *scl = nextvisible(CurrVis);
  440. struct def *df1 = 0;
  441. while( scl ) {
  442. /* look in enclosing scopes */
  443. df1 = lookup(df->df_fortype->f_node->nd_IDF,
  444. scl->sc_scope, D_INUSE);
  445. if( df1 ) break;
  446. scl = nextvisible( scl );
  447. }
  448. if( !df1 || df1->df_kind != D_TYPE ) {
  449. /* bad forward type */
  450. tp = error_type;
  451. }
  452. else { /* ok */
  453. tp = df1->df_type;
  454. /* remove the def struct in the current scope */
  455. if( !ldf )
  456. CurrentScope->sc_def = df->df_nextinscope;
  457. else
  458. ldf->df_nextinscope = df->df_nextinscope;
  459. /* remove the def struct from symbol-table */
  460. remove_def(df);
  461. }
  462. }
  463. else /* forward type was resolved */
  464. tp = df->df_type;
  465. while( fw_type ) {
  466. if( tp == error_type )
  467. node_error(fw_type->f_node,
  468. "identifier \"%s\" is not a type",
  469. df->df_idf->id_text);
  470. fw_type->f_type->next = tp;
  471. fw_type = fw_type->f_next;
  472. }
  473. FreeForward( df->df_fortype );
  474. df->df_flags |= D_USED;
  475. if( tp == error_type )
  476. df->df_kind = D_ERROR;
  477. else
  478. df->df_kind = D_TYPE;
  479. }
  480. ldf = df;
  481. df = df->df_nextinscope;
  482. }
  483. }
  484. TstCaseConstants(nd, sel, sel1)
  485. register struct node *nd;
  486. register struct selector *sel, *sel1;
  487. {
  488. /* Insert selector of nested variant (sel1) in tagvalue-table of
  489. current selector (sel).
  490. */
  491. while( nd ) {
  492. if( !TstCompat(nd->nd_type, sel->sel_type) )
  493. node_error(nd, "type incompatibility in caselabel");
  494. else if( sel->sel_ptrs ) {
  495. arith i = nd->nd_INT - sel->sel_lb;
  496. if( i < 0 || i >= sel->sel_ncst )
  497. node_error(nd, "case constant: out of bounds");
  498. else if( sel->sel_ptrs[i] != sel )
  499. node_error(nd,
  500. "record variant: multiple defined caselabel");
  501. else
  502. sel->sel_ptrs[i] = sel1;
  503. }
  504. nd = nd->nd_next;
  505. }
  506. }
  507. arith
  508. align(pos, al)
  509. arith pos;
  510. int al;
  511. {
  512. arith i;
  513. return pos + ((i = pos % al) ? al - i : 0);
  514. }
  515. int
  516. gcd(m, n)
  517. register int m, n;
  518. {
  519. /* Greatest Common Divisor
  520. */
  521. register int r;
  522. while( n ) {
  523. r = m % n;
  524. m = n;
  525. n = r;
  526. }
  527. return m;
  528. }
  529. int
  530. lcm(m, n)
  531. int m, n;
  532. {
  533. /* Least Common Multiple
  534. */
  535. return m * (n / gcd(m, n));
  536. }
  537. #ifdef DEBUG
  538. DumpType(tp)
  539. register struct type *tp;
  540. {
  541. if( !tp ) return;
  542. print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
  543. print(" fund:");
  544. switch( tp->tp_fund ) {
  545. case T_ENUMERATION:
  546. print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
  547. case T_INTEGER:
  548. print("INTEGER"); break;
  549. case T_LONG:
  550. print("LONG"); break;
  551. case T_REAL:
  552. print("REAL"); break;
  553. case T_CHAR:
  554. print("CHAR"); break;
  555. case T_STRING:
  556. print("STRING"); break;
  557. case T_PROCEDURE:
  558. case T_FUNCTION:
  559. {
  560. register struct paramlist *par = ParamList(tp);
  561. if( tp->tp_fund == T_PROCEDURE )
  562. print("PROCEDURE");
  563. else
  564. print("FUNCTION");
  565. if( par ) {
  566. print("(");
  567. while( par ) {
  568. if( IsVarParam(par) ) print("VAR ");
  569. DumpType(TypeOfParam(par));
  570. par = par->next;
  571. }
  572. }
  573. break;
  574. }
  575. case T_FILE:
  576. print("FILE"); break;
  577. case T_STRINGCONST:
  578. print("STRINGCONST"); break;
  579. case T_SUBRANGE:
  580. print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
  581. break;
  582. case T_SET:
  583. print("SET"); break;
  584. case T_ARRAY:
  585. print("ARRAY");
  586. print("; element:");
  587. DumpType(tp->arr_elem);
  588. print("; index:");
  589. DumpType(tp->next);
  590. print(";");
  591. return;
  592. case T_RECORD:
  593. print("RECORD"); break;
  594. case T_POINTER:
  595. print("POINTER"); break;
  596. default:
  597. crash("DumpType");
  598. }
  599. if( tp->next && tp->tp_fund != T_POINTER ) {
  600. /* Avoid printing recursive types!
  601. */
  602. print(" next:(");
  603. DumpType(tp->next);
  604. print(")");
  605. }
  606. print(";");
  607. }
  608. #endif