src/oberon-type-compat.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <stdarg.h>
   4 #include <ctype.h>
   5 #include <string.h>
   6 #include <assert.h>
   7 #include <stdbool.h>
   8 #include <math.h>
   9
  10 #include "../include/oberon.h"
  11
  12 #include "oberon-common.h"
  13 #include "oberon-internals.h"
  14 #include "oberon-type-compat.h"
  15
  16 bool
  17 oberon_is_array_type(oberon_type_t * t)
  18 {
  19         return t -> class == OBERON_TYPE_ARRAY;
  20 }
  21
  22 bool
  23 oberon_is_open_array(oberon_type_t * t)
  24 {
  25         /* Открытые массивы всегда размером 0 */
  26
  27         return oberon_is_array_type(t) && (t -> size == 0);
  28 }
  29
  30 bool
  31 oberon_is_real_type(oberon_type_t * t)
  32 {
  33         return t -> class == OBERON_TYPE_REAL;
  34 }
  35
  36 bool
  37 oberon_is_integer_type(oberon_type_t * t)
  38 {
  39         return t -> class == OBERON_TYPE_INTEGER;
  40 }
  41
  42 bool
  43 oberon_is_number_type(oberon_type_t * t)
  44 {
  45         return oberon_is_integer_type(t)
  46                 || oberon_is_real_type(t);
  47 }
  48
  49 bool
  50 oberon_is_char_type(oberon_type_t * t)
  51 {
  52         return t -> class == OBERON_TYPE_CHAR;
  53 }
  54
  55 bool
  56 oberon_is_set_type(oberon_type_t * t)
  57 {
  58         return t -> class == OBERON_TYPE_SET;
  59 }
  60
  61 bool
  62 oberon_is_string_type(oberon_type_t * t)
  63 {
  64         return t -> class == OBERON_TYPE_STRING;
  65 }
  66
  67 bool
  68 oberon_is_procedure_type(oberon_type_t * t)
  69 {
  70         return t -> class == OBERON_TYPE_PROCEDURE;
  71 }
  72
  73 bool
  74 oberon_is_record_type(oberon_type_t * t)
  75 {
  76         return t -> class == OBERON_TYPE_RECORD;
  77 }
  78
  79 bool
  80 oberon_is_pointer_type(oberon_type_t * t)
  81 {
  82         return t -> class == OBERON_TYPE_POINTER;
  83 }
  84
  85 bool
  86 oberon_is_pointer_to_record(oberon_type_t * t)
  87 {
  88         return oberon_is_pointer_type(t) && oberon_is_record_type(t -> base);
  89 }
  90
  91 bool
  92 oberon_is_boolean_type(oberon_type_t * t)
  93 {
  94         return t -> class == OBERON_TYPE_BOOLEAN;
  95 }
  96
  97 bool
  98 oberon_is_array_of_char_type(oberon_type_t * t)
  99 {
 100         return oberon_is_array_type(t) && oberon_is_char_type(t -> base);
 101 }
 102
 103 bool
 104 oberon_is_nil_type(oberon_type_t * t)
 105 {
 106         return t -> class == OBERON_TYPE_NIL;
 107 }
 108
 109 bool
 110 oberon_is_type_expr(oberon_expr_t * e)
 111 {
 112         return (e -> is_item) && (e -> item.mode == MODE_TYPE);
 113 }
 114
 115
 116
 117 bool
 118 oberon_is_some_types(oberon_type_t * a, oberon_type_t * b)
 119 {
 120         /* Две переменные a и b с типами Ta и Tb имеют одинаковый тип, если */
 121         /*   1. Ta и Tb оба обозначены одним и тем же идентификатором типа, или */
 122         /*   2. Ta объявлен равным Tb в объявлении типа вида Ta = Tb, или  */
 123         /*   3. a и b появляются в одном и том же списке идентификаторов переменных, полей записи */
 124         /*        или объявлении формальных параметров и не являются открытыми массивами. */
 125
 126         return (a == b) && !oberon_is_open_array(a) && !oberon_is_open_array(b);
 127 }
 128
 129 bool
 130 oberon_is_some_procedure_signatures(oberon_type_t * a, oberon_type_t * b)
 131 {
 132         /* Два списка формальных параметров совпадают если */
 133         /*  1. они имеют одинаковое количество параметров, и */
 134         /*  2. они имеют или одинаковый тип результата функции или не имеют никакого, и */
 135         /*  3. параметры в соответствующих позициях имеют равные типы, и */
 136         /*  4. параметры в соответствующих позициях - оба или параметры-значения */
 137         /*       или параметры-переменные. */
 138
 139         if(a -> num_decl != b -> num_decl)
 140         {
 141                 return false;
 142         }
 143
 144         if(!oberon_is_some_types(a -> base, b -> base))
 145         {
 146                 return false;
 147         }
 148
 149         int num = a -> num_decl;
 150         oberon_object_t * va = a -> decl;
 151         oberon_object_t * vb = b -> decl;
 152         for(int i = 0; i < num; i++)
 153         {
 154                 if(!oberon_is_equal_types(va -> type, vb -> type))
 155                 {
 156                         return false;
 157                 }
 158
 159                 if(va -> class != vb -> class)
 160                 {
 161                         return false;
 162                 }
 163
 164                 va = va -> next;
 165                 vb = vb -> next;
 166         }
 167
 168         return true;
 169 }
 170
 171 bool
 172 oberon_is_equal_types(oberon_type_t * a, oberon_type_t * b)
 173 {
 174         /* Два типа Ta, и Tb равны, если */
 175         /*  1. Ta и Tb - одинаковые типы, или */
 176         /*  2. Ta и Tb - типы открытый массив с равными типами элементов, или */
 177         /*  3. Ta и Tb - процедурные типы, чьи списки формальных параметров совпадают. */
 178
 179         return oberon_is_some_types(a, b)
 180                 || (oberon_is_open_array(a) && oberon_is_open_array(b) && oberon_is_some_types(a -> base, b -> base))
 181                 || (oberon_is_procedure_type(a) && oberon_is_procedure_type(b) && oberon_is_some_procedure_signatures(a, b));
 182 }
 183
 184 bool
 185 oberon_incluses_type(oberon_type_t * a, oberon_type_t * b)
 186 {
 187         /* a поглощает b */
 188         /* LONGREAL >= REAL >= LONGINT >= INTEGER >= SHORTINT  */
 189
 190 /*
 191         printf("oberon_incluses_type: a %i %i\n", a -> class, a -> size);
 192         printf("oberon_incluses_type: b %i %i\n", b -> class, b -> size);
 193 */
 194
 195         if(a -> class == OBERON_TYPE_REAL)
 196         {
 197                 if(b -> class == OBERON_TYPE_INTEGER)
 198                 {
 199                         return true;
 200                 }
 201                 else if(b -> class == OBERON_TYPE_REAL)
 202                 {
 203                         return (a -> size >= b -> size);
 204                 }
 205         }
 206         else if(a -> class == OBERON_TYPE_INTEGER)
 207         {
 208                 if(b -> class == OBERON_TYPE_INTEGER)
 209                 {
 210                         return (a -> size >= b -> size);
 211                 }
 212         }
 213
 214         return false;
 215 }
 216
 217 bool
 218 oberon_extension_of(oberon_type_t * ext, oberon_type_t * rec)
 219 {
 220         /* Тип Tb есть расширение типа Ta (Ta есть базовый тип Tb) если */
 221         /*  1. Ta и Tb - одинаковые типы, или */
 222         /*  2. Tb - непосредственное расширение типа, являющегося расширением Ta */
 223         /*  Если Pa = POINTER TO Ta и Pb = POINTER TO Tb, то Pb есть расширение Pa */
 224         /*    (Pa есть базовый тип Pb), если Tb есть расширение Ta. */
 225
 226         if(ext -> class == OBERON_TYPE_POINTER && rec -> class == OBERON_TYPE_POINTER)
 227         {
 228                 ext = ext -> base;
 229                 rec = rec -> base;
 230         }
 231
 232         if(ext -> class != OBERON_TYPE_RECORD || rec -> class != OBERON_TYPE_RECORD)
 233         {
 234                 return false;
 235         }
 236
 237         if(oberon_is_some_types(ext, rec))
 238         {
 239                 return true;
 240         }
 241
 242         while(rec -> base)
 243         {
 244                 if(oberon_is_some_types(ext, rec -> base))
 245                 {
 246                         return true;
 247                 }
 248                 rec = rec -> base;
 249         }
 250
 251         return false;
 252 }
 253
 254 bool
 255 oberon_is_const_string(oberon_expr_t * e)
 256 {
 257         return e -> result -> class == OBERON_TYPE_STRING && e -> is_item && e -> item.mode == MODE_STRING;
 258 }
 259
 260 bool
 261 oberon_is_assignment_compatible_expressions(oberon_expr_t * e, oberon_type_t * Tv)
 262 {
 263         /* Выражение e типа Te совместимо по присваиванию с переменной v типа Tv, */
 264         /* если выполнено одно из следующих условий: */
 265         /*   1. Te и Tv - одинаковые типы; */
 266         /*   2. Te и Tv - числовые типы и Tv поглощает Te; */
 267         /*   3. Te и Tv - типы запись, Te есть расширение Tv, а v имеет динамический тип Tv; */
 268         /*   4. Te и Tv - типы указатель и Te - расширение Tv; */
 269         /*   5. Tv - тип указатель или процедурный тип, а e - NIL; */
 270         /*   6. Tv - ARRAY n OF CHAR, e - строковая константа из m символов и m < n; */
 271         /*   7. Tv - процедурный тип, а e - имя процедуры, чьи формальные параметры */
 272         /*      совпадают с параметрами Tv. */
 273         /* Доп: Tv - символ, е - строковая константа из одного символа */
 274
 275         oberon_type_t * Te = e -> result;
 276
 277 /*
 278         printf("<<< oberon_is_assignment_compatible_expressions ===\n");
 279         printf(": Te -> class == %i\n", Te -> class);
 280         printf(": Tv -> class == %i\n", Tv -> class);
 281         printf(":: oberon_is_some_types(Te, Tv) == %i\n", oberon_is_some_types(Te, Tv));
 282         printf("::: oberon_is_number_type(Te) == %i\n", oberon_is_number_type(Te));
 283         printf("::: oberon_is_number_type(Tv) == %i\n", oberon_is_number_type(Tv));
 284         printf("::: oberon_incluses_type(Tv, Te) == %i\n", oberon_incluses_type(Tv, Te));
 285         printf(":::: oberon_is_record_type(Te) == %i\n", oberon_is_record_type(Te));
 286         printf(":::: oberon_is_record_type(Tv) == %i\n", oberon_is_record_type(Tv));
 287 //      printf(":::: oberon_extension_of(Te, Tv) == %i\n", oberon_extension_of(Te, Tv));
 288         printf(":::: oberon_extension_of(Tv, Te) == %i\n", oberon_extension_of(Tv, Te));
 289         printf("=== oberon_is_assignment_compatible_expressions >>>\n");
 290 */
 291
 292         return oberon_is_some_types(Te, Tv)
 293                 || (oberon_is_number_type(Te) && oberon_is_number_type(Tv) && oberon_incluses_type(Tv, Te))
 294                 || (oberon_is_record_type(Te) && oberon_is_record_type(Tv) && oberon_extension_of(Tv, Te))
 295                 || (oberon_is_pointer_type(Te) && oberon_is_pointer_type(Tv) && oberon_extension_of(Tv, Te))
 296                 || ((oberon_is_pointer_type(Tv) || oberon_is_procedure_type(Tv)) && oberon_is_nil_type(Te))
 297                 || (oberon_is_array_of_char_type(Tv) && !oberon_is_open_array(Tv) && oberon_is_const_string(e) && (strlen(e -> item.string) < Tv -> size))
 298                 || (oberon_is_procedure_type(Tv) && e -> is_item && e -> item.var -> class == OBERON_CLASS_PROC && oberon_is_some_procedure_signatures(Tv, e -> result))
 299                 || (oberon_is_char_type(Tv) && oberon_is_const_string(e) && strlen(e -> item.string) == 1);
 300 }
 301
 302 static bool
 303 oberon_is_compatible_arrays_types(oberon_type_t * Tf, oberon_type_t * Ta)
 304 {
 305         /* Фактический параметр a типа Ta является совместимым массивом для формального параметра f типа Tf если */
 306         /*   1. Tf и Ta - одинаковые типы или */
 307         /*   2. Tf - открытый массив, Ta - любой массив, а типы их элементов - совместимые массивы или */
 308         /*   3. f - параметр-значение типа ARRAY OF CHAR, а фактический параметр a - строка. */
 309
 310         return oberon_is_some_types(Tf, Ta)
 311                 || (oberon_is_open_array(Tf) && oberon_is_array_type(Ta) && oberon_is_compatible_arrays_types(Tf -> base, Ta -> base));
 312 }
 313
 314 bool
 315 oberon_is_compatible_arrays(oberon_object_t * f, oberon_expr_t * a)
 316 {
 317         oberon_type_t * Tf = f -> type;
 318         oberon_type_t * Ta = a -> result;
 319
 320         return oberon_is_compatible_arrays_types(Tf, Ta)
 321                 || (oberon_is_array_of_char_type(Tf) && oberon_is_const_string(a));
 322 }
 323
 324 void
 325 oberon_check_compatible_arrays(oberon_context_t * ctx, oberon_object_t * f, oberon_expr_t * a)
 326 {
 327         if(!oberon_is_compatible_arrays(f, a))
 328         {
 329                 oberon_error(ctx, "incompatible types");
 330         }
 331 }
 332
 333 bool
 334 oberon_is_compatible_bin_expr_types(int token, oberon_type_t * a, oberon_type_t * b)
 335 {
 336         if(token == PLUS || token == MINUS || token == STAR || token == SLASH)
 337         {
 338                 if(oberon_is_number_type(a) && oberon_is_number_type(b))
 339                 {
 340                         return true;
 341                 }
 342                 else if(oberon_is_set_type(a) && oberon_is_set_type(b))
 343                 {
 344                         return true;
 345                 }
 346         }
 347         else if(token == DIV || token == MOD)
 348         {
 349                 if(oberon_is_integer_type(a) && oberon_is_integer_type(b))
 350                 {
 351                         return true;
 352                 }
 353         }
 354         else if(token == OR || token == AND)
 355         {
 356                 if(oberon_is_boolean_type(a) && oberon_is_boolean_type(b))
 357                 {
 358                         return true;
 359                 }
 360         }
 361         else if(token == EQUAL || token == NEQ)
 362         {
 363                 if(oberon_is_number_type(a) && oberon_is_number_type(b))
 364                 {
 365                         return true;
 366                 }
 367                 else if(oberon_is_char_type(a) && oberon_is_char_type(b))
 368                 {
 369                         return true;
 370                 }
 371                 else if((oberon_is_array_of_char_type(a) || oberon_is_string_type(a))
 372                         && (oberon_is_array_of_char_type(b) || oberon_is_string_type(b)))
 373                 {
 374                         return true;
 375                 }
 376                 else if(oberon_is_boolean_type(a) && oberon_is_boolean_type(b))
 377                 {
 378                         return true;
 379                 }
 380                 else if(oberon_is_set_type(a) && oberon_is_set_type(b))
 381                 {
 382                         return true;
 383                 }
 384                 else if((oberon_is_nil_type(a) || oberon_is_pointer_to_record(a) || oberon_is_procedure_type(a))
 385                         && (oberon_is_nil_type(b) || oberon_is_pointer_to_record(b) || oberon_is_procedure_type(b)))
 386                 {
 387                         return true;
 388                 }
 389         }
 390         else if(token == LESS || token == LEQ || token == GREAT || token == GEQ)
 391         {
 392                 if(oberon_is_number_type(a) && oberon_is_number_type(b))
 393                 {
 394                         return true;
 395                 }
 396                 else if(oberon_is_char_type(a) && oberon_is_char_type(b))
 397                 {
 398                         return true;
 399                 }
 400                 else if((oberon_is_array_of_char_type(a) || oberon_is_string_type(a))
 401                         && (oberon_is_array_of_char_type(b) || oberon_is_string_type(b)))
 402                 {
 403                         return true;
 404                 }
 405         }
 406         else if(token == IN)
 407         {
 408                 if(oberon_is_integer_type(a) && oberon_is_set_type(b))
 409                 {
 410                         return true;
 411                 }
 412         }
 413         else if(token == IS)
 414         {
 415                 if(oberon_extension_of(a, b))
 416                 {
 417                         return true;
 418                 }
 419         }
 420
 421         return false;
 422 }
 423
 424 bool
 425 oberon_is_compatible_var_param(oberon_type_t * Tf, oberon_type_t * Ta)
 426 {
 427         /* Пусть Tf - тип формального параметра f (не открытого массива) */
 428         /* и Ta - тип соответствующего фактического параметра a. */
 429         /* Для параметров-переменных Ta и Tf должны быть одинаковыми типами */
 430         /* или Tf должен быть типом запись, а Ta - расширением Tf. */
 431
 432         return oberon_is_some_types(Tf, Ta)
 433                 || (oberon_is_record_type(Tf) && oberon_extension_of(Ta, Tf));
 434 }
 435
 436 void
 437 oberon_check_compatible_var_param(oberon_context_t * ctx, oberon_type_t * Tf, oberon_type_t * Ta)
 438 {
 439         if(!oberon_is_compatible_var_param(Tf, Ta))
 440         {
 441                 oberon_error(ctx, "incompatible types");
 442         }
 443 }
 444
 445 void
 446 oberon_check_type_expr(oberon_context_t * ctx, oberon_expr_t * e)
 447 {
 448         if(!oberon_is_type_expr(e))
 449         {
 450                 oberon_error(ctx, "expected type");
 451         }
 452 }
 453
 454 void
 455 oberon_check_compatible_bin_expr_types(oberon_context_t * ctx, int token, oberon_type_t * a, oberon_type_t * b)
 456 {
 457         if(!oberon_is_compatible_bin_expr_types(token, a, b))
 458         {
 459                 oberon_error(ctx, "incompatibe expression types");
 460         }
 461 }
 462
 463 void
 464 oberon_check_assignment_compatible(oberon_context_t * ctx, oberon_expr_t * e, oberon_type_t * Tv)
 465 {
 466         if(!oberon_is_assignment_compatible_expressions(e, Tv))
 467         {
 468                 oberon_error(ctx, "incompatible types");
 469         }
 470 }
 471
 472 void
 473 oberon_check_extension_of(oberon_context_t * ctx, oberon_type_t * ext, oberon_type_t * rec)
 474 {
 475         if(!oberon_extension_of(ext, rec))
 476         {
 477                 oberon_error(ctx, "not extension");
 478         }
 479 }
 480
 481 oberon_type_t *
 482 oberon_get_longer_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
 483 {
 484         if(oberon_incluses_type(a, b))
 485         {
 486                 return a;
 487         }
 488         else if(oberon_incluses_type(b, a))
 489         {
 490                 return b;
 491         }
 492         else
 493         {
 494                 oberon_error(ctx, "oberon_get_longer_type: error");
 495                 return NULL;
 496         }
 497 }
 498
 499 oberon_type_t *
 500 oberon_get_longer_real_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
 501 {
 502         oberon_type_t * result = oberon_get_longer_type(ctx, a, b);
 503         if(oberon_is_integer_type(result))
 504         {
 505                 return ctx -> real_type;
 506         }
 507         else if(oberon_is_real_type(result))
 508         {
 509                 return result;
 510         }
 511         else
 512         {
 513                 oberon_error(ctx, "oberon_get_longer_real_type: error");
 514                 return NULL;
 515         }
 516 }