lang/m2/comp/typequiv.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   E Q U I V A L E N C E */
   9
  10 /* $Id: typequiv.c,v 1.40 1996/08/14 07:42:40 ceriel Exp $ */
  11
  12 /*      Routines for testing type equivalence, type compatibility, and
  13         assignment compatibility
  14 */
  15 #include        "debug.h"
  16
  17 #include        <em_arith.h>
  18 #include        <em_label.h>
  19 #include        <assert.h>
  20
  21 #include        "strict3rd.h"
  22 #include        "type.h"
  23 #include        "LLlex.h"
  24 #include        "idf.h"
  25 #include        "def.h"
  26 #include        "node.h"
  27 #include        "warning.h"
  28 #include        "main.h"
  29 #include        "Lpars.h"
  30
  31 extern char *sprint();
  32
  33 int
  34 TstTypeEquiv(tp1, tp2)
  35         t_type *tp1, *tp2;
  36 {
  37         /*      test if two types are equivalent.
  38         */
  39
  40         return     tp1 == tp2
  41                 ||
  42                    tp1 == error_type
  43                 ||
  44                    tp2 == error_type;
  45 }
  46
  47 int
  48 TstParEquiv(tp1, tp2)
  49         register t_type *tp1, *tp2;
  50 {
  51         /*      test if two parameter types are equivalent. This routine
  52                 is used to check if two different procedure declarations
  53                 (one in the definition module, one in the implementation
  54                 module) are equivalent. A complication comes from dynamic
  55                 arrays.
  56         */
  57
  58         return
  59                    TstTypeEquiv(tp1, tp2)
  60                 ||
  61                    (
  62                      IsConformantArray(tp1)
  63                    &&
  64                      IsConformantArray(tp2)
  65                    &&
  66                      TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
  67                    );
  68 }
  69
  70 int
  71 TstProcEquiv(tp1, tp2)
  72         t_type *tp1, *tp2;
  73 {
  74         /*      Test if two procedure types are equivalent. This routine
  75                 may also be used for the testing of assignment compatibility
  76                 between procedure variables and procedures.
  77         */
  78         register t_param *p1, *p2;
  79
  80         /* First check if the result types are equivalent
  81         */
  82         if (! TstTypeEquiv(ResultType(tp1), ResultType(tp2))) return 0;
  83
  84         p1 = ParamList(tp1);
  85         p2 = ParamList(tp2);
  86
  87         /* Now check the parameters
  88         */
  89         while (p1 && p2) {
  90                 if (IsVarParam(p1) != IsVarParam(p2) ||
  91                     !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2))) return 0;
  92                 p1 = p1->par_next;
  93                 p2 = p2->par_next;
  94         }
  95
  96         /* Here, at least one of the parameterlists is exhausted.
  97            Check that they are both.
  98         */
  99         return p1 == p2;
 100 }
 101
 102 int
 103 TstCompat(tp1, tp2)
 104         register t_type *tp1, *tp2;
 105 {
 106         /*      test if two types are compatible. See section 6.3 of the
 107                 Modula-2 Report for a definition of "compatible".
 108         */
 109
 110         if (TstTypeEquiv(tp1, tp2)) return 1;
 111
 112         tp1 = BaseType(tp1);
 113         tp2 = BaseType(tp2);
 114         if (tp2->tp_fund != T_INTORCARD &&
 115             (tp1->tp_fund == T_INTORCARD || tp1 == address_type)) {
 116                 t_type *tmp = tp2;
 117
 118                 tp2 = tp1;
 119                 tp1 = tmp;
 120         }
 121
 122         return  tp1 == tp2
 123             ||
 124                 (  tp2 == intorcard_type
 125                 &&
 126                    (tp1 == int_type || tp1 == card_type || tp1 == address_type)
 127                 )
 128             ||
 129                 (  tp2 == longintorcard_type
 130                 &&
 131                    (tp1 == longint_type || tp1 == longcard_type || tp1 == address_type)
 132                 )
 133             ||
 134                 (  tp2 == address_type
 135                 &&
 136                   ( tp1->tp_fund == T_CARDINAL || tp1->tp_fund == T_POINTER)
 137                 )
 138         ;
 139 }
 140
 141 int
 142 TstAssCompat(tp1, tp2)
 143         register t_type *tp1, *tp2;
 144 {
 145         /*      Test if two types are assignment compatible.
 146                 See Def 9.1.
 147         */
 148
 149         if (TstCompat(tp1, tp2)) return 1;
 150
 151         tp1 = BaseType(tp1);
 152         tp2 = BaseType(tp2);
 153
 154         if (((tp1->tp_fund & T_INTORCARD) || tp1 == address_type) &&
 155             ((tp2->tp_fund & T_INTORCARD) || tp2 == address_type)) return 1;
 156
 157         if ((tp1->tp_fund == T_REAL) &&
 158             (tp2->tp_fund == T_REAL)) return 1;
 159
 160         if (tp1->tp_fund == T_PROCEDURE &&
 161             tp2->tp_fund == T_PROCEDURE) {
 162                 return TstProcEquiv(tp1, tp2);
 163         }
 164
 165         if (tp1->tp_fund == T_ARRAY) {
 166                 /* check for string
 167                 */
 168                 if (IsConformantArray(tp1)) return 0;
 169
 170                 return
 171                         BaseType(tp1->arr_elem) == char_type
 172                     &&  tp2->tp_fund  == T_STRING
 173                     &&  (tp1->arr_high - tp1->arr_low + 1) >= tp2->tp_size
 174                         ;
 175         }
 176
 177         return 0;
 178 }
 179
 180 char *
 181 incompat(tp1, tp2)
 182         register t_type *tp1, *tp2;
 183 {
 184
 185         if (tp1->tp_fund == T_HIDDEN || tp2->tp_fund == T_HIDDEN) {
 186                 return "properties of opaque type are hidden; illegal use";
 187         }
 188         return "type incompatibility";
 189 }
 190
 191 int
 192 TstParCompat(parno, formaltype, VARflag, nd, edf)
 193         register t_type *formaltype;
 194         t_node **nd;
 195         t_def *edf;
 196 {
 197         /*      Check type compatibility for a parameter in a procedure call.
 198                 Assignment compatibility may do if the parameter is
 199                 a value parameter.
 200                 Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
 201                 may do too.
 202                 Or: a WORD may do.
 203         */
 204         register t_type *actualtype = (*nd)->nd_type;
 205         char ebuf[256];
 206
 207         if (edf) {
 208                 sprint(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno);
 209         }
 210         else sprint(ebuf, "parameter %d: %%s", parno);
 211
 212         if (
 213                 TstTypeEquiv(formaltype, actualtype)
 214             ||
 215                 ( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0))
 216             ||
 217                 (  formaltype == address_type
 218                 && actualtype->tp_fund == T_POINTER
 219                 )
 220             ||
 221                 (  formaltype == word_type
 222                 &&
 223                    (  actualtype->tp_size == word_size
 224                    ||
 225                       (  !VARflag
 226                       &&
 227                          actualtype->tp_size <= word_size
 228                       &&
 229                          ! IsConformantArray(actualtype)
 230                       )
 231                    )
 232                 )
 233             ||
 234                 (  formaltype == byte_type
 235                 && actualtype->tp_size == (arith) 1
 236                 )
 237             ||
 238                 (  IsConformantArray(formaltype)
 239                 &&
 240                    (  formaltype->arr_elem == word_type
 241                    || formaltype->arr_elem == byte_type
 242                    ||
 243                       (  actualtype->tp_fund == T_ARRAY
 244                       && TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)
 245                       )
 246                    ||
 247                       (  actualtype->tp_fund == T_STRING
 248                       && TstTypeEquiv(formaltype->arr_elem, char_type)
 249                       )
 250                    )
 251                 )
 252         )
 253                 return 1;
 254 #ifndef STRICT_3RD_ED
 255         if (! options['3'] && VARflag && TstCompat(formaltype, actualtype)) {
 256                 if (formaltype->tp_size == actualtype->tp_size) {
 257                         node_warning(*nd,
 258                                      W_OLDFASHIONED,
 259                                      ebuf,
 260                                      "identical types required");
 261                         return 1;
 262                 }
 263                 node_error(*nd, ebuf, "equal sized types required");
 264                 return 0;
 265         }
 266 #endif
 267         node_error(*nd, ebuf, incompat(formaltype, actualtype));
 268         return 0;
 269 }
 270
 271 CompatCheck(nd, tp, message, fc)
 272         register t_node **nd;
 273         t_type *tp;
 274         char *message;
 275         int (*fc)();
 276 {
 277         if (! (*fc)(tp, (*nd)->nd_type)) {
 278                 if (message) {
 279                         node_error(*nd, "%s in %s",
 280                                         incompat(tp, (*nd)->nd_type),
 281                                         message);
 282                 }
 283                 return 0;
 284         }
 285         MkCoercion(nd, tp);
 286         return 1;
 287 }
 288
 289 ChkAssCompat(nd, tp, message)
 290         t_node **nd;
 291         t_type *tp;
 292         char *message;
 293 {
 294         /*      Check assignment compatibility of node "nd" with type "tp".
 295                 Give an error message when it fails
 296         */
 297
 298         if ((*nd)->nd_symb == STRING) {
 299                 TryToString((*nd), tp);
 300         }
 301         return CompatCheck(nd, tp, message, TstAssCompat);
 302 }
 303
 304 ChkCompat(nd, tp, message)
 305         t_node **nd;
 306         t_type *tp;
 307         char *message;
 308 {
 309         /*      Check compatibility of node "nd" with type "tp".
 310                 Give an error message when it fails
 311         */
 312
 313         return CompatCheck(nd, tp, message, TstCompat);
 314 }