lang/pc/comp/typequiv.c

   1 /* T Y P E   E Q U I V A L E N C E */
   2
   3 /*      Routines for testing type equivalence & type compatibility.
   4 */
   5
   6 #include        "debug.h"
   7
   8 #include        <assert.h>
   9 #include        <em_arith.h>
  10 #include        <em_label.h>
  11
  12 #include        "LLlex.h"
  13 #include        "def.h"
  14 #include        "node.h"
  15 #include        "type.h"
  16
  17
  18 int
  19 TstTypeEquiv(tp1, tp2)
  20         register struct type *tp1, *tp2;
  21 {
  22         /*      test if two types are equivalent.
  23         */
  24         return tp1 == tp2 || tp1 == error_type || tp2 == error_type;
  25 }
  26
  27 arith
  28 IsString(tp)
  29         register struct type *tp;
  30 {
  31         /* string = packed array[1..ub] of char and ub > 1 */
  32         if( tp->tp_fund & T_STRINGCONST ) return tp->tp_psize;
  33
  34         if( IsConformantArray(tp) ) return 0;
  35
  36         if( tp->tp_fund & T_ARRAY && IsPacked(tp) &&
  37                                         tp->arr_elem == char_type )     {
  38                 arith lb, ub;
  39
  40                 if( BaseType(IndexType(tp)) != int_type ) return 0;
  41                 getbounds(IndexType(tp), &lb, &ub);
  42                 return (lb == 1 && ub > 1) ? ub : (arith) 0;
  43         }
  44         return (arith) 0;
  45 }
  46
  47 int
  48 TstStrCompat(tp1, tp2)
  49         register struct type *tp1, *tp2;
  50 {
  51         /*      test if two types are compatible string-types.
  52         */
  53
  54         arith ub1, ub2;
  55
  56         ub1 = IsString(tp1);
  57         ub2 = IsString(tp2);
  58
  59         if( !ub1 || !ub2 ) return 0;
  60         else
  61                 return ub1 == ub2;
  62 }
  63
  64 int
  65 TstCompat(tp1, tp2)
  66         register struct type *tp1, *tp2;
  67 {
  68         /*      test if two types are compatible. ISO 6.4.5
  69         */
  70
  71         /* clause a */
  72         if( TstTypeEquiv(tp1, tp2) ) return 1;
  73
  74         /* clause d */
  75         if( TstStrCompat(tp1, tp2) ) return 1;
  76
  77         /* type of NIL is compatible with every pointertype */
  78         if( tp1->tp_fund & T_POINTER && tp2->tp_fund & T_POINTER )
  79                 return tp1 == tp2 || tp1 == nil_type || tp2 == nil_type;
  80
  81         /* clause c */
  82         /* if both types are sets then both must be packed or not */
  83         if( tp1->tp_fund & T_SET && tp2->tp_fund & T_SET )      {
  84                 if( tp1 == emptyset_type || tp2 == emptyset_type )
  85                         return 1;
  86                 if( IsPacked(tp1) != IsPacked(tp2) )
  87                         return 0;
  88                 if( TstCompat(ElementType(tp1), ElementType(tp2)) )     {
  89                         /*
  90                         if( ElementType(tp1) != ElementType(tp2) )
  91                                 warning("base-types of sets not equal");
  92                         */
  93                         return 1;
  94                 }
  95                 else return 0;
  96         }
  97
  98         /* no clause, just check for longs and ints */
  99         /* BaseType is used in case of array indexing */
 100         if ((BaseType(tp1) == int_type && tp2 == long_type) ||
 101                         (tp1 == long_type && BaseType(tp2) == int_type))
 102                 return 1;
 103
 104
 105         /* clause b */
 106         tp1 = BaseType(tp1);
 107         tp2 = BaseType(tp2);
 108
 109         return tp1 == tp2;
 110 }
 111
 112 int
 113 TstAssCompat(tp1, tp2)
 114         register struct type *tp1, *tp2;
 115 {
 116         /*      test if two types are assignment compatible. ISO 6.4.6
 117         */
 118
 119         /* clauses a, c, d and e */
 120         if( TstCompat(tp1, tp2) )
 121                 return !(tp1->tp_flags & T_HASFILE);
 122
 123         /* clause b */
 124         if( tp1 == real_type )
 125                 return BaseType(tp2) == int_type || BaseType(tp2) == long_type;
 126
 127         return 0;
 128 }
 129
 130 int
 131 TstParEquiv(tp1, tp2)
 132         register struct type *tp1, *tp2;
 133 {
 134         /*      Test if two parameter types are equivalent.  ISO 6.6.3.6
 135         */
 136
 137         return
 138                    TstTypeEquiv(tp1, tp2)
 139                 ||
 140                    (
 141                      IsConformantArray(tp1)
 142                    &&
 143                      IsConformantArray(tp2)
 144                    &&
 145                      IsPacked(tp1) == IsPacked(tp2)
 146                    &&
 147                      TstParEquiv(tp1->arr_elem, tp2->arr_elem)
 148                    )
 149                 ||
 150                    (
 151                      (
 152                       tp1->tp_fund == T_PROCEDURE && tp2->tp_fund == T_PROCEDURE
 153                      ||
 154                       tp1->tp_fund == T_FUNCTION && tp2->tp_fund == T_FUNCTION
 155                      )
 156                    &&
 157                      TstProcEquiv(tp1, tp2)
 158                    );
 159 }
 160
 161 int
 162 TstProcEquiv(tp1, tp2)
 163         register struct type *tp1, *tp2;
 164 {
 165         /*      Test if two procedure types are equivalent. ISO 6.6.3.6
 166         */
 167         register struct paramlist *p1, *p2;
 168
 169         /* First check if the result types are equivalent
 170         */
 171         if( !TstTypeEquiv(ResultType(tp1), ResultType(tp2)) )
 172                 return 0;
 173
 174         p1 = ParamList(tp1);
 175         p2 = ParamList(tp2);
 176
 177         /* Now check the parameters
 178         */
 179         while( p1 && p2 )       {
 180                 if( IsVarParam(p1) != IsVarParam(p2) ||
 181                     !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2)) ) return 0;
 182                 p1 = p1->next;
 183                 p2 = p2->next;
 184         }
 185
 186         /* Here, at least one of the parameterlists is exhausted.
 187            Check that they are both.
 188         */
 189         return p1 == p2;
 190 }
 191
 192 int
 193 TstParCompat(formaltype, actualtype, VARflag, nd, new_par_section)
 194         register struct type *formaltype, *actualtype;
 195         struct node *nd;
 196 {
 197         /*      Check type compatibility for a parameter in a procedure call.
 198         */
 199
 200         if(
 201                 TstTypeEquiv(formaltype, actualtype)
 202             ||
 203                 ( !VARflag && TstAssCompat(formaltype, actualtype) )
 204             ||
 205                 (  formaltype->tp_fund == T_FUNCTION
 206                  &&
 207                    actualtype->tp_fund == T_FUNCTION
 208                  &&
 209                    TstProcEquiv(formaltype, actualtype)
 210                 )
 211             ||
 212                 (  formaltype->tp_fund == T_PROCEDURE
 213                  &&
 214                    actualtype->tp_fund == T_PROCEDURE
 215                  &&
 216                    TstProcEquiv(formaltype, actualtype)
 217                 )
 218             ||
 219                 (  IsConformantArray(formaltype)
 220                 &&
 221                    TstConform(formaltype, actualtype, new_par_section)
 222                 )
 223         ) {
 224                 if( !VARflag && IsConformantArray(actualtype) ) {
 225                         node_warning(nd,
 226                                 "conformant array used as value parameter");
 227                 }
 228                 return 1;
 229         }
 230         else return 0;
 231 }
 232
 233 int
 234 TstConform(formaltype, actualtype, new_par_section)
 235         register struct type *formaltype, *actualtype;
 236 {
 237         /*      Check conformability.
 238
 239                 DEVIATION FROM STANDARD (ISO 6.6.3.7.2):
 240                 Allow with value parameters also conformant arrays as actual
 241                 type.(ISO only with var. parameters)
 242
 243                 Do as much checking on indextypes as possible.
 244         */
 245
 246         struct type *formalindextp, *actualindextp;
 247         arith flb, fub, alb, aub;
 248         static struct type *lastactual;
 249
 250         if( !new_par_section )
 251                 /* actualparameters of one conformant-array-specification
 252                    must be equal
 253                 */
 254                 return TstTypeEquiv(actualtype, lastactual);
 255
 256         lastactual = actualtype;
 257
 258         if( actualtype->tp_fund == T_STRINGCONST )      {
 259                 actualindextp = int_type;
 260                 alb = 1;
 261                 aub = actualtype->tp_psize;
 262         }
 263         else if( actualtype->tp_fund == T_ARRAY )       {
 264                 actualindextp = IndexType(actualtype);
 265                 if( bounded(actualindextp) )
 266                         getbounds(actualindextp, &alb, &aub);
 267         }
 268         else
 269                 return 0;
 270
 271         /* clause (d) */
 272         if( IsPacked(actualtype) != IsPacked(formaltype) )
 273                 return 0;
 274
 275         formalindextp = IndexType(formaltype);
 276
 277         /* clause (a) */
 278         if( !TstCompat(actualindextp, formalindextp) )
 279                 return 0;
 280
 281         /* clause (b) */
 282         if( bounded(actualindextp) ||
 283                         actualindextp->tp_fund == T_STRINGCONST ) {
 284                 /* test was necessary because the actual type could be confor-
 285                    mant !!
 286                 */
 287                 if( bounded(formalindextp) )    {
 288                         getbounds(formalindextp, &flb, &fub);
 289                         if( alb < flb || aub > fub )
 290                                 return 0;
 291                 }
 292         }
 293
 294         /* clause (c) */
 295         if( !IsConformantArray(formaltype->arr_elem) )
 296                 return TstTypeEquiv(actualtype->arr_elem, formaltype->arr_elem);
 297         else
 298                 return TstConform(formaltype->arr_elem, actualtype->arr_elem,
 299                                                                new_par_section);
 300 }