type.c 20 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937
  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. /* T Y P E D E F I N I T I O N M E C H A N I S M */
  8. /* $Id$ */
  9. #include "debug.h"
  10. #include <assert.h>
  11. #include <alloc.h>
  12. #include <em_arith.h>
  13. #include <em_label.h>
  14. #include <em_code.h>
  15. #include "nostrict.h"
  16. #include "LLlex.h"
  17. #include "def.h"
  18. #include "type.h"
  19. #include "idf.h"
  20. #include "node.h"
  21. #include "scope.h"
  22. #include "walk.h"
  23. #include "main.h"
  24. #include "chk_expr.h"
  25. #include "warning.h"
  26. #include "uns_arith.h"
  27. #ifndef NOCROSS
  28. #include "target_sizes.h"
  29. int
  30. word_align = AL_WORD,
  31. short_align = AL_SHORT,
  32. int_align = AL_INT,
  33. long_align = AL_LONG,
  34. float_align = AL_FLOAT,
  35. double_align = AL_DOUBLE,
  36. pointer_align = AL_POINTER,
  37. struct_align = AL_STRUCT;
  38. arith
  39. word_size = SZ_WORD,
  40. dword_size = 2 * SZ_WORD,
  41. int_size = SZ_INT,
  42. short_size = SZ_SHORT,
  43. long_size = SZ_LONG,
  44. float_size = SZ_FLOAT,
  45. double_size = SZ_DOUBLE,
  46. pointer_size = SZ_POINTER;
  47. #endif
  48. #define arith_sign ((arith) (1L << (sizeof(arith) * 8 - 1)))
  49. arith ret_area_size;
  50. t_type
  51. *bool_type,
  52. *char_type,
  53. *int_type,
  54. *card_type,
  55. *longint_type,
  56. *longcard_type,
  57. *real_type,
  58. *longreal_type,
  59. *word_type,
  60. *byte_type,
  61. *address_type,
  62. *intorcard_type,
  63. *longintorcard_type,
  64. *bitset_type,
  65. *void_type,
  66. *std_type,
  67. *error_type;
  68. t_type *
  69. construct_type(fund, tp)
  70. int fund;
  71. register t_type *tp;
  72. {
  73. /* fund must be a type constructor.
  74. The pointer to the constructed type is returned.
  75. */
  76. register t_type *dtp = new_type();
  77. switch (dtp->tp_fund = fund) {
  78. case T_PROCEDURE:
  79. case T_POINTER:
  80. case T_HIDDEN:
  81. dtp->tp_align = pointer_align;
  82. dtp->tp_size = pointer_size;
  83. break;
  84. case T_SET:
  85. dtp->tp_align = word_align;
  86. break;
  87. case T_ARRAY:
  88. dtp->tp_value.tp_arr = new_array();
  89. dtp->tp_align = struct_align;
  90. break;
  91. case T_SUBRANGE:
  92. assert(tp != 0);
  93. dtp->tp_value.tp_subrange = new_subrange();
  94. dtp->tp_align = tp->tp_align;
  95. dtp->tp_size = tp->tp_size;
  96. break;
  97. default:
  98. crash("funny type constructor");
  99. }
  100. dtp->tp_next = tp;
  101. return dtp;
  102. }
  103. arith
  104. align(pos, al)
  105. arith pos;
  106. int al;
  107. {
  108. int i = pos % al;
  109. if (i) return pos + (al - i);
  110. return pos;
  111. }
  112. t_type *
  113. standard_type(fund, algn, size)
  114. int fund;
  115. int algn;
  116. arith size;
  117. {
  118. register t_type *tp = new_type();
  119. tp->tp_fund = fund;
  120. tp->tp_align = algn;
  121. tp->tp_size = size;
  122. if (fund == T_ENUMERATION || fund == T_CHAR) {
  123. tp->tp_value.tp_enum = new_enume();
  124. }
  125. return tp;
  126. }
  127. InitTypes()
  128. {
  129. /* Initialize the predefined types
  130. */
  131. register t_type *tp;
  132. /* first, do some checking
  133. */
  134. if ((int) int_size != (int) word_size) {
  135. fatal("integer size not equal to word size");
  136. }
  137. if ((int) long_size < (int) int_size) {
  138. fatal("long integer size smaller than integer size");
  139. }
  140. if ((int) double_size < (int) float_size) {
  141. fatal("long real size smaller than real size");
  142. }
  143. ret_area_size = (int) double_size > ((int) pointer_size << 1) ?
  144. double_size : (pointer_size << 1);
  145. /* character type
  146. */
  147. char_type = standard_type(T_CHAR, 1, (arith) 1);
  148. char_type->enm_ncst = 256;
  149. /* boolean type
  150. */
  151. bool_type = standard_type(T_ENUMERATION, 1, (arith) 1);
  152. bool_type->enm_ncst = 2;
  153. /* integer types, also a "intorcard", for integer constants between
  154. 0 and MAX(INTEGER)
  155. */
  156. int_type = standard_type(T_INTEGER, int_align, int_size);
  157. longint_type = standard_type(T_INTEGER, long_align, long_size);
  158. longcard_type = standard_type(T_CARDINAL, long_align, long_size);
  159. card_type = standard_type(T_CARDINAL, int_align, int_size);
  160. intorcard_type = standard_type(T_INTORCARD, int_align, int_size);
  161. longintorcard_type = standard_type(T_INTORCARD, long_align, long_size);
  162. /* floating types
  163. */
  164. real_type = standard_type(T_REAL, float_align, float_size);
  165. longreal_type = standard_type(T_REAL, double_align, double_size);
  166. /* SYSTEM types
  167. */
  168. word_type = standard_type(T_WORD, word_align, word_size);
  169. byte_type = standard_type(T_WORD, 1, (arith) 1);
  170. address_type = construct_type(T_POINTER, word_type);
  171. /* create BITSET type
  172. TYPE BITSET = SET OF [0..W-1];
  173. The subrange is a subrange of type cardinal, because the lower bound
  174. is a non-negative integer (See Rep. 6.3)
  175. */
  176. tp = construct_type(T_SUBRANGE, card_type);
  177. tp->sub_lb = 0;
  178. tp->sub_ub = (int) word_size * 8 - 1;
  179. bitset_type = set_type(tp);
  180. /* a unique type for standard procedures and functions
  181. */
  182. std_type = construct_type(T_PROCEDURE, NULLTYPE);
  183. /* a unique type indicating an error
  184. */
  185. error_type = new_type();
  186. *error_type = *char_type;
  187. void_type = error_type;
  188. }
  189. int
  190. fit(sz, nbytes)
  191. arith sz;
  192. {
  193. return ((sz) + ((arith)0x80<<(((nbytes)-1)*8)) & ~full_mask[(nbytes)]) == 0;
  194. }
  195. STATIC
  196. u_small(tp, n)
  197. register t_type *tp;
  198. arith n;
  199. {
  200. if (ufit(n, 1)) {
  201. tp->tp_size = 1;
  202. tp->tp_align = 1;
  203. }
  204. else if (ufit(n, (int)short_size)) {
  205. tp->tp_size = short_size;
  206. tp->tp_align = short_align;
  207. }
  208. }
  209. t_type *
  210. enum_type(EnumList)
  211. t_node *EnumList;
  212. {
  213. register t_type *tp =
  214. standard_type(T_ENUMERATION, int_align, int_size);
  215. EnterEnumList(EnumList, tp);
  216. if (! fit(tp->enm_ncst, (int) int_size)) {
  217. node_error(EnumList, "too many enumeration literals");
  218. }
  219. u_small(tp, (arith) (tp->enm_ncst-1));
  220. return tp;
  221. }
  222. t_type *
  223. qualified_type(pnd)
  224. t_node **pnd;
  225. {
  226. register t_def *df;
  227. if (ChkDesig(pnd, D_USED)) {
  228. register t_node *nd = *pnd;
  229. if (nd->nd_class != Def) {
  230. node_error(nd, "type expected");
  231. FreeNode(nd);
  232. return error_type;
  233. }
  234. df = nd->nd_def;
  235. if (df->df_kind&(D_ISTYPE|D_FORWARD|D_FORWTYPE|D_ERROR)) {
  236. if (! df->df_type) {
  237. node_error(nd,"type \"%s\" not (yet) declared", df->df_idf->id_text);
  238. FreeNode(nd);
  239. return error_type;
  240. }
  241. FreeNode(nd);
  242. if (df->df_kind == D_FORWTYPE) {
  243. /* Here, df->df_type was already set,
  244. so there is an actual definition in the
  245. surrounding scope, which is now used.
  246. */
  247. ForceForwardTypeDef(df);
  248. }
  249. return df->df_type;
  250. }
  251. node_error(nd, "identifier \"%s\" is not a type", df->df_idf->id_text);
  252. }
  253. FreeNode(*pnd);
  254. return error_type;
  255. }
  256. int
  257. chk_bounds(l1, l2, fund)
  258. arith l1, l2;
  259. {
  260. /* compare to arith's, but be careful. They might be unsigned
  261. */
  262. if (fund == T_INTEGER) {
  263. return l2 >= l1;
  264. }
  265. #ifdef UNSIGNED_ARITH
  266. return (UNSIGNED_ARITH) l2 >= (UNSIGNED_ARITH) l1;
  267. #else
  268. return (l2 & arith_sign ?
  269. (l1 & arith_sign ? l2 >= l1 : 1) :
  270. (l1 & arith_sign ? 0 : l2 >= l1)
  271. );
  272. #endif
  273. }
  274. int
  275. in_range(i, tp)
  276. arith i;
  277. register t_type *tp;
  278. {
  279. /* Check that the value i fits in the subrange or enumeration
  280. type tp. Return 1 if so, 0 otherwise
  281. */
  282. switch(tp->tp_fund) {
  283. case T_ENUMERATION:
  284. case T_CHAR:
  285. return i >= 0 && i < tp->enm_ncst;
  286. case T_SUBRANGE:
  287. return chk_bounds(i, tp->sub_ub, SubBaseType(tp)->tp_fund) &&
  288. chk_bounds(tp->sub_lb, i, SubBaseType(tp)->tp_fund);
  289. }
  290. assert(0);
  291. /*NOTREACHED*/
  292. }
  293. t_type *
  294. subr_type(lb, ub, base)
  295. register t_node *lb;
  296. t_node *ub;
  297. t_type *base;
  298. {
  299. /* Construct a subrange type from the constant expressions
  300. indicated by "lb" and "ub", but first perform some
  301. checks. "base" is either a user-specified base-type, or NULL.
  302. */
  303. register t_type *tp = BaseType(lb->nd_type);
  304. register t_type *res;
  305. if (tp == intorcard_type) {
  306. /* Lower bound >= 0; in this case, the base type is CARDINAL,
  307. according to the language definition, par. 6.3.
  308. But what if the upper-bound is of type INTEGER (f.i.
  309. MAX(INTEGER)? The Report does not answer this. Fix this
  310. for the time being, by making it an INTEGER subrange.
  311. ???
  312. */
  313. assert(lb->nd_INT >= 0);
  314. if (BaseType(ub->nd_type) == int_type ||
  315. (base && BaseType(base) == int_type)) tp = int_type;
  316. else tp = card_type;
  317. }
  318. if (!ChkCompat(&ub, tp, "subrange bounds")) {
  319. return error_type;
  320. }
  321. /* Check base type
  322. */
  323. if (! (tp->tp_fund & T_DISCRETE)) {
  324. node_error(lb, "illegal base type for subrange");
  325. return error_type;
  326. }
  327. /* Now construct resulting type
  328. */
  329. res = construct_type(T_SUBRANGE, tp);
  330. res->sub_lb = lb->nd_INT;
  331. res->sub_ub = ub->nd_INT;
  332. /* Check bounds
  333. */
  334. if (! chk_bounds(lb->nd_INT, ub->nd_INT, tp->tp_fund)) {
  335. node_error(lb, "lower bound exceeds upper bound");
  336. ub->nd_INT = lb->nd_INT;
  337. res->sub_ub = res->sub_lb;
  338. }
  339. if (tp == card_type) {
  340. u_small(res, res->sub_ub);
  341. }
  342. else if (tp == int_type) {
  343. if (fit(res->sub_lb, 1) && fit(res->sub_ub, 1)) {
  344. res->tp_size = 1;
  345. res->tp_align = 1;
  346. }
  347. else if (fit(res->sub_lb, (int)short_size) &&
  348. fit(res->sub_ub, (int)short_size)) {
  349. res->tp_size = short_size;
  350. res->tp_align = short_align;
  351. }
  352. }
  353. if (base) {
  354. if (base->tp_fund == T_SUBRANGE) {
  355. /* Check that the bounds of "res" fall within the range
  356. of "base".
  357. */
  358. if (! in_range(res->sub_lb, base) ||
  359. ! in_range(res->sub_ub, base)) {
  360. error("base type has insufficient range");
  361. }
  362. base = base->tp_next;
  363. }
  364. if ((base->tp_fund & (T_ENUMERATION|T_CHAR)) ||
  365. base == card_type) {
  366. if (res->tp_next != base) {
  367. error("specified basetype for subrange not compatible with bounds");
  368. }
  369. }
  370. else if (base == int_type) {
  371. if (res->tp_next == card_type &&
  372. ! chk_bounds(res->sub_ub,
  373. max_int[(int)int_size],
  374. T_CARDINAL)){
  375. error("upperbound too large for type INTEGER");
  376. }
  377. }
  378. else error("illegal base for a subrange");
  379. res->tp_next = base;
  380. }
  381. return res;
  382. }
  383. t_type *
  384. proc_type(result_type, parameters, n_bytes_params)
  385. t_type *result_type;
  386. t_param *parameters;
  387. arith n_bytes_params;
  388. {
  389. register t_type *tp = construct_type(T_PROCEDURE, result_type);
  390. tp->prc_params = parameters;
  391. tp->prc_nbpar = n_bytes_params;
  392. if (! fit(n_bytes_params, (int) word_size)) {
  393. error("maximum parameter byte count exceeded");
  394. }
  395. if (result_type && ! fit(WA(result_type->tp_size), (int) word_size)) {
  396. error("maximum return value size exceeded");
  397. }
  398. return tp;
  399. }
  400. genrck(tp)
  401. register t_type *tp;
  402. {
  403. /* generate a range check descriptor for type "tp" when
  404. neccessary. Return its label.
  405. */
  406. arith lb, ub;
  407. register label ol;
  408. arith size = tp->tp_size;
  409. extern char *long2str();
  410. register t_type *btp = BaseType(tp);
  411. if (size < word_size) size = word_size;
  412. getbounds(tp, &lb, &ub);
  413. if (tp->tp_fund == T_SUBRANGE) {
  414. if (!(ol = tp->sub_rck)) {
  415. tp->sub_rck = ++data_label;
  416. }
  417. }
  418. else if (!(ol = tp->enm_rck)) {
  419. tp->enm_rck = ++data_label;
  420. }
  421. if (!ol) {
  422. C_df_dlb(ol = data_label);
  423. C_rom_icon(long2str((long)lb,10), size);
  424. C_rom_icon(long2str((long)ub,10), size);
  425. }
  426. c_lae_dlb(ol);
  427. if (size <= word_size) {
  428. CAL(btp->tp_fund == T_INTEGER ? "rcki" : "rcku", (int) pointer_size);
  429. }
  430. else {
  431. CAL(btp->tp_fund == T_INTEGER ? "rckil" : "rckul", (int) pointer_size);
  432. }
  433. }
  434. getbounds(tp, plo, phi)
  435. register t_type *tp;
  436. arith *plo, *phi;
  437. {
  438. /* Get the bounds of a bounded type
  439. */
  440. assert(bounded(tp));
  441. if (tp->tp_fund == T_SUBRANGE) {
  442. *plo = tp->sub_lb;
  443. *phi = tp->sub_ub;
  444. }
  445. else {
  446. *plo = 0;
  447. *phi = tp->enm_ncst - 1;
  448. }
  449. }
  450. t_type *
  451. set_type(tp)
  452. register t_type *tp;
  453. {
  454. /* Construct a set type with base type "tp", but first
  455. perform some checks
  456. */
  457. arith lb, ub, diff, alloc_size;
  458. if (! bounded(tp) || tp->tp_size > word_size) {
  459. error("illegal base type for set");
  460. return error_type;
  461. }
  462. getbounds(tp, &lb, &ub);
  463. #ifndef NOSTRICT
  464. if (lb < 0) {
  465. warning(W_STRICT, "base type of set has negative lower bound");
  466. }
  467. #endif
  468. diff = ub - lb + 1;
  469. if (diff < 0) {
  470. error("set type limits exceeded");
  471. return error_type;
  472. }
  473. tp = construct_type(T_SET, tp);
  474. tp->tp_size = WA((diff + 7) >> 3);
  475. alloc_size = (tp->tp_size / word_size + 1) * sizeof(arith);
  476. tp->set_sz = alloc_size;
  477. if (tp->set_sz != alloc_size) {
  478. error("set size too large");
  479. return error_type;
  480. }
  481. tp->set_low = lb;
  482. return tp;
  483. }
  484. ArrayElSize(tp)
  485. register t_type *tp;
  486. {
  487. /* Align element size to alignment requirement of element type.
  488. Also make sure that its size is either a dividor of the word_size,
  489. or a multiple of it.
  490. */
  491. register arith algn;
  492. register t_type *elem_type = tp->arr_elem;
  493. if (elem_type->tp_fund == T_ARRAY) ArraySizes(elem_type);
  494. algn = align(elem_type->tp_size, elem_type->tp_align);
  495. if (word_size % algn != 0) {
  496. /* algn is not a dividor of the word size, so make sure it
  497. is a multiple
  498. */
  499. algn = WA(algn);
  500. }
  501. if (! fit(algn, (int) word_size)) {
  502. error("element size of array too large");
  503. }
  504. tp->arr_elsize = algn;
  505. if (tp->tp_align < elem_type->tp_align) {
  506. tp->tp_align = elem_type->tp_align;
  507. }
  508. }
  509. ArraySizes(tp)
  510. register t_type *tp;
  511. {
  512. /* Assign sizes to an array type, and check index type
  513. */
  514. register t_type *index_type = IndexType(tp);
  515. arith diff;
  516. ArrayElSize(tp);
  517. /* check index type
  518. */
  519. if (index_type->tp_size > word_size || ! bounded(index_type)) {
  520. error("illegal index type");
  521. tp->tp_size = tp->arr_elsize;
  522. return;
  523. }
  524. getbounds(index_type, &(tp->arr_low), &(tp->arr_high));
  525. diff = tp->arr_high - tp->arr_low;
  526. if (diff < 0 || ! fit(diff, (int) int_size)) {
  527. error("too many elements in array");
  528. }
  529. tp->tp_size = align((diff + 1) * tp->arr_elsize, tp->tp_align);
  530. /* ??? check overflow ??? */
  531. if (! ufit(tp->tp_size, (int) pointer_size)) {
  532. error("array too large");
  533. }
  534. /* generate descriptor and remember label.
  535. */
  536. tp->arr_descr = ++data_label;
  537. C_df_dlb(tp->arr_descr);
  538. C_rom_cst((arith) 0);
  539. C_rom_cst(diff);
  540. C_rom_cst(tp->arr_elsize);
  541. }
  542. FreeType(tp)
  543. register t_type *tp;
  544. {
  545. /* Release type structures indicated by "tp".
  546. This procedure is only called for types, constructed with
  547. T_PROCEDURE.
  548. */
  549. register t_param *pr, *pr1;
  550. assert(tp->tp_fund == T_PROCEDURE);
  551. pr = ParamList(tp);
  552. while (pr) {
  553. pr1 = pr;
  554. pr = pr->par_next;
  555. free_def(pr1->par_def);
  556. free_paramlist(pr1);
  557. }
  558. free_type(tp);
  559. }
  560. DeclareType(nd, df, tp)
  561. register t_def *df;
  562. register t_type *tp;
  563. t_node *nd;
  564. {
  565. /* A type with type-description "tp" is declared and must
  566. be bound to definition "df".
  567. This routine also handles the case that the type-field of
  568. "df" is already bound. In that case, it is either an opaque
  569. type, or an error message was given when "df" was created.
  570. */
  571. register t_type *df_tp = df->df_type;
  572. if (df_tp && df_tp->tp_fund == T_HIDDEN) {
  573. if (! (tp->tp_fund & (T_POINTER|T_HIDDEN|T_EQUAL))) {
  574. node_error(nd,
  575. "opaque type \"%s\" is not a pointer type",
  576. df->df_idf->id_text);
  577. }
  578. df_tp->tp_next = tp;
  579. df_tp->tp_fund = T_EQUAL;
  580. while (tp != df_tp && tp->tp_fund == T_EQUAL) {
  581. tp = tp->tp_next;
  582. }
  583. if (tp == df_tp) {
  584. /* Circular definition! */
  585. node_error(nd,
  586. "opaque type \"%s\" has a circular definition",
  587. df->df_idf->id_text);
  588. tp->tp_next = error_type;
  589. }
  590. }
  591. else {
  592. df->df_type = tp;
  593. if (BaseType(tp)->tp_fund == T_ENUMERATION) {
  594. CheckForImports(df);
  595. }
  596. }
  597. #ifdef DBSYMTAB
  598. if (options['g']) stb_string(df, D_TYPE);
  599. #endif
  600. SolveForwardTypeRefs(df);
  601. }
  602. SolveForwardTypeRefs(df)
  603. register t_def *df;
  604. {
  605. register t_node *nd;
  606. if (df->df_kind == D_FORWTYPE) {
  607. nd = df->df_forw_node;
  608. df->df_kind = D_TYPE;
  609. while (nd) {
  610. nd->nd_type->tp_next = df->df_type;
  611. #ifdef DBSYMTAB
  612. if (options['g'] && nd->nd_type->tp_dbindex < 0) {
  613. stb_addtp("(forward_type)", nd->nd_type);
  614. }
  615. #endif
  616. nd = nd->nd_RIGHT;
  617. }
  618. FreeNode(df->df_forw_node);
  619. }
  620. }
  621. ForceForwardTypeDef(df)
  622. register t_def *df;
  623. {
  624. register t_def *df1 = df, *df2;
  625. register t_node *nd = df->df_forw_node;
  626. while (df && df->df_kind == D_FORWTYPE) {
  627. RemoveFromIdList(df);
  628. if ((df2 = df->df_scope->sc_def) == df) {
  629. df->df_scope->sc_def = df->df_nextinscope;
  630. }
  631. else {
  632. while (df2->df_nextinscope != df) {
  633. df2 = df2->df_nextinscope;
  634. }
  635. df2->df_nextinscope = df->df_nextinscope;
  636. }
  637. df = df->df_forw_def;
  638. }
  639. while (nd->nd_class == Link) {
  640. nd = nd->nd_RIGHT;
  641. }
  642. df = lookfor(nd, CurrVis, 1, 0);
  643. if (! df->df_kind & (D_ERROR|D_TYPE)) {
  644. node_error(nd, "\"%s\" is not a type", df1->df_idf->id_text);
  645. }
  646. while (df1 && df1->df_kind == D_FORWTYPE) {
  647. df2 = df1->df_forw_def;
  648. df1->df_type = df->df_type;
  649. SolveForwardTypeRefs(df1);
  650. free_def(df1);
  651. df1 = df2;
  652. }
  653. }
  654. t_type *
  655. RemoveEqual(tpx)
  656. register t_type *tpx;
  657. {
  658. if (tpx) while (tpx->tp_fund == T_EQUAL) tpx = tpx->tp_next;
  659. return tpx;
  660. }
  661. int
  662. type_or_forward(tp)
  663. t_type *tp;
  664. {
  665. /* POINTER TO IDENTIFIER construction. The IDENTIFIER resides
  666. in "dot". This routine handles the different cases.
  667. */
  668. register t_node *nd;
  669. register t_def *df, *df1;
  670. if ((df1 = lookup(dot.TOK_IDF, CurrentScope, D_IMPORTED, D_USED))) {
  671. /* Either a Module or a Type, but in both cases defined
  672. in this scope, so this is the correct identification
  673. */
  674. switch(df1->df_kind) {
  675. case D_FORWARD:
  676. FreeNode(df1->for_node);
  677. df1->df_kind = D_FORWTYPE;
  678. df1->df_forw_node = 0;
  679. /* Fall through */
  680. case D_FORWTYPE:
  681. nd = dot2node(Link, NULLNODE, df1->df_forw_node);
  682. df1->df_forw_node = nd;
  683. nd->nd_type = tp;
  684. return 0;
  685. default:
  686. return 1;
  687. }
  688. }
  689. nd = dot2leaf(Name);
  690. if ((df1 = lookfor(nd, CurrVis, 0, D_USED))->df_kind == D_MODULE) {
  691. /* A Modulename in one of the enclosing scopes.
  692. It is not clear from the language definition that
  693. it is correct to handle these like this, but
  694. existing compilers do it like this, and the
  695. alternative is difficult with a lookahead of only
  696. one token.
  697. This path should actually only be taken if the next token
  698. is a '.'.
  699. ???
  700. */
  701. FreeNode(nd);
  702. return 1;
  703. }
  704. /* Enter a forward reference into a list belonging to the
  705. current scope. This is used for POINTER declarations, which
  706. may have forward references that must howewer be declared in the
  707. same scope.
  708. */
  709. df = define(nd->nd_IDF, CurrentScope, D_FORWTYPE);
  710. assert(df->df_kind == D_FORWTYPE);
  711. df->df_flags |= D_USED | D_DEFINED;
  712. nd->nd_type = tp;
  713. df->df_forw_node = nd;
  714. if (df != df1 && (df1->df_kind & (D_TYPE | D_FORWTYPE))) {
  715. /* "df1" refers to a possible identification, but
  716. we cannot be sure at this point. For the time
  717. being, however, we use this one.
  718. */
  719. df->df_type = df1->df_type;
  720. df->df_forw_def = df1;
  721. }
  722. return 0;
  723. }
  724. int
  725. gcd(m, n)
  726. register int m, n;
  727. {
  728. /* Greatest Common Divisor
  729. */
  730. register int r;
  731. while (n) {
  732. r = m % n;
  733. m = n;
  734. n = r;
  735. }
  736. return m;
  737. }
  738. int
  739. lcm(m, n)
  740. int m, n;
  741. {
  742. /* Least Common Multiple
  743. */
  744. return m * (n / gcd(m, n));
  745. }
  746. t_type *
  747. intorcard(left, right)
  748. register t_type *left, *right;
  749. {
  750. if (left->tp_fund == T_INTORCARD) {
  751. t_type *tmp = left;
  752. left = right;
  753. right = tmp;
  754. }
  755. if (right->tp_fund == T_INTORCARD) {
  756. if (left->tp_fund == T_INTEGER || left->tp_fund == T_CARDINAL) {
  757. return left;
  758. }
  759. }
  760. return 0;
  761. }
  762. #ifdef DEBUG
  763. DumpType(tp)
  764. register t_type *tp;
  765. {
  766. if (!tp) return;
  767. print("align:%d; size:%ld;", tp->tp_align, (long) tp->tp_size);
  768. print(" fund:");
  769. switch(tp->tp_fund) {
  770. case T_RECORD:
  771. print("RECORD");
  772. break;
  773. case T_ENUMERATION:
  774. print("ENUMERATION; ncst:%d", tp->enm_ncst); break;
  775. case T_INTEGER:
  776. print("INTEGER"); break;
  777. case T_CARDINAL:
  778. print("CARDINAL"); break;
  779. case T_REAL:
  780. print("REAL"); break;
  781. case T_HIDDEN:
  782. print("HIDDEN"); break;
  783. case T_EQUAL:
  784. print("EQUAL"); break;
  785. case T_POINTER:
  786. print("POINTER"); break;
  787. case T_CHAR:
  788. print("CHAR"); break;
  789. case T_WORD:
  790. print("WORD"); break;
  791. case T_SET:
  792. print("SET"); break;
  793. case T_SUBRANGE:
  794. print("SUBRANGE %ld-%ld", (long) tp->sub_lb, (long) tp->sub_ub);
  795. break;
  796. case T_PROCEDURE:
  797. {
  798. register t_param *par = ParamList(tp);
  799. print("PROCEDURE");
  800. if (par) {
  801. print("(");
  802. while(par) {
  803. if (IsVarParam(par)) print("VAR ");
  804. DumpType(TypeOfParam(par));
  805. par = par->par_next;
  806. }
  807. }
  808. break;
  809. }
  810. case T_ARRAY:
  811. print("ARRAY");
  812. print("; element:");
  813. DumpType(tp->arr_elem);
  814. print("; index:");
  815. DumpType(tp->tp_next);
  816. print(";");
  817. return;
  818. case T_STRING:
  819. print("STRING"); break;
  820. case T_INTORCARD:
  821. print("INTORCARD"); break;
  822. default:
  823. crash("DumpType");
  824. }
  825. if (tp->tp_next && tp->tp_fund != T_POINTER) {
  826. /* Avoid printing recursive types!
  827. */
  828. print(" next:(");
  829. DumpType(tp->tp_next);
  830. print(")");
  831. }
  832. print(";");
  833. }
  834. #endif