oberon.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
   8 #include "oberon.h"
   9 #include "generator.h"
  10
  11 enum {
  12         EOF_ = 0,
  13         IDENT,
  14         MODULE,
  15         SEMICOLON,
  16         END,
  17         DOT,
  18         VAR,
  19         COLON,
  20         BEGIN,
  21         ASSIGN,
  22         INTEGER,
  23         TRUE,
  24         FALSE,
  25         LPAREN,
  26         RPAREN,
  27         EQUAL,
  28         NEQ,
  29         LESS,
  30         LEQ,
  31         GREAT,
  32         GEQ,
  33         PLUS,
  34         MINUS,
  35         OR,
  36         STAR,
  37         SLASH,
  38         DIV,
  39         MOD,
  40         AND,
  41         NOT,
  42         PROCEDURE,
  43         COMMA,
  44         RETURN,
  45         CONST,
  46         TYPE,
  47         ARRAY,
  48         OF,
  49         LBRACE,
  50         RBRACE,
  51         RECORD,
  52         POINTER,
  53         TO,
  54         UPARROW,
  55         NIL
  56 };
  57
  58 // =======================================================================
  59 //   UTILS
  60 // =======================================================================
  61
  62 void
  63 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
  64 {
  65         va_list ptr;
  66         va_start(ptr, fmt);
  67         fprintf(stderr, "error: ");
  68         vfprintf(stderr, fmt, ptr);
  69         fprintf(stderr, "\n");
  70         fprintf(stderr, "  code_index = %i\n", ctx -> code_index);
  71         fprintf(stderr, "  c          = %c\n", ctx -> c);
  72         fprintf(stderr, "  token      = %i\n", ctx -> token);
  73         va_end(ptr);
  74         exit(1);
  75 }
  76
  77 static oberon_type_t *
  78 oberon_new_type_ptr(int class)
  79 {
  80         oberon_type_t * x = malloc(sizeof *x);
  81         memset(x, 0, sizeof *x);
  82         x -> class = class;
  83         return x;
  84 }
  85
  86 static oberon_type_t *
  87 oberon_new_type_integer(int size)
  88 {
  89         oberon_type_t * x;
  90         x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
  91         x -> size = size;
  92         return x;
  93 }
  94
  95 static oberon_type_t *
  96 oberon_new_type_boolean(int size)
  97 {
  98         oberon_type_t * x;
  99         x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
 100         x -> size = size;
 101         return x;
 102 }
 103
 104 // =======================================================================
 105 //   TABLE
 106 // =======================================================================
 107
 108 static oberon_scope_t *
 109 oberon_open_scope(oberon_context_t * ctx)
 110 {
 111         oberon_scope_t * scope = malloc(sizeof *scope);
 112         memset(scope, 0, sizeof *scope);
 113
 114         oberon_object_t * list = malloc(sizeof *list);
 115         memset(list, 0, sizeof *list);
 116
 117         scope -> ctx = ctx;
 118         scope -> list = list;
 119         scope -> up = ctx -> decl;
 120
 121         ctx -> decl = scope;
 122         return scope;
 123 }
 124
 125 static void
 126 oberon_close_scope(oberon_scope_t * scope)
 127 {
 128         oberon_context_t * ctx = scope -> ctx;
 129         ctx -> decl = scope -> up;
 130 }
 131
 132 static oberon_object_t *
 133 oberon_define_object(oberon_scope_t * scope, char * name, int class)
 134 {
 135         oberon_object_t * x = scope -> list;
 136         while(x -> next && strcmp(x -> next -> name, name) != 0)
 137         {
 138                 x = x -> next;
 139         }
 140
 141         if(x -> next)
 142         {
 143                 oberon_error(scope -> ctx, "already defined");
 144         }
 145
 146         oberon_object_t * newvar = malloc(sizeof *newvar);
 147         memset(newvar, 0, sizeof *newvar);
 148         newvar -> name = name;
 149         newvar -> class = class;
 150
 151         x -> next = newvar;
 152
 153         return newvar;
 154 }
 155
 156 static void
 157 oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char *  name, oberon_type_t * type)
 158 {
 159         oberon_object_t * x = rec -> decl;
 160         while(x -> next && strcmp(x -> next -> name, name) != 0)
 161         {
 162                 x = x -> next;
 163         }
 164
 165         if(x -> next)
 166         {
 167                 oberon_error(ctx, "multiple definition");
 168         }
 169
 170         oberon_object_t * field = malloc(sizeof *field);
 171         memset(field, 0, sizeof *field);
 172         field -> name = name;
 173         field -> class = OBERON_CLASS_FIELD;
 174         field -> type = type;
 175
 176         rec -> num_decl += 1;
 177         x -> next = field;
 178 }
 179
 180 static oberon_object_t *
 181 oberon_find_object_in_list(oberon_object_t * list, char * name)
 182 {
 183         oberon_object_t * x = list;
 184         while(x -> next && strcmp(x -> next -> name, name) != 0)
 185         {
 186                 x = x -> next;
 187         }
 188         return x -> next;
 189 }
 190
 191 static oberon_object_t *
 192 oberon_find_object(oberon_scope_t * scope, char * name, int check_it)
 193 {
 194         oberon_object_t * result = NULL;
 195
 196         oberon_scope_t * s = scope;
 197         while(result == NULL && s != NULL)
 198         {
 199                 result = oberon_find_object_in_list(s -> list, name);
 200                 s = s -> up;
 201         }
 202
 203         if(check_it && result == NULL)
 204         {
 205                 oberon_error(scope -> ctx, "undefined ident %s", name);
 206         }
 207
 208         return result;
 209 }
 210
 211 static oberon_object_t *
 212 oberon_find_field(oberon_context_t * ctx, oberon_type_t * rec, char * name)
 213 {
 214         oberon_object_t * x = rec -> decl;
 215         for(int i = 0; i < rec -> num_decl; i++)
 216         {
 217                 if(strcmp(x -> name, name) == 0)
 218                 {
 219                         return x;
 220                 }
 221                 x = x -> next;
 222         }
 223
 224         oberon_error(ctx, "field not defined");
 225
 226         return NULL;
 227 }
 228
 229 static oberon_object_t *
 230 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type)
 231 {
 232         oberon_object_t * id;
 233         id = oberon_define_object(scope, name, OBERON_CLASS_TYPE);
 234         id -> type = type;
 235         oberon_generator_init_type(scope -> ctx, type);
 236         return id;
 237 }
 238
 239 /*
 240 static oberon_type_t *
 241 oberon_find_type(oberon_scope_t * scope, char * name)
 242 {
 243         oberon_object_t * x = oberon_find_object(scope, name);
 244         if(x -> class != OBERON_CLASS_TYPE)
 245         {
 246                 oberon_error(scope -> ctx, "%s not a type", name);
 247         }
 248
 249         return x -> type;
 250 }
 251 */
 252
 253 static oberon_object_t *
 254 oberon_define_var(oberon_scope_t * scope, int class, char * name, oberon_type_t * type)
 255 {
 256         oberon_object_t * var;
 257         var = oberon_define_object(scope, name, class);
 258         var -> type = type;
 259         return var;
 260 }
 261
 262 /*
 263 static oberon_object_t *
 264 oberon_find_var(oberon_scope_t * scope, char * name)
 265 {
 266         oberon_object_t * x = oberon_find_object(scope, name);
 267
 268         if(x -> class != OBERON_CLASS_VAR)
 269         {
 270                 oberon_error(scope -> ctx, "%s not a var", name);
 271         }
 272
 273         return x;
 274 }
 275 */
 276
 277 static oberon_object_t *
 278 oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signature)
 279 {
 280         oberon_object_t * proc;
 281         proc = oberon_define_object(scope, name, OBERON_CLASS_PROC);
 282         proc -> type = signature;
 283         return proc;
 284 }
 285
 286 // =======================================================================
 287 //   SCANER
 288 // =======================================================================
 289
 290 static void
 291 oberon_get_char(oberon_context_t * ctx)
 292 {
 293         ctx -> code_index += 1;
 294         ctx -> c = ctx -> code[ctx -> code_index];
 295 }
 296
 297 static void
 298 oberon_init_scaner(oberon_context_t * ctx, const char * code)
 299 {
 300         ctx -> code = code;
 301         ctx -> code_index = 0;
 302         ctx -> c = ctx -> code[ctx -> code_index];
 303 }
 304
 305 static void
 306 oberon_read_ident(oberon_context_t * ctx)
 307 {
 308         int len = 0;
 309         int i = ctx -> code_index;
 310
 311         int c = ctx -> code[i];
 312         while(isalnum(c))
 313         {
 314                 i += 1;
 315                 len += 1;
 316                 c = ctx -> code[i];
 317         }
 318
 319         char * ident = malloc(len + 1);
 320         memcpy(ident, &ctx->code[ctx->code_index], len);
 321         ident[len] = 0;
 322
 323         ctx -> code_index = i;
 324         ctx -> c = ctx -> code[i];
 325         ctx -> string = ident;
 326         ctx -> token = IDENT;
 327
 328         if(strcmp(ident, "MODULE") == 0)
 329         {
 330                 ctx -> token = MODULE;
 331         }
 332         else if(strcmp(ident, "END") == 0)
 333         {
 334                 ctx -> token = END;
 335         }
 336         else if(strcmp(ident, "VAR") == 0)
 337         {
 338                 ctx -> token = VAR;
 339         }
 340         else if(strcmp(ident, "BEGIN") == 0)
 341         {
 342                 ctx -> token = BEGIN;
 343         }
 344         else if(strcmp(ident, "TRUE") == 0)
 345         {
 346                 ctx -> token = TRUE;
 347         }
 348         else if(strcmp(ident, "FALSE") == 0)
 349         {
 350                 ctx -> token = FALSE;
 351         }
 352         else if(strcmp(ident, "OR") == 0)
 353         {
 354                 ctx -> token = OR;
 355         }
 356         else if(strcmp(ident, "DIV") == 0)
 357         {
 358                 ctx -> token = DIV;
 359         }
 360         else if(strcmp(ident, "MOD") == 0)
 361         {
 362                 ctx -> token = MOD;
 363         }
 364         else if(strcmp(ident, "PROCEDURE") == 0)
 365         {
 366                 ctx -> token = PROCEDURE;
 367         }
 368         else if(strcmp(ident, "RETURN") == 0)
 369         {
 370                 ctx -> token = RETURN;
 371         }
 372         else if(strcmp(ident, "CONST") == 0)
 373         {
 374                 ctx -> token = CONST;
 375         }
 376         else if(strcmp(ident, "TYPE") == 0)
 377         {
 378                 ctx -> token = TYPE;
 379         }
 380         else if(strcmp(ident, "ARRAY") == 0)
 381         {
 382                 ctx -> token = ARRAY;
 383         }
 384         else if(strcmp(ident, "OF") == 0)
 385         {
 386                 ctx -> token = OF;
 387         }
 388         else if(strcmp(ident, "RECORD") == 0)
 389         {
 390                 ctx -> token = RECORD;
 391         }
 392         else if(strcmp(ident, "POINTER") == 0)
 393         {
 394                 ctx -> token = POINTER;
 395         }
 396         else if(strcmp(ident, "TO") == 0)
 397         {
 398                 ctx -> token = TO;
 399         }
 400         else if(strcmp(ident, "NIL") == 0)
 401         {
 402                 ctx -> token = NIL;
 403         }
 404 }
 405
 406 static void
 407 oberon_read_integer(oberon_context_t * ctx)
 408 {
 409         int len = 0;
 410         int i = ctx -> code_index;
 411
 412         int c = ctx -> code[i];
 413         while(isdigit(c))
 414         {
 415                 i += 1;
 416                 len += 1;
 417                 c = ctx -> code[i];
 418         }
 419
 420         char * ident = malloc(len + 2);
 421         memcpy(ident, &ctx->code[ctx->code_index], len);
 422         ident[len + 1] = 0;
 423
 424         ctx -> code_index = i;
 425         ctx -> c = ctx -> code[i];
 426         ctx -> string = ident;
 427         ctx -> integer = atoi(ident);
 428         ctx -> token = INTEGER;
 429 }
 430
 431 static void
 432 oberon_skip_space(oberon_context_t * ctx)
 433 {
 434         while(isspace(ctx -> c))
 435         {
 436                 oberon_get_char(ctx);
 437         }
 438 }
 439
 440 static void
 441 oberon_read_symbol(oberon_context_t * ctx)
 442 {
 443         int c = ctx -> c;
 444         switch(c)
 445         {
 446                 case 0:
 447                         ctx -> token = EOF_;
 448                         break;
 449                 case ';':
 450                         ctx -> token = SEMICOLON;
 451                         oberon_get_char(ctx);
 452                         break;
 453                 case ':':
 454                         ctx -> token = COLON;
 455                         oberon_get_char(ctx);
 456                         if(ctx -> c == '=')
 457                         {
 458                                 ctx -> token = ASSIGN;
 459                                 oberon_get_char(ctx);
 460                         }
 461                         break;
 462                 case '.':
 463                         ctx -> token = DOT;
 464                         oberon_get_char(ctx);
 465                         break;
 466                 case '(':
 467                         ctx -> token = LPAREN;
 468                         oberon_get_char(ctx);
 469                         break;
 470                 case ')':
 471                         ctx -> token = RPAREN;
 472                         oberon_get_char(ctx);
 473                         break;
 474                 case '=':
 475                         ctx -> token = EQUAL;
 476                         oberon_get_char(ctx);
 477                         break;
 478                 case '#':
 479                         ctx -> token = NEQ;
 480                         oberon_get_char(ctx);
 481                         break;
 482                 case '<':
 483                         ctx -> token = LESS;
 484                         oberon_get_char(ctx);
 485                         if(ctx -> c == '=')
 486                         {
 487                                 ctx -> token = LEQ;
 488                                 oberon_get_char(ctx);
 489                         }
 490                         break;
 491                 case '>':
 492                         ctx -> token = GREAT;
 493                         oberon_get_char(ctx);
 494                         if(ctx -> c == '=')
 495                         {
 496                                 ctx -> token = GEQ;
 497                                 oberon_get_char(ctx);
 498                         }
 499                         break;
 500                 case '+':
 501                         ctx -> token = PLUS;
 502                         oberon_get_char(ctx);
 503                         break;
 504                 case '-':
 505                         ctx -> token = MINUS;
 506                         oberon_get_char(ctx);
 507                         break;
 508                 case '*':
 509                         ctx -> token = STAR;
 510                         oberon_get_char(ctx);
 511                         break;
 512                 case '/':
 513                         ctx -> token = SLASH;
 514                         oberon_get_char(ctx);
 515                         break;
 516                 case '&':
 517                         ctx -> token = AND;
 518                         oberon_get_char(ctx);
 519                         break;
 520                 case '~':
 521                         ctx -> token = NOT;
 522                         oberon_get_char(ctx);
 523                         break;
 524                 case ',':
 525                         ctx -> token = COMMA;
 526                         oberon_get_char(ctx);
 527                         break;
 528                 case '[':
 529                         ctx -> token = LBRACE;
 530                         oberon_get_char(ctx);
 531                         break;
 532                 case ']':
 533                         ctx -> token = RBRACE;
 534                         oberon_get_char(ctx);
 535                         break;
 536                 case '^':
 537                         ctx -> token = UPARROW;
 538                         oberon_get_char(ctx);
 539                         break;
 540                 default:
 541                         oberon_error(ctx, "invalid char");
 542                         break;
 543         }
 544 }
 545
 546 static void
 547 oberon_read_token(oberon_context_t * ctx)
 548 {
 549         oberon_skip_space(ctx);
 550
 551         int c = ctx -> c;
 552         if(isalpha(c))
 553         {
 554                 oberon_read_ident(ctx);
 555         }
 556         else if(isdigit(c))
 557         {
 558                 oberon_read_integer(ctx);
 559         }
 560         else
 561         {
 562                 oberon_read_symbol(ctx);
 563         }
 564 }
 565
 566 // =======================================================================
 567 //   EXPRESSION
 568 // =======================================================================
 569
 570 static void oberon_expect_token(oberon_context_t * ctx, int token);
 571 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
 572 static void oberon_assert_token(oberon_context_t * ctx, int token);
 573 static char * oberon_assert_ident(oberon_context_t * ctx);
 574 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
 575 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
 576
 577 static oberon_expr_t *
 578 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
 579 {
 580         oberon_oper_t * operator;
 581         operator = malloc(sizeof *operator);
 582         memset(operator, 0, sizeof *operator);
 583
 584         operator -> is_item = 0;
 585         operator -> result = result;
 586         operator -> op = op;
 587         operator -> left = left;
 588         operator -> right = right;
 589
 590         return (oberon_expr_t *) operator;
 591 }
 592
 593 static oberon_expr_t *
 594 oberon_new_item(int mode, oberon_type_t * result)
 595 {
 596         oberon_item_t * item;
 597         item = malloc(sizeof *item);
 598         memset(item, 0, sizeof *item);
 599
 600         item -> is_item = 1;
 601         item -> result = result;
 602         item -> mode = mode;
 603
 604         return (oberon_expr_t *)item;
 605 }
 606
 607 static oberon_expr_t *
 608 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
 609 {
 610         oberon_expr_t * expr;
 611         oberon_type_t * result;
 612
 613         result = a -> result;
 614
 615         if(token == MINUS)
 616         {
 617                 if(result -> class != OBERON_TYPE_INTEGER)
 618                 {
 619                         oberon_error(ctx, "incompatible operator type");
 620                 }
 621
 622                 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
 623         }
 624         else if(token == NOT)
 625         {
 626                 if(result -> class != OBERON_TYPE_BOOLEAN)
 627                 {
 628                         oberon_error(ctx, "incompatible operator type");
 629                 }
 630
 631                 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
 632         }
 633         else
 634         {
 635                 oberon_error(ctx, "oberon_make_unary_op: wat");
 636         }
 637
 638         return expr;
 639 }
 640
 641 static void
 642 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
 643 {
 644         oberon_expr_t * last;
 645
 646         *num_expr = 1;
 647         *first = last = oberon_expr(ctx);
 648         while(ctx -> token == COMMA)
 649         {
 650                 oberon_assert_token(ctx, COMMA);
 651                 oberon_expr_t * current;
 652
 653                 if(const_expr)
 654                 {
 655                         current = (oberon_expr_t *) oberon_const_expr(ctx);
 656                 }
 657                 else
 658                 {
 659                         current = oberon_expr(ctx);
 660                 }
 661
 662                 last -> next = current;
 663                 last = current;
 664                 *num_expr += 1;
 665         }
 666 }
 667
 668 static oberon_expr_t *
 669 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
 670 {
 671         if(pref -> class != expr -> result -> class)
 672         {
 673                 oberon_error(ctx, "incompatible types");
 674         }
 675
 676         if(pref -> class == OBERON_TYPE_INTEGER)
 677         {
 678                 if(expr -> result -> class > pref -> class)
 679                 {
 680                         oberon_error(ctx, "incompatible size");
 681                 }
 682         }
 683         else if(pref -> class == OBERON_TYPE_RECORD)
 684         {
 685                 if(expr -> result != pref)
 686                 {
 687                         printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
 688                         oberon_error(ctx, "incompatible record types");
 689                 }
 690         }
 691         else if(pref -> class == OBERON_TYPE_POINTER)
 692         {
 693                 if(expr -> result -> base != pref -> base)
 694                 {
 695                         if(expr -> result -> base -> class != OBERON_TYPE_VOID)
 696                         {
 697                                 oberon_error(ctx, "incompatible pointer types");
 698                         }
 699                 }
 700         }
 701
 702         // TODO cast
 703
 704         return expr;
 705 }
 706
 707 static void
 708 oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
 709 {
 710         if(desig -> is_item == 0)
 711         {
 712                 oberon_error(ctx, "expected item");
 713         }
 714
 715         if(desig -> item.mode != MODE_CALL)
 716         {
 717                 oberon_error(ctx, "expected mode CALL");
 718         }
 719
 720         if(desig -> item.var -> class != OBERON_CLASS_PROC)
 721         {
 722                 oberon_error(ctx, "only procedures can be called");
 723         }
 724
 725         oberon_type_t * fn = desig -> item.var -> type;
 726         int num_args = desig -> item.num_args;
 727         int num_decl = fn -> num_decl;
 728
 729         if(num_args < num_decl)
 730         {
 731                 oberon_error(ctx, "too few arguments");
 732         }
 733         else if(num_args > num_decl)
 734         {
 735                 oberon_error(ctx, "too many arguments");
 736         }
 737
 738         oberon_expr_t * arg = desig -> item.args;
 739         oberon_object_t * param = fn -> decl;
 740         for(int i = 0; i < num_args; i++)
 741         {
 742                 if(param -> class == OBERON_CLASS_VAR_PARAM)
 743                 {
 744                         if(arg -> is_item)
 745                         {
 746                                 switch(arg -> item.mode)
 747                                 {
 748                                         case MODE_VAR:
 749                                         case MODE_INDEX:
 750                                         case MODE_FIELD:
 751                                         // Допустимо разыменование?
 752                                         //case MODE_DEREF:
 753                                                 break;
 754                                         default:
 755                                                 oberon_error(ctx, "var-parameter accept only variables");
 756                                                 break;
 757                                 }
 758                         }
 759                 }
 760                 oberon_autocast_to(ctx, arg, param -> type);
 761                 arg = arg -> next;
 762                 param = param -> next;
 763         }
 764 }
 765
 766 #define ISEXPR(x) \
 767         (((x) == PLUS) \
 768         || ((x) == MINUS) \
 769         || ((x) == IDENT) \
 770         || ((x) == INTEGER) \
 771         || ((x) == LPAREN) \
 772         || ((x) == NOT) \
 773         || ((x) == TRUE) \
 774         || ((x) == FALSE))
 775
 776 static oberon_expr_t *
 777 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
 778 {
 779         if(expr -> result -> class != OBERON_TYPE_POINTER)
 780         {
 781                 oberon_error(ctx, "not a pointer");
 782         }
 783
 784         assert(expr -> is_item);
 785
 786         oberon_expr_t * selector;
 787         selector = oberon_new_item(MODE_DEREF, expr -> result -> base);
 788         selector -> item.parent = (oberon_item_t *) expr;
 789
 790         return selector;
 791 }
 792
 793 static oberon_expr_t *
 794 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
 795 {
 796         if(desig -> result -> class == OBERON_TYPE_POINTER)
 797         {
 798                 desig = oberno_make_dereferencing(ctx, desig);
 799         }
 800
 801         assert(desig -> is_item);
 802
 803         if(desig -> result -> class != OBERON_TYPE_ARRAY)
 804         {
 805                 oberon_error(ctx, "not array");
 806         }
 807
 808         oberon_type_t * base;
 809         base = desig -> result -> base;
 810
 811         if(index -> result -> class != OBERON_TYPE_INTEGER)
 812         {
 813                 oberon_error(ctx, "index must be integer");
 814         }
 815
 816         // Статическая проверка границ массива
 817         if(index -> is_item)
 818         {
 819                 if(index -> item.mode == MODE_INTEGER)
 820                 {
 821                         int arr_size = desig -> result -> size;
 822                         int index_int = index -> item.integer;
 823                         if(index_int < 0 || index_int > arr_size - 1)
 824                         {
 825                                 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
 826                         }
 827                 }
 828         }
 829
 830         oberon_expr_t * selector;
 831         selector = oberon_new_item(MODE_INDEX, base);
 832         selector -> item.parent = (oberon_item_t *) desig;
 833         selector -> item.num_args = 1;
 834         selector -> item.args = index;
 835
 836         return selector;
 837 }
 838
 839 static oberon_expr_t *
 840 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
 841 {
 842         if(expr -> result -> class == OBERON_TYPE_POINTER)
 843         {
 844                 expr = oberno_make_dereferencing(ctx, expr);
 845         }
 846
 847         assert(expr -> is_item == 1);
 848
 849         if(expr -> result -> class != OBERON_TYPE_RECORD)
 850         {
 851                 oberon_error(ctx, "not record");
 852         }
 853
 854         oberon_type_t * rec = expr -> result;
 855
 856         oberon_object_t * field;
 857         field = oberon_find_field(ctx, rec, name);
 858
 859         oberon_expr_t * selector;
 860         selector = oberon_new_item(MODE_FIELD, field -> type);
 861         selector -> item.var = field;
 862         selector -> item.parent = (oberon_item_t *) expr;
 863
 864         return selector;
 865 }
 866
 867 #define ISSELECTOR(x) \
 868         (((x) == LBRACE) \
 869         || ((x) == DOT) \
 870         || ((x) == UPARROW))
 871
 872 static oberon_expr_t *
 873 oberon_designator(oberon_context_t * ctx)
 874 {
 875         char * name;
 876         oberon_object_t * var;
 877         oberon_expr_t * expr;
 878
 879         name = oberon_assert_ident(ctx);
 880         var = oberon_find_object(ctx -> decl, name, 1);
 881
 882         switch(var -> class)
 883         {
 884                 case OBERON_CLASS_CONST:
 885                         // TODO copy value
 886                         expr = (oberon_expr_t *) var -> value;
 887                         break;
 888                 case OBERON_CLASS_VAR:
 889                 case OBERON_CLASS_VAR_PARAM:
 890                 case OBERON_CLASS_PARAM:
 891                         expr = oberon_new_item(MODE_VAR, var -> type);
 892                         break;
 893                 case OBERON_CLASS_PROC:
 894                         expr = oberon_new_item(MODE_CALL, var -> type);
 895                         break;
 896                 default:
 897                         oberon_error(ctx, "invalid designator");
 898                         break;
 899         }
 900         expr -> item.var = var;
 901
 902         while(ISSELECTOR(ctx -> token))
 903         {
 904                 switch(ctx -> token)
 905                 {
 906                         case DOT:
 907                                 oberon_assert_token(ctx, DOT);
 908                                 name = oberon_assert_ident(ctx);
 909                                 expr = oberon_make_record_selector(ctx, expr, name);
 910                                 break;
 911                         case LBRACE:
 912                                 oberon_assert_token(ctx, LBRACE);
 913                                 int num_indexes = 0;
 914                                 oberon_expr_t * indexes = NULL;
 915                                 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
 916                                 oberon_assert_token(ctx, RBRACE);
 917
 918                                 for(int i = 0; i < num_indexes; i++)
 919                                 {
 920                                         expr = oberon_make_array_selector(ctx, expr, indexes);
 921                                         indexes = indexes -> next;
 922                                 }
 923                                 break;
 924                         case UPARROW:
 925                                 oberon_assert_token(ctx, UPARROW);
 926                                 expr = oberno_make_dereferencing(ctx, expr);
 927                                 break;
 928                         default:
 929                                 oberon_error(ctx, "oberon_designator: wat");
 930                                 break;
 931                 }
 932         }
 933         return expr;
 934 }
 935
 936 static oberon_expr_t *
 937 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 938 {
 939         assert(expr -> is_item == 1);
 940
 941         if(ctx -> token == LPAREN)
 942         {
 943                 if(expr -> result -> class != OBERON_TYPE_PROCEDURE)
 944                 {
 945                         oberon_error(ctx, "not a procedure");
 946                 }
 947
 948                 oberon_assert_token(ctx, LPAREN);
 949
 950                 int num_args = 0;
 951                 oberon_expr_t * arguments = NULL;
 952
 953                 if(ISEXPR(ctx -> token))
 954                 {
 955                         oberon_expr_list(ctx, &num_args, &arguments, 0);
 956                 }
 957
 958                 expr -> result = expr -> item.var -> type -> base;
 959                 expr -> item.mode = MODE_CALL;
 960                 expr -> item.num_args = num_args;
 961                 expr -> item.args = arguments;
 962                 oberon_assert_token(ctx, RPAREN);
 963
 964                 oberon_autocast_call(ctx, expr);
 965         }
 966
 967         return expr;
 968 }
 969
 970 static oberon_expr_t *
 971 oberon_factor(oberon_context_t * ctx)
 972 {
 973         oberon_expr_t * expr;
 974
 975         switch(ctx -> token)
 976         {
 977                 case IDENT:
 978                         expr = oberon_designator(ctx);
 979                         expr = oberon_opt_proc_parens(ctx, expr);
 980                         break;
 981                 case INTEGER:
 982                         expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
 983                         expr -> item.integer = ctx -> integer;
 984                         oberon_assert_token(ctx, INTEGER);
 985                         break;
 986                 case TRUE:
 987                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 988                         expr -> item.boolean = 1;
 989                         oberon_assert_token(ctx, TRUE);
 990                         break;
 991                 case FALSE:
 992                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 993                         expr -> item.boolean = 0;
 994                         oberon_assert_token(ctx, FALSE);
 995                         break;
 996                 case LPAREN:
 997                         oberon_assert_token(ctx, LPAREN);
 998                         expr = oberon_expr(ctx);
 999                         oberon_assert_token(ctx, RPAREN);
1000                         break;
1001                 case NOT:
1002                         oberon_assert_token(ctx, NOT);
1003                         expr = oberon_factor(ctx);
1004                         expr = oberon_make_unary_op(ctx, NOT, expr);
1005                         break;
1006                 case NIL:
1007                         oberon_assert_token(ctx, NIL);
1008                         expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type);
1009                         break;
1010                 default:
1011                         oberon_error(ctx, "invalid expression");
1012         }
1013
1014         return expr;
1015 }
1016
1017 /*
1018  * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1019  *   1. Классы обоих типов должны быть одинаковы
1020  *   2. В качестве результата должен быть выбран больший тип.
1021  *   3. Если размер результат не должен быть меньше чем базовый int
1022  */
1023
1024 static void
1025 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
1026 {
1027         if((a -> class) != (b -> class))
1028         {
1029                 oberon_error(ctx, "incompatible types");
1030         }
1031
1032         if((a -> size) > (b -> size))
1033         {
1034                 *result = a;
1035         }
1036         else
1037         {
1038                 *result = b;
1039         }
1040
1041         if(((*result) -> class) == OBERON_TYPE_INTEGER)
1042         {
1043                 if(((*result) -> size) < (ctx -> int_type -> size))
1044                 {
1045                         *result = ctx -> int_type;
1046                 }
1047         }
1048
1049         /* TODO: cast types */
1050 }
1051
1052 #define ITMAKESBOOLEAN(x) \
1053         (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1054
1055 #define ITUSEONLYINTEGER(x) \
1056         ((x) >= LESS && (x) <= GEQ)
1057
1058 #define ITUSEONLYBOOLEAN(x) \
1059         (((x) == OR) || ((x) == AND))
1060
1061 static oberon_expr_t *
1062 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1063 {
1064         oberon_expr_t * expr;
1065         oberon_type_t * result;
1066
1067         if(ITMAKESBOOLEAN(token))
1068         {
1069                 if(ITUSEONLYINTEGER(token))
1070                 {
1071                         if(a -> result -> class != OBERON_TYPE_INTEGER
1072                                 || b -> result -> class != OBERON_TYPE_INTEGER)
1073                         {
1074                                 oberon_error(ctx, "used only with integer types");
1075                         }
1076                 }
1077                 else if(ITUSEONLYBOOLEAN(token))
1078                 {
1079                         if(a -> result -> class != OBERON_TYPE_BOOLEAN
1080                                 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1081                         {
1082                                 oberon_error(ctx, "used only with boolean type");
1083                         }
1084                 }
1085
1086                 result = ctx -> bool_type;
1087
1088                 if(token == EQUAL)
1089                 {
1090                         expr = oberon_new_operator(OP_EQ, result, a, b);
1091                 }
1092                 else if(token == NEQ)
1093                 {
1094                         expr = oberon_new_operator(OP_NEQ, result, a, b);
1095                 }
1096                 else if(token == LESS)
1097                 {
1098                         expr = oberon_new_operator(OP_LSS, result, a, b);
1099                 }
1100                 else if(token == LEQ)
1101                 {
1102                         expr = oberon_new_operator(OP_LEQ, result, a, b);
1103                 }
1104                 else if(token == GREAT)
1105                 {
1106                         expr = oberon_new_operator(OP_GRT, result, a, b);
1107                 }
1108                 else if(token == GEQ)
1109                 {
1110                         expr = oberon_new_operator(OP_GEQ, result, a, b);
1111                 }
1112                 else if(token == OR)
1113                 {
1114                         expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1115                 }
1116                 else if(token == AND)
1117                 {
1118                         expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1119                 }
1120                 else
1121                 {
1122                         oberon_error(ctx, "oberon_make_bin_op: bool wat");
1123                 }
1124         }
1125         else
1126         {
1127                 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1128
1129                 if(token == PLUS)
1130                 {
1131                         expr = oberon_new_operator(OP_ADD, result, a, b);
1132                 }
1133                 else if(token == MINUS)
1134                 {
1135                         expr = oberon_new_operator(OP_SUB, result, a, b);
1136                 }
1137                 else if(token == STAR)
1138                 {
1139                         expr = oberon_new_operator(OP_MUL, result, a, b);
1140                 }
1141                 else if(token == SLASH)
1142                 {
1143                         expr = oberon_new_operator(OP_DIV, result, a, b);
1144                 }
1145                 else if(token == DIV)
1146                 {
1147                         expr = oberon_new_operator(OP_DIV, result, a, b);
1148                 }
1149                 else if(token == MOD)
1150                 {
1151                         expr = oberon_new_operator(OP_MOD, result, a, b);
1152                 }
1153                 else
1154                 {
1155                         oberon_error(ctx, "oberon_make_bin_op: bin wat");
1156                 }
1157         }
1158
1159         return expr;
1160 }
1161
1162 #define ISMULOP(x) \
1163         ((x) >= STAR && (x) <= AND)
1164
1165 static oberon_expr_t *
1166 oberon_term_expr(oberon_context_t * ctx)
1167 {
1168         oberon_expr_t * expr;
1169
1170         expr = oberon_factor(ctx);
1171         while(ISMULOP(ctx -> token))
1172         {
1173                 int token = ctx -> token;
1174                 oberon_read_token(ctx);
1175
1176                 oberon_expr_t * inter = oberon_factor(ctx);
1177                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1178         }
1179
1180         return expr;
1181 }
1182
1183 #define ISADDOP(x) \
1184         ((x) >= PLUS && (x) <= OR)
1185
1186 static oberon_expr_t *
1187 oberon_simple_expr(oberon_context_t * ctx)
1188 {
1189         oberon_expr_t * expr;
1190
1191         int minus = 0;
1192         if(ctx -> token == PLUS)
1193         {
1194                 minus = 0;
1195                 oberon_assert_token(ctx, PLUS);
1196         }
1197         else if(ctx -> token == MINUS)
1198         {
1199                 minus = 1;
1200                 oberon_assert_token(ctx, MINUS);
1201         }
1202
1203         expr = oberon_term_expr(ctx);
1204         while(ISADDOP(ctx -> token))
1205         {
1206                 int token = ctx -> token;
1207                 oberon_read_token(ctx);
1208
1209                 oberon_expr_t * inter = oberon_term_expr(ctx);
1210                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1211         }
1212
1213         if(minus)
1214         {
1215                 expr = oberon_make_unary_op(ctx, MINUS, expr);
1216         }
1217
1218         return expr;
1219 }
1220
1221 #define ISRELATION(x) \
1222         ((x) >= EQUAL && (x) <= GEQ)
1223
1224 static oberon_expr_t *
1225 oberon_expr(oberon_context_t * ctx)
1226 {
1227         oberon_expr_t * expr;
1228
1229         expr = oberon_simple_expr(ctx);
1230         while(ISRELATION(ctx -> token))
1231         {
1232                 int token = ctx -> token;
1233                 oberon_read_token(ctx);
1234
1235                 oberon_expr_t * inter = oberon_simple_expr(ctx);
1236                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1237         }
1238
1239         return expr;
1240 }
1241
1242 static oberon_item_t *
1243 oberon_const_expr(oberon_context_t * ctx)
1244 {
1245         oberon_expr_t * expr;
1246         expr = oberon_expr(ctx);
1247
1248         if(expr -> is_item == 0)
1249         {
1250                 oberon_error(ctx, "const expression are required");
1251         }
1252
1253         return (oberon_item_t *) expr;
1254 }
1255
1256 // =======================================================================
1257 //   PARSER
1258 // =======================================================================
1259
1260 static void oberon_decl_seq(oberon_context_t * ctx);
1261 static void oberon_statement_seq(oberon_context_t * ctx);
1262
1263 static void
1264 oberon_expect_token(oberon_context_t * ctx, int token)
1265 {
1266         if(ctx -> token != token)
1267         {
1268                 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1269         }
1270 }
1271
1272 static void
1273 oberon_assert_token(oberon_context_t * ctx, int token)
1274 {
1275         oberon_expect_token(ctx, token);
1276         oberon_read_token(ctx);
1277 }
1278
1279 static char *
1280 oberon_assert_ident(oberon_context_t * ctx)
1281 {
1282         oberon_expect_token(ctx, IDENT);
1283         char * ident = ctx -> string;
1284         oberon_read_token(ctx);
1285         return ident;
1286 }
1287
1288 static void
1289 oberon_var_decl(oberon_context_t * ctx)
1290 {
1291         char * name;
1292         oberon_type_t * type;
1293         type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1294
1295         name = oberon_assert_ident(ctx);
1296         oberon_assert_token(ctx, COLON);
1297         oberon_type(ctx, &type);
1298         oberon_define_var(ctx -> decl, OBERON_CLASS_VAR, name, type);
1299 }
1300
1301 static oberon_object_t *
1302 oberon_make_param(oberon_context_t * ctx, int token, char * name, oberon_type_t * type)
1303 {
1304         oberon_object_t * param;
1305
1306         if(token == VAR)
1307         {
1308                 param = oberon_define_var(ctx -> decl, OBERON_CLASS_VAR_PARAM, name, type);
1309         }
1310         else if(token == IDENT)
1311         {
1312                 param = oberon_define_var(ctx -> decl, OBERON_CLASS_PARAM, name, type);
1313         }
1314         else
1315         {
1316                 oberon_error(ctx, "oberon_make_param: wat");
1317         }
1318
1319         return param;
1320 }
1321
1322 static oberon_object_t *
1323 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1324 {
1325         int modifer_token = ctx -> token;
1326         if(ctx -> token == VAR)
1327         {
1328                 oberon_read_token(ctx);
1329         }
1330
1331         char * name;
1332         name = oberon_assert_ident(ctx);
1333
1334         oberon_assert_token(ctx, COLON);
1335
1336         oberon_type_t * type;
1337         type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1338         oberon_type(ctx, &type);
1339
1340         oberon_object_t * first;
1341         first = oberon_make_param(ctx, modifer_token, name, type);
1342
1343         *num_decl += 1;
1344         return first;
1345 }
1346
1347 #define ISFPSECTION \
1348         ((ctx -> token == VAR) || (ctx -> token == IDENT))
1349
1350 static void
1351 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1352 {
1353         oberon_assert_token(ctx, LPAREN);
1354
1355         if(ISFPSECTION)
1356         {
1357                 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
1358                 while(ctx -> token == SEMICOLON)
1359                 {
1360                         oberon_assert_token(ctx, SEMICOLON);
1361                         oberon_fp_section(ctx, &signature -> num_decl);
1362                 }
1363         }
1364
1365         oberon_assert_token(ctx, RPAREN);
1366
1367         if(ctx -> token == COLON)
1368         {
1369                 oberon_assert_token(ctx, COLON);
1370                 // TODO get by qualident
1371                 oberon_type(ctx, &signature -> base);
1372         }
1373 }
1374
1375 static void
1376 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
1377 {
1378         oberon_type_t * signature;
1379         signature = *type;
1380         signature -> class = OBERON_TYPE_PROCEDURE;
1381         signature -> num_decl = 0;
1382         signature -> base = ctx -> void_type;
1383         signature -> decl = NULL;
1384
1385         if(ctx -> token == LPAREN)
1386         {
1387                 oberon_formal_pars(ctx, signature);
1388         }
1389 }
1390
1391 static void
1392 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1393 {
1394         if(ctx -> result_type -> class == OBERON_TYPE_VOID)
1395         {
1396                 if(expr != NULL)
1397                 {
1398                         oberon_error(ctx, "procedure has no result type");
1399                 }
1400         }
1401         else
1402         {
1403                 if(expr == NULL)
1404                 {
1405                         oberon_error(ctx, "procedure requires expression on result");
1406                 }
1407
1408                 oberon_autocast_to(ctx, expr, ctx -> result_type);
1409         }
1410
1411         ctx -> has_return = 1;
1412
1413         oberon_generate_return(ctx, expr);
1414 }
1415
1416 static void
1417 oberon_proc_decl(oberon_context_t * ctx)
1418 {
1419         oberon_assert_token(ctx, PROCEDURE);
1420
1421         char * name;
1422         name = oberon_assert_ident(ctx);
1423
1424         oberon_scope_t * this_proc_def_scope = ctx -> decl;
1425         oberon_open_scope(ctx);
1426
1427         oberon_type_t * signature;
1428         signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
1429         oberon_opt_formal_pars(ctx, &signature);
1430
1431         oberon_object_t * proc;
1432         proc = oberon_define_proc(this_proc_def_scope, name, signature);
1433
1434         ctx -> result_type = signature -> base;
1435         ctx -> has_return = 0;
1436
1437         oberon_assert_token(ctx, SEMICOLON);
1438
1439         oberon_decl_seq(ctx);
1440         oberon_generator_init_type(ctx, signature);
1441         oberon_generator_init_proc(ctx, proc);
1442
1443         oberon_generate_begin_proc(ctx, proc);
1444
1445         if(ctx -> token == BEGIN)
1446         {
1447                 oberon_assert_token(ctx, BEGIN);
1448                 oberon_statement_seq(ctx);
1449         }
1450
1451         oberon_assert_token(ctx, END);
1452         char * name2 = oberon_assert_ident(ctx);
1453         if(strcmp(name2, name) != 0)
1454         {
1455                 oberon_error(ctx, "procedure name not matched");
1456         }
1457
1458         if(signature -> base -> class == OBERON_TYPE_VOID)
1459         {
1460                 oberon_make_return(ctx, NULL);
1461         }
1462
1463         if(ctx -> has_return == 0)
1464         {
1465                 oberon_error(ctx, "procedure requires return");
1466         }
1467         ctx -> result_type = NULL;
1468
1469         oberon_generate_end_proc(ctx);
1470         oberon_close_scope(ctx -> decl);
1471 }
1472
1473 static void
1474 oberon_const_decl(oberon_context_t * ctx)
1475 {
1476         char * name;
1477         oberon_item_t * value;
1478         oberon_object_t * constant;
1479
1480         name = oberon_assert_ident(ctx);
1481         oberon_assert_token(ctx, EQUAL);
1482         value = oberon_const_expr(ctx);
1483
1484         constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST);
1485         constant -> value = value;
1486 }
1487
1488 static void
1489 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
1490 {
1491         if(size -> is_item == 0)
1492         {
1493                 oberon_error(ctx, "requires constant");
1494         }
1495
1496         if(size -> item.mode != MODE_INTEGER)
1497         {
1498                 oberon_error(ctx, "requires integer constant");
1499         }
1500
1501         oberon_type_t * arr;
1502         arr = *type;
1503         arr -> class = OBERON_TYPE_ARRAY;
1504         arr -> size = size -> item.integer;
1505         arr -> base = base;
1506 }
1507
1508 static void
1509 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1510 {
1511         if(ctx -> token == IDENT)
1512         {
1513                 char * name;
1514                 oberon_type_t * type;
1515                 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1516
1517                 name = oberon_assert_ident(ctx);
1518                 oberon_assert_token(ctx, COLON);
1519                 oberon_type(ctx, &type);
1520                 oberon_define_field(ctx, rec, name, type);
1521         }
1522 }
1523
1524 static void
1525 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
1526 {
1527         char * name;
1528         oberon_object_t * to;
1529
1530         name = oberon_assert_ident(ctx);
1531         to = oberon_find_object(ctx -> decl, name, 0);
1532
1533         if(to != NULL)
1534         {
1535                 if(to -> class != OBERON_CLASS_TYPE)
1536                 {
1537                         oberon_error(ctx, "not a type");
1538                 }
1539         }
1540         else
1541         {
1542                 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1543                 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1544         }
1545
1546         *type = to -> type;
1547 }
1548
1549 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
1550
1551 /*
1552  * Правило граматики "type". Указатель type должен указывать на существующий объект!
1553  */
1554
1555 static void
1556 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
1557 {
1558         if(sizes == NULL)
1559         {
1560                 *type = base;
1561                 return;
1562         }
1563
1564         oberon_type_t * dim;
1565         dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
1566
1567         oberon_make_multiarray(ctx, sizes -> next, base, &dim);
1568
1569         oberon_make_array_type(ctx, sizes, dim, type);
1570 }
1571
1572 static void
1573 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
1574 {
1575         if(ctx -> token == IDENT)
1576         {
1577                 oberon_qualident_type(ctx, type);
1578         }
1579         else if(ctx -> token == ARRAY)
1580         {
1581                 oberon_assert_token(ctx, ARRAY);
1582
1583                 int num_sizes = 0;
1584                 oberon_expr_t * sizes;
1585                 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
1586
1587                 oberon_assert_token(ctx, OF);
1588
1589                 oberon_type_t * base;
1590                 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1591                 oberon_type(ctx, &base);
1592
1593                 oberon_make_multiarray(ctx, sizes, base, type);
1594         }
1595         else if(ctx -> token == RECORD)
1596         {
1597                 oberon_type_t * rec;
1598                 rec = *type;
1599                 rec -> class = OBERON_TYPE_RECORD;
1600                 oberon_object_t * list = malloc(sizeof *list);
1601                 memset(list, 0, sizeof *list);
1602                 rec -> num_decl = 0;
1603                 rec -> base = NULL;
1604                 rec -> decl = list;
1605
1606                 oberon_assert_token(ctx, RECORD);
1607                 oberon_field_list(ctx, rec);
1608                 while(ctx -> token == SEMICOLON)
1609                 {
1610                         oberon_assert_token(ctx, SEMICOLON);
1611                         oberon_field_list(ctx, rec);
1612                 }
1613                 oberon_assert_token(ctx, END);
1614
1615                 rec -> decl = rec -> decl -> next;
1616                 *type = rec;
1617         }
1618         else if(ctx -> token == POINTER)
1619         {
1620                 oberon_assert_token(ctx, POINTER);
1621                 oberon_assert_token(ctx, TO);
1622
1623                 oberon_type_t * base;
1624                 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1625                 oberon_type(ctx, &base);
1626
1627                 oberon_type_t * ptr;
1628                 ptr = *type;
1629                 ptr -> class = OBERON_TYPE_POINTER;
1630                 ptr -> base = base;
1631         }
1632         else if(ctx -> token == PROCEDURE)
1633         {
1634                 oberon_open_scope(ctx);
1635                 oberon_assert_token(ctx, PROCEDURE);
1636                 oberon_opt_formal_pars(ctx, type);
1637                 oberon_close_scope(ctx -> decl);
1638         }
1639         else
1640         {
1641                 oberon_error(ctx, "invalid type declaration");
1642         }
1643 }
1644
1645 static void
1646 oberon_type_decl(oberon_context_t * ctx)
1647 {
1648         char * name;
1649         oberon_object_t * newtype;
1650         oberon_type_t * type;
1651
1652         name = oberon_assert_ident(ctx);
1653
1654         newtype = oberon_find_object(ctx -> decl, name, 0);
1655         if(newtype == NULL)
1656         {
1657                 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1658                 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1659                 assert(newtype -> type);
1660         }
1661         else
1662         {
1663                 if(newtype -> class != OBERON_CLASS_TYPE)
1664                 {
1665                         oberon_error(ctx, "mult definition");
1666                 }
1667
1668                 if(newtype -> linked)
1669                 {
1670                         oberon_error(ctx, "mult definition - already linked");
1671                 }
1672         }
1673
1674         oberon_assert_token(ctx, EQUAL);
1675
1676         type = newtype -> type;
1677         oberon_type(ctx, &type);
1678
1679         if(type -> class == OBERON_TYPE_VOID)
1680         {
1681                 oberon_error(ctx, "recursive alias declaration");
1682         }
1683
1684         newtype -> type = type;
1685         newtype -> linked = 1;
1686 }
1687
1688 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
1689 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
1690
1691 static void
1692 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
1693 {
1694         if(type -> class != OBERON_TYPE_POINTER
1695                 && type -> class != OBERON_TYPE_ARRAY)
1696         {
1697                 return;
1698         }
1699
1700         if(type -> recursive)
1701         {
1702                 oberon_error(ctx, "recursive pointer declaration");
1703         }
1704
1705         if(type -> base -> class == OBERON_TYPE_POINTER)
1706         {
1707                 oberon_error(ctx, "attempt to make pointer to pointer");
1708         }
1709
1710         type -> recursive = 1;
1711
1712         oberon_prevent_recursive_pointer(ctx, type -> base);
1713
1714         type -> recursive = 0;
1715 }
1716
1717 static void
1718 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
1719 {
1720         if(type -> class != OBERON_TYPE_RECORD)
1721         {
1722                 return;
1723         }
1724
1725         if(type -> recursive)
1726         {
1727                 oberon_error(ctx, "recursive record declaration");
1728         }
1729
1730         type -> recursive = 1;
1731
1732         int num_fields = type -> num_decl;
1733         oberon_object_t * field = type -> decl;
1734         for(int i = 0; i < num_fields; i++)
1735         {
1736                 oberon_prevent_recursive_object(ctx, field);
1737                 field = field -> next;
1738         }
1739
1740         type -> recursive = 0;
1741 }
1742 static void
1743 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
1744 {
1745         if(type -> class != OBERON_TYPE_PROCEDURE)
1746         {
1747                 return;
1748         }
1749
1750         if(type -> recursive)
1751         {
1752                 oberon_error(ctx, "recursive procedure declaration");
1753         }
1754
1755         type -> recursive = 1;
1756
1757         int num_fields = type -> num_decl;
1758         oberon_object_t * field = type -> decl;
1759         for(int i = 0; i < num_fields; i++)
1760         {
1761                 oberon_prevent_recursive_object(ctx, field);
1762                 field = field -> next;
1763         }
1764
1765         type -> recursive = 0;
1766 }
1767
1768 static void
1769 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
1770 {
1771         if(type -> class != OBERON_TYPE_ARRAY)
1772         {
1773                 return;
1774         }
1775
1776         if(type -> recursive)
1777         {
1778                 oberon_error(ctx, "recursive array declaration");
1779         }
1780
1781         type -> recursive = 1;
1782
1783         oberon_prevent_recursive_type(ctx, type -> base);
1784
1785         type -> recursive = 0;
1786 }
1787
1788 static void
1789 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
1790 {
1791         if(type -> class == OBERON_TYPE_POINTER)
1792         {
1793                 oberon_prevent_recursive_pointer(ctx, type);
1794         }
1795         else if(type -> class == OBERON_TYPE_RECORD)
1796         {
1797                 oberon_prevent_recursive_record(ctx, type);
1798         }
1799         else if(type -> class == OBERON_TYPE_ARRAY)
1800         {
1801                 oberon_prevent_recursive_array(ctx, type);
1802         }
1803         else if(type -> class == OBERON_TYPE_PROCEDURE)
1804         {
1805                 oberon_prevent_recursive_procedure(ctx, type);
1806         }
1807 }
1808
1809 static void
1810 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
1811 {
1812         switch(x -> class)
1813         {
1814                 case OBERON_CLASS_VAR:
1815                 case OBERON_CLASS_TYPE:
1816                 case OBERON_CLASS_PARAM:
1817                 case OBERON_CLASS_VAR_PARAM:
1818                 case OBERON_CLASS_FIELD:
1819                         oberon_prevent_recursive_type(ctx, x -> type);
1820                         break;
1821                 case OBERON_CLASS_CONST:
1822                 case OBERON_CLASS_PROC:
1823                         break;
1824                 default:
1825                         oberon_error(ctx, "oberon_prevent_recursive_object: wat");
1826                         break;
1827         }
1828 }
1829
1830 static void
1831 oberon_prevent_recursive_decl(oberon_context_t * ctx)
1832 {
1833         oberon_object_t * x = ctx -> decl -> list -> next;
1834
1835         while(x)
1836         {
1837                 oberon_prevent_recursive_object(ctx, x);
1838                 x = x -> next;
1839         }
1840 }
1841
1842 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
1843 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
1844
1845 static void
1846 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
1847 {
1848         if(type -> class != OBERON_TYPE_RECORD)
1849         {
1850                 return;
1851         }
1852
1853         int num_fields = type -> num_decl;
1854         oberon_object_t * field = type -> decl;
1855         for(int i = 0; i < num_fields; i++)
1856         {
1857                 if(field -> type -> class == OBERON_TYPE_POINTER)
1858                 {
1859                         oberon_initialize_type(ctx, field -> type);
1860                 }
1861
1862                 oberon_initialize_object(ctx, field);
1863                 field = field -> next;
1864         }
1865
1866         oberon_generator_init_record(ctx, type);
1867 }
1868
1869 static void
1870 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
1871 {
1872         if(type -> class == OBERON_TYPE_VOID)
1873         {
1874                 oberon_error(ctx, "undeclarated type");
1875         }
1876
1877         if(type -> initialized)
1878         {
1879                 return;
1880         }
1881
1882         type -> initialized = 1;
1883
1884         if(type -> class == OBERON_TYPE_POINTER)
1885         {
1886                 oberon_initialize_type(ctx, type -> base);
1887                 oberon_generator_init_type(ctx, type);
1888         }
1889         else if(type -> class == OBERON_TYPE_ARRAY)
1890         {
1891                 oberon_initialize_type(ctx, type -> base);
1892                 oberon_generator_init_type(ctx, type);
1893         }
1894         else if(type -> class == OBERON_TYPE_RECORD)
1895         {
1896                 oberon_generator_init_type(ctx, type);
1897                 oberon_initialize_record_fields(ctx, type);
1898         }
1899         else if(type -> class == OBERON_TYPE_PROCEDURE)
1900         {
1901                 int num_fields = type -> num_decl;
1902                 oberon_object_t * field = type -> decl;
1903                 for(int i = 0; i < num_fields; i++)
1904                 {
1905                         oberon_initialize_object(ctx, field);
1906                         field = field -> next;
1907                 }
1908
1909                 oberon_generator_init_type(ctx, type);
1910         }
1911         else
1912         {
1913                 oberon_generator_init_type(ctx, type);
1914         }
1915 }
1916
1917 static void
1918 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
1919 {
1920         printf("oberon_initialize_object: name %s class %i\n", x -> name, x -> class);
1921         switch(x -> class)
1922         {
1923                 case OBERON_CLASS_TYPE:
1924                         oberon_initialize_type(ctx, x -> type);
1925                         break;
1926                 case OBERON_CLASS_VAR:
1927                 case OBERON_CLASS_PARAM:
1928                 case OBERON_CLASS_VAR_PARAM:
1929                 case OBERON_CLASS_FIELD:
1930                         oberon_initialize_type(ctx, x -> type);
1931                         oberon_generator_init_var(ctx, x);
1932                         break;
1933                 case OBERON_CLASS_CONST:
1934                 case OBERON_CLASS_PROC:
1935                         break;
1936                 default:
1937                         oberon_error(ctx, "oberon_prevent_recursive_object: wat");
1938                         break;
1939         }
1940 }
1941
1942 static void
1943 oberon_initialize_decl(oberon_context_t * ctx)
1944 {
1945         oberon_object_t * x = ctx -> decl -> list;
1946
1947         while(x -> next)
1948         {
1949                 oberon_initialize_object(ctx, x -> next);
1950                 x = x -> next;
1951         }
1952 }
1953
1954 static void
1955 oberon_decl_seq(oberon_context_t * ctx)
1956 {
1957         if(ctx -> token == CONST)
1958         {
1959                 oberon_assert_token(ctx, CONST);
1960                 while(ctx -> token == IDENT)
1961                 {
1962                         oberon_const_decl(ctx);
1963                         oberon_assert_token(ctx, SEMICOLON);
1964                 }
1965         }
1966
1967         if(ctx -> token == TYPE)
1968         {
1969                 oberon_assert_token(ctx, TYPE);
1970                 while(ctx -> token == IDENT)
1971                 {
1972                         oberon_type_decl(ctx);
1973                         oberon_assert_token(ctx, SEMICOLON);
1974                 }
1975         }
1976
1977         if(ctx -> token == VAR)
1978         {
1979                 oberon_assert_token(ctx, VAR);
1980                 while(ctx -> token == IDENT)
1981                 {
1982                         oberon_var_decl(ctx);
1983                         oberon_assert_token(ctx, SEMICOLON);
1984                 }
1985         }
1986
1987         oberon_prevent_recursive_decl(ctx);
1988         oberon_initialize_decl(ctx);
1989
1990         while(ctx -> token == PROCEDURE)
1991         {
1992                 oberon_proc_decl(ctx);
1993                 oberon_assert_token(ctx, SEMICOLON);
1994         }
1995 }
1996
1997 static void
1998 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
1999 {
2000         oberon_autocast_to(ctx, src, dst -> result);
2001         oberon_generate_assign(ctx, src, dst);
2002 }
2003
2004 static void
2005 oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
2006 {
2007         if(desig -> result -> class != OBERON_TYPE_VOID)
2008         {
2009                 oberon_error(ctx, "procedure with result");
2010         }
2011
2012         oberon_autocast_call(ctx, desig);
2013         oberon_generate_call_proc(ctx, desig);
2014 }
2015
2016 static void
2017 oberon_statement(oberon_context_t * ctx)
2018 {
2019         oberon_expr_t * item1;
2020         oberon_expr_t * item2;
2021
2022         if(ctx -> token == IDENT)
2023         {
2024                 item1 = oberon_designator(ctx);
2025                 if(ctx -> token == ASSIGN)
2026                 {
2027                         oberon_assert_token(ctx, ASSIGN);
2028                         item2 = oberon_expr(ctx);
2029                         oberon_assign(ctx, item2, item1);
2030                 }
2031                 else
2032                 {
2033                         item1 = oberon_opt_proc_parens(ctx, item1);
2034                         oberon_make_call(ctx, item1);
2035                 }
2036         }
2037         else if(ctx -> token == RETURN)
2038         {
2039                 oberon_assert_token(ctx, RETURN);
2040                 if(ISEXPR(ctx -> token))
2041                 {
2042                         oberon_expr_t * expr;
2043                         expr = oberon_expr(ctx);
2044                         oberon_make_return(ctx, expr);
2045                 }
2046                 else
2047                 {
2048                         oberon_make_return(ctx, NULL);
2049                 }
2050         }
2051 }
2052
2053 static void
2054 oberon_statement_seq(oberon_context_t * ctx)
2055 {
2056         oberon_statement(ctx);
2057         while(ctx -> token == SEMICOLON)
2058         {
2059                 oberon_assert_token(ctx, SEMICOLON);
2060                 oberon_statement(ctx);
2061         }
2062 }
2063
2064 static void
2065 oberon_parse_module(oberon_context_t * ctx)
2066 {
2067         char *name1, *name2;
2068         oberon_read_token(ctx);
2069
2070         oberon_assert_token(ctx, MODULE);
2071         name1 = oberon_assert_ident(ctx);
2072         oberon_assert_token(ctx, SEMICOLON);
2073         ctx -> mod -> name = name1;
2074
2075         oberon_decl_seq(ctx);
2076
2077         if(ctx -> token == BEGIN)
2078         {
2079                 oberon_assert_token(ctx, BEGIN);
2080                 oberon_generate_begin_module(ctx);
2081                 oberon_statement_seq(ctx);
2082                 oberon_generate_end_module(ctx);
2083         }
2084
2085         oberon_assert_token(ctx, END);
2086         name2 = oberon_assert_ident(ctx);
2087         oberon_assert_token(ctx, DOT);
2088
2089         if(strcmp(name1, name2) != 0)
2090         {
2091                 oberon_error(ctx, "module name not matched");
2092         }
2093 }
2094
2095 // =======================================================================
2096 //   LIBRARY
2097 // =======================================================================
2098
2099 static void
2100 register_default_types(oberon_context_t * ctx)
2101 {
2102         ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2103         oberon_generator_init_type(ctx, ctx -> void_type);
2104
2105         ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
2106         ctx -> void_ptr_type -> base = ctx -> void_type;
2107         oberon_generator_init_type(ctx, ctx -> void_ptr_type);
2108
2109         ctx -> int_type = oberon_new_type_integer(sizeof(int));
2110         oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
2111
2112         ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
2113         oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
2114 }
2115
2116 oberon_context_t *
2117 oberon_create_context()
2118 {
2119         oberon_context_t * ctx = malloc(sizeof *ctx);
2120         memset(ctx, 0, sizeof *ctx);
2121
2122         oberon_scope_t * world_scope;
2123         world_scope = oberon_open_scope(ctx);
2124         ctx -> world_scope = world_scope;
2125
2126         oberon_generator_init_context(ctx);
2127
2128         register_default_types(ctx);
2129
2130         return ctx;
2131 }
2132
2133 void
2134 oberon_destroy_context(oberon_context_t * ctx)
2135 {
2136         oberon_generator_destroy_context(ctx);
2137         free(ctx);
2138 }
2139
2140 oberon_module_t *
2141 oberon_compile_module(oberon_context_t * ctx, const char * code)
2142 {
2143         oberon_module_t * mod = malloc(sizeof *mod);
2144         memset(mod, 0, sizeof *mod);
2145         ctx -> mod = mod;
2146
2147         oberon_scope_t * module_scope;
2148         module_scope = oberon_open_scope(ctx);
2149         mod -> decl = module_scope;
2150
2151         oberon_init_scaner(ctx, code);
2152         oberon_parse_module(ctx);
2153
2154         oberon_generate_code(ctx);
2155
2156         ctx -> mod = NULL;
2157         return mod;
2158 }