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