lang/pc/comp/type.c

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