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