lang/m2/comp/type.c

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