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 };
  53
  54 // =======================================================================
  55 //   UTILS
  56 // =======================================================================
  57
  58 void
  59 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
  60 {
  61         va_list ptr;
  62         va_start(ptr, fmt);
  63         fprintf(stderr, "error: ");
  64         vfprintf(stderr, fmt, ptr);
  65         fprintf(stderr, "\n");
  66         fprintf(stderr, "  code_index = %i\n", ctx -> code_index);
  67         fprintf(stderr, "  c          = %c\n", ctx -> c);
  68         fprintf(stderr, "  token      = %i\n", ctx -> token);
  69         va_end(ptr);
  70         exit(1);
  71 }
  72
  73 static oberon_type_t *
  74 oberon_new_type_ptr(int class)
  75 {
  76         oberon_type_t * x = malloc(sizeof *x);
  77         memset(x, 0, sizeof *x);
  78         x -> class = class;
  79         return x;
  80 }
  81
  82 static oberon_type_t *
  83 oberon_new_type_integer(int size)
  84 {
  85         oberon_type_t * x;
  86         x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
  87         x -> size = size;
  88         return x;
  89 }
  90
  91 static oberon_type_t *
  92 oberon_new_type_boolean(int size)
  93 {
  94         oberon_type_t * x;
  95         x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
  96         x -> size = size;
  97         return x;
  98 }
  99
 100 // =======================================================================
 101 //   TABLE
 102 // =======================================================================
 103
 104 static oberon_scope_t *
 105 oberon_open_scope(oberon_context_t * ctx)
 106 {
 107         oberon_scope_t * scope = malloc(sizeof *scope);
 108         memset(scope, 0, sizeof *scope);
 109
 110         oberon_object_t * list = malloc(sizeof *list);
 111         memset(list, 0, sizeof *list);
 112
 113         scope -> ctx = ctx;
 114         scope -> list = list;
 115         scope -> up = ctx -> decl;
 116
 117         ctx -> decl = scope;
 118         return scope;
 119 }
 120
 121 static void
 122 oberon_close_scope(oberon_scope_t * scope)
 123 {
 124         oberon_context_t * ctx = scope -> ctx;
 125         ctx -> decl = scope -> up;
 126 }
 127
 128 static oberon_object_t *
 129 oberon_define_object(oberon_scope_t * scope, char * name, int class)
 130 {
 131         oberon_object_t * x = scope -> list;
 132         while(x -> next && strcmp(x -> next -> name, name) != 0)
 133         {
 134                 x = x -> next;
 135         }
 136
 137         if(x -> next)
 138         {
 139                 oberon_error(scope -> ctx, "already defined");
 140         }
 141
 142         oberon_object_t * newvar = malloc(sizeof *newvar);
 143         memset(newvar, 0, sizeof *newvar);
 144         newvar -> name = name;
 145         newvar -> class = class;
 146
 147         x -> next = newvar;
 148
 149         return newvar;
 150 }
 151
 152 static void
 153 oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char *  name, oberon_type_t * type)
 154 {
 155         oberon_object_t * x = rec -> decl;
 156         while(x -> next && strcmp(x -> next -> name, name) != 0)
 157         {
 158                 x = x -> next;
 159         }
 160
 161         if(x -> next)
 162         {
 163                 oberon_error(ctx, "multiple definition");
 164         }
 165
 166         oberon_object_t * field = malloc(sizeof *field);
 167         memset(field, 0, sizeof *field);
 168         field -> name = name;
 169         field -> class = OBERON_CLASS_FIELD;
 170         field -> type = type;
 171
 172         rec -> num_decl += 1;
 173         oberon_generator_init_var(ctx, field);
 174
 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)
 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(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 static oberon_type_t *
 238 oberon_find_type(oberon_scope_t * scope, char * name)
 239 {
 240         oberon_object_t * x = oberon_find_object(scope, name);
 241         if(x -> class != OBERON_CLASS_TYPE)
 242         {
 243                 oberon_error(scope -> ctx, "%s not a type", name);
 244         }
 245
 246         return x -> type;
 247 }
 248
 249 static oberon_object_t *
 250 oberon_define_var(oberon_scope_t * scope, int class, char * name, oberon_type_t * type)
 251 {
 252         oberon_object_t * var;
 253         var = oberon_define_object(scope, name, class);
 254         var -> type = type;
 255         oberon_generator_init_var(scope -> ctx, var);
 256         return var;
 257 }
 258
 259 /*
 260 static oberon_object_t *
 261 oberon_find_var(oberon_scope_t * scope, char * name)
 262 {
 263         oberon_object_t * x = oberon_find_object(scope, name);
 264
 265         if(x -> class != OBERON_CLASS_VAR)
 266         {
 267                 oberon_error(scope -> ctx, "%s not a var", name);
 268         }
 269
 270         return x;
 271 }
 272 */
 273
 274 static oberon_object_t *
 275 oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signature)
 276 {
 277         oberon_object_t * proc;
 278         proc = oberon_define_object(scope, name, OBERON_CLASS_PROC);
 279         proc -> type = signature;
 280         oberon_generator_init_proc(scope -> ctx, proc);
 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 }
 391
 392 static void
 393 oberon_read_integer(oberon_context_t * ctx)
 394 {
 395         int len = 0;
 396         int i = ctx -> code_index;
 397
 398         int c = ctx -> code[i];
 399         while(isdigit(c))
 400         {
 401                 i += 1;
 402                 len += 1;
 403                 c = ctx -> code[i];
 404         }
 405
 406         char * ident = malloc(len + 2);
 407         memcpy(ident, &ctx->code[ctx->code_index], len);
 408         ident[len + 1] = 0;
 409
 410         ctx -> code_index = i;
 411         ctx -> c = ctx -> code[i];
 412         ctx -> string = ident;
 413         ctx -> integer = atoi(ident);
 414         ctx -> token = INTEGER;
 415 }
 416
 417 static void
 418 oberon_skip_space(oberon_context_t * ctx)
 419 {
 420         while(isspace(ctx -> c))
 421         {
 422                 oberon_get_char(ctx);
 423         }
 424 }
 425
 426 static void
 427 oberon_read_symbol(oberon_context_t * ctx)
 428 {
 429         int c = ctx -> c;
 430         switch(c)
 431         {
 432                 case 0:
 433                         ctx -> token = EOF_;
 434                         break;
 435                 case ';':
 436                         ctx -> token = SEMICOLON;
 437                         oberon_get_char(ctx);
 438                         break;
 439                 case ':':
 440                         ctx -> token = COLON;
 441                         oberon_get_char(ctx);
 442                         if(ctx -> c == '=')
 443                         {
 444                                 ctx -> token = ASSIGN;
 445                                 oberon_get_char(ctx);
 446                         }
 447                         break;
 448                 case '.':
 449                         ctx -> token = DOT;
 450                         oberon_get_char(ctx);
 451                         break;
 452                 case '(':
 453                         ctx -> token = LPAREN;
 454                         oberon_get_char(ctx);
 455                         break;
 456                 case ')':
 457                         ctx -> token = RPAREN;
 458                         oberon_get_char(ctx);
 459                         break;
 460                 case '=':
 461                         ctx -> token = EQUAL;
 462                         oberon_get_char(ctx);
 463                         break;
 464                 case '#':
 465                         ctx -> token = NEQ;
 466                         oberon_get_char(ctx);
 467                         break;
 468                 case '<':
 469                         ctx -> token = LESS;
 470                         oberon_get_char(ctx);
 471                         if(ctx -> c == '=')
 472                         {
 473                                 ctx -> token = LEQ;
 474                                 oberon_get_char(ctx);
 475                         }
 476                         break;
 477                 case '>':
 478                         ctx -> token = GREAT;
 479                         oberon_get_char(ctx);
 480                         if(ctx -> c == '=')
 481                         {
 482                                 ctx -> token = GEQ;
 483                                 oberon_get_char(ctx);
 484                         }
 485                         break;
 486                 case '+':
 487                         ctx -> token = PLUS;
 488                         oberon_get_char(ctx);
 489                         break;
 490                 case '-':
 491                         ctx -> token = MINUS;
 492                         oberon_get_char(ctx);
 493                         break;
 494                 case '*':
 495                         ctx -> token = STAR;
 496                         oberon_get_char(ctx);
 497                         break;
 498                 case '/':
 499                         ctx -> token = SLASH;
 500                         oberon_get_char(ctx);
 501                         break;
 502                 case '&':
 503                         ctx -> token = AND;
 504                         oberon_get_char(ctx);
 505                         break;
 506                 case '~':
 507                         ctx -> token = NOT;
 508                         oberon_get_char(ctx);
 509                         break;
 510                 case ',':
 511                         ctx -> token = COMMA;
 512                         oberon_get_char(ctx);
 513                         break;
 514                 case '[':
 515                         ctx -> token = LBRACE;
 516                         oberon_get_char(ctx);
 517                         break;
 518                 case ']':
 519                         ctx -> token = RBRACE;
 520                         oberon_get_char(ctx);
 521                         break;
 522                 default:
 523                         oberon_error(ctx, "invalid char");
 524                         break;
 525         }
 526 }
 527
 528 static void
 529 oberon_read_token(oberon_context_t * ctx)
 530 {
 531         oberon_skip_space(ctx);
 532
 533         int c = ctx -> c;
 534         if(isalpha(c))
 535         {
 536                 oberon_read_ident(ctx);
 537         }
 538         else if(isdigit(c))
 539         {
 540                 oberon_read_integer(ctx);
 541         }
 542         else
 543         {
 544                 oberon_read_symbol(ctx);
 545         }
 546 }
 547
 548 // =======================================================================
 549 //   EXPRESSION
 550 // =======================================================================
 551
 552 static void oberon_expect_token(oberon_context_t * ctx, int token);
 553 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
 554 static void oberon_assert_token(oberon_context_t * ctx, int token);
 555 static char * oberon_assert_ident(oberon_context_t * ctx);
 556 static oberon_type_t * oberon_type(oberon_context_t * ctx);
 557
 558 static oberon_expr_t *
 559 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
 560 {
 561         oberon_oper_t * operator;
 562         operator = malloc(sizeof *operator);
 563         memset(operator, 0, sizeof *operator);
 564
 565         operator -> is_item = 0;
 566         operator -> result = result;
 567         operator -> op = op;
 568         operator -> left = left;
 569         operator -> right = right;
 570
 571         return (oberon_expr_t *) operator;
 572 }
 573
 574 static oberon_expr_t *
 575 oberon_new_item(int mode, oberon_type_t * result)
 576 {
 577         oberon_item_t * item;
 578         item = malloc(sizeof *item);
 579         memset(item, 0, sizeof *item);
 580
 581         item -> is_item = 1;
 582         item -> result = result;
 583         item -> mode = mode;
 584
 585         return (oberon_expr_t *)item;
 586 }
 587
 588 static oberon_expr_t *
 589 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
 590 {
 591         oberon_expr_t * expr;
 592         oberon_type_t * result;
 593
 594         result = a -> result;
 595
 596         if(token == MINUS)
 597         {
 598                 if(result -> class != OBERON_TYPE_INTEGER)
 599                 {
 600                         oberon_error(ctx, "incompatible operator type");
 601                 }
 602
 603                 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
 604         }
 605         else if(token == NOT)
 606         {
 607                 if(result -> class != OBERON_TYPE_BOOLEAN)
 608                 {
 609                         oberon_error(ctx, "incompatible operator type");
 610                 }
 611
 612                 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
 613         }
 614         else
 615         {
 616                 oberon_error(ctx, "oberon_make_unary_op: wat");
 617         }
 618
 619         return expr;
 620 }
 621
 622 static void
 623 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first)
 624 {
 625         oberon_expr_t * last;
 626
 627         *num_expr = 1;
 628         *first = last = oberon_expr(ctx);
 629         while(ctx -> token == COMMA)
 630         {
 631                 oberon_assert_token(ctx, COMMA);
 632                 oberon_expr_t * current;
 633                 current = oberon_expr(ctx);
 634                 last -> next = current;
 635                 last = current;
 636                 *num_expr += 1;
 637         }
 638 }
 639
 640 static oberon_expr_t *
 641 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
 642 {
 643         if(pref -> class != expr -> result -> class)
 644         {
 645                 oberon_error(ctx, "incompatible types");
 646         }
 647
 648
 649         if(pref -> class == OBERON_TYPE_INTEGER)
 650         {
 651                 if(expr -> result -> class > pref -> class)
 652                 {
 653                         oberon_error(ctx, "incompatible size");
 654                 }
 655         }
 656
 657         // TODO cast
 658
 659         return expr;
 660 }
 661
 662 static void
 663 oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
 664 {
 665         if(desig -> is_item == 0)
 666         {
 667                 oberon_error(ctx, "expected item");
 668         }
 669
 670         if(desig -> item.mode != MODE_CALL)
 671         {
 672                 oberon_error(ctx, "expected mode CALL");
 673         }
 674
 675         if(desig -> item.var -> class != OBERON_CLASS_PROC)
 676         {
 677                 oberon_error(ctx, "only procedures can be called");
 678         }
 679
 680         oberon_type_t * fn = desig -> item.var -> type;
 681         int num_args = desig -> item.num_args;
 682         int num_decl = fn -> num_decl;
 683
 684         if(num_args < num_decl)
 685         {
 686                 oberon_error(ctx, "too few arguments");
 687         }
 688         else if(num_args > num_decl)
 689         {
 690                 oberon_error(ctx, "too many arguments");
 691         }
 692
 693         oberon_expr_t * arg = desig -> item.args;
 694         oberon_object_t * param = fn -> decl;
 695         for(int i = 0; i < num_args; i++)
 696         {
 697                 oberon_autocast_to(ctx, arg, param -> type);
 698                 arg = arg -> next;
 699                 param = param -> next;
 700         }
 701 }
 702
 703 #define ISEXPR(x) \
 704         (((x) == PLUS) \
 705         || ((x) == MINUS) \
 706         || ((x) == IDENT) \
 707         || ((x) == INTEGER) \
 708         || ((x) == LPAREN) \
 709         || ((x) == NOT) \
 710         || ((x) == TRUE) \
 711         || ((x) == FALSE))
 712
 713 #define ISSELECTOR(x) \
 714         (((x) == LBRACE) \
 715         || ((x) == DOT))
 716
 717 static oberon_expr_t *
 718 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, int num_indexes, oberon_expr_t * indexes)
 719 {
 720         assert(desig -> is_item == 1);
 721
 722         if(desig -> item.mode != MODE_VAR)
 723         {
 724                 oberon_error(ctx, "not MODE_VAR");
 725         }
 726
 727         int class = desig -> item.var -> class;
 728         switch(class)
 729         {
 730                 case OBERON_CLASS_VAR:
 731                 case OBERON_CLASS_VAR_PARAM:
 732                 case OBERON_CLASS_PARAM:
 733                         break;
 734                 default:
 735                         oberon_error(ctx, "not variable");
 736                         break;
 737         }
 738
 739         oberon_type_t * type = desig -> item.var -> type;
 740         if(type -> class != OBERON_TYPE_ARRAY)
 741         {
 742                 oberon_error(ctx, "not array");
 743         }
 744
 745         int dim = desig -> item.var -> type -> dim;
 746         if(num_indexes != dim)
 747         {
 748                 oberon_error(ctx, "dimesions not matched");
 749         }
 750
 751         oberon_type_t * base = desig -> item.var -> type -> base;
 752
 753         oberon_expr_t * selector;
 754         selector = oberon_new_item(MODE_INDEX, base);
 755         selector -> item.parent = (oberon_item_t *) desig;
 756         selector -> item.num_args = num_indexes;
 757         selector -> item.args = indexes;
 758
 759         return selector;
 760 }
 761
 762 static oberon_expr_t *
 763 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
 764 {
 765         assert(expr -> is_item == 1);
 766
 767         int class = expr -> result -> class;
 768         if(class != OBERON_TYPE_RECORD)
 769         {
 770                 oberon_error(ctx, "not record");
 771         }
 772
 773         oberon_type_t * rec = expr -> result;
 774
 775         oberon_object_t * field;
 776         field = oberon_find_field(ctx, rec, name);
 777
 778         oberon_expr_t * selector;
 779         selector = oberon_new_item(MODE_FIELD, field -> type);
 780         selector -> item.var = field;
 781         selector -> item.parent = (oberon_item_t *) expr;
 782
 783         return selector;
 784 }
 785
 786 static oberon_expr_t *
 787 oberon_designator(oberon_context_t * ctx)
 788 {
 789         char * name;
 790         oberon_object_t * var;
 791         oberon_expr_t * expr;
 792
 793         name = oberon_assert_ident(ctx);
 794         var = oberon_find_object(ctx -> decl, name);
 795
 796         switch(var -> class)
 797         {
 798                 case OBERON_CLASS_CONST:
 799                         // TODO copy value
 800                         expr = (oberon_expr_t *) var -> value;
 801                         break;
 802                 case OBERON_CLASS_VAR:
 803                 case OBERON_CLASS_VAR_PARAM:
 804                 case OBERON_CLASS_PARAM:
 805                         expr = oberon_new_item(MODE_VAR, var -> type);
 806                         break;
 807                 case OBERON_CLASS_PROC:
 808                         expr = oberon_new_item(MODE_CALL, var -> type);
 809                         break;
 810                 default:
 811                         oberon_error(ctx, "invalid designator");
 812                         break;
 813         }
 814         expr -> item.var = var;
 815
 816         while(ISSELECTOR(ctx -> token))
 817         {
 818                 switch(ctx -> token)
 819                 {
 820                         case DOT:
 821                                 oberon_assert_token(ctx, DOT);
 822                                 name = oberon_assert_ident(ctx);
 823                                 expr = oberon_make_record_selector(ctx, expr, name);
 824                                 break;
 825                         case LBRACE:
 826                                 oberon_assert_token(ctx, LBRACE);
 827                                 int num_indexes = 0;
 828                                 oberon_expr_t * indexes = NULL;
 829                                 oberon_expr_list(ctx, &num_indexes, &indexes);
 830                                 oberon_assert_token(ctx, RBRACE);
 831                                 expr = oberon_make_array_selector(ctx, expr, num_indexes, indexes);
 832                                 break;
 833                         default:
 834                                 oberon_error(ctx, "oberon_designator: wat");
 835                                 break;
 836                 }
 837         }
 838         return expr;
 839 }
 840
 841 static oberon_expr_t *
 842 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 843 {
 844         assert(expr -> is_item == 1);
 845
 846         if(ctx -> token == LPAREN)
 847         {
 848                 if(expr -> result -> class != OBERON_TYPE_PROCEDURE)
 849                 {
 850                         oberon_error(ctx, "not a procedure");
 851                 }
 852
 853                 oberon_assert_token(ctx, LPAREN);
 854
 855                 int num_args = 0;
 856                 oberon_expr_t * arguments = NULL;
 857
 858                 if(ISEXPR(ctx -> token))
 859                 {
 860                         oberon_expr_list(ctx, &num_args, &arguments);
 861                 }
 862
 863                 expr -> result = expr -> item.var -> type -> base;
 864                 expr -> item.mode = MODE_CALL;
 865                 expr -> item.num_args = num_args;
 866                 expr -> item.args = arguments;
 867                 oberon_assert_token(ctx, RPAREN);
 868
 869                 oberon_autocast_call(ctx, expr);
 870         }
 871
 872         return expr;
 873 }
 874
 875 static oberon_expr_t *
 876 oberon_factor(oberon_context_t * ctx)
 877 {
 878         oberon_expr_t * expr;
 879
 880         switch(ctx -> token)
 881         {
 882                 case IDENT:
 883                         expr = oberon_designator(ctx);
 884                         expr = oberon_opt_proc_parens(ctx, expr);
 885                         break;
 886                 case INTEGER:
 887                         expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
 888                         expr -> item.integer = ctx -> integer;
 889                         oberon_assert_token(ctx, INTEGER);
 890                         break;
 891                 case TRUE:
 892                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 893                         expr -> item.boolean = 1;
 894                         oberon_assert_token(ctx, TRUE);
 895                         break;
 896                 case FALSE:
 897                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 898                         expr -> item.boolean = 0;
 899                         oberon_assert_token(ctx, FALSE);
 900                         break;
 901                 case LPAREN:
 902                         oberon_assert_token(ctx, LPAREN);
 903                         expr = oberon_expr(ctx);
 904                         oberon_assert_token(ctx, RPAREN);
 905                         break;
 906                 case NOT:
 907                         oberon_assert_token(ctx, NOT);
 908                         expr = oberon_factor(ctx);
 909                         expr = oberon_make_unary_op(ctx, NOT, expr);
 910                         break;
 911                 default:
 912                         oberon_error(ctx, "invalid expression");
 913         }
 914
 915         return expr;
 916 }
 917
 918 /*
 919  * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
 920  *   1. Классы обоих типов должны быть одинаковы
 921  *   2. В качестве результата должен быть выбран больший тип.
 922  *   3. Если размер результат не должен быть меньше чем базовый int
 923  */
 924
 925 static void
 926 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
 927 {
 928         if((a -> class) != (b -> class))
 929         {
 930                 oberon_error(ctx, "incompatible types");
 931         }
 932
 933         if((a -> size) > (b -> size))
 934         {
 935                 *result = a;
 936         }
 937         else
 938         {
 939                 *result = b;
 940         }
 941
 942         if(((*result) -> class) == OBERON_TYPE_INTEGER)
 943         {
 944                 if(((*result) -> size) < (ctx -> int_type -> size))
 945                 {
 946                         *result = ctx -> int_type;
 947                 }
 948         }
 949
 950         /* TODO: cast types */
 951 }
 952
 953 #define ITMAKESBOOLEAN(x) \
 954         (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
 955
 956 #define ITUSEONLYINTEGER(x) \
 957         ((x) >= LESS && (x) <= GEQ)
 958
 959 #define ITUSEONLYBOOLEAN(x) \
 960         (((x) == OR) || ((x) == AND))
 961
 962 static oberon_expr_t *
 963 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
 964 {
 965         oberon_expr_t * expr;
 966         oberon_type_t * result;
 967
 968         if(ITMAKESBOOLEAN(token))
 969         {
 970                 if(ITUSEONLYINTEGER(token))
 971                 {
 972                         if(a -> result -> class != OBERON_TYPE_INTEGER
 973                                 || b -> result -> class != OBERON_TYPE_INTEGER)
 974                         {
 975                                 oberon_error(ctx, "used only with integer types");
 976                         }
 977                 }
 978                 else if(ITUSEONLYBOOLEAN(token))
 979                 {
 980                         if(a -> result -> class != OBERON_TYPE_BOOLEAN
 981                                 || b -> result -> class != OBERON_TYPE_BOOLEAN)
 982                         {
 983                                 oberon_error(ctx, "used only with boolean type");
 984                         }
 985                 }
 986
 987                 result = ctx -> bool_type;
 988
 989                 if(token == EQUAL)
 990                 {
 991                         expr = oberon_new_operator(OP_EQ, result, a, b);
 992                 }
 993                 else if(token == NEQ)
 994                 {
 995                         expr = oberon_new_operator(OP_NEQ, result, a, b);
 996                 }
 997                 else if(token == LESS)
 998                 {
 999                         expr = oberon_new_operator(OP_LSS, result, a, b);
1000                 }
1001                 else if(token == LEQ)
1002                 {
1003                         expr = oberon_new_operator(OP_LEQ, result, a, b);
1004                 }
1005                 else if(token == GREAT)
1006                 {
1007                         expr = oberon_new_operator(OP_GRT, result, a, b);
1008                 }
1009                 else if(token == GEQ)
1010                 {
1011                         expr = oberon_new_operator(OP_GEQ, result, a, b);
1012                 }
1013                 else if(token == OR)
1014                 {
1015                         expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1016                 }
1017                 else if(token == AND)
1018                 {
1019                         expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1020                 }
1021                 else
1022                 {
1023                         oberon_error(ctx, "oberon_make_bin_op: bool wat");
1024                 }
1025         }
1026         else
1027         {
1028                 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1029
1030                 if(token == PLUS)
1031                 {
1032                         expr = oberon_new_operator(OP_ADD, result, a, b);
1033                 }
1034                 else if(token == MINUS)
1035                 {
1036                         expr = oberon_new_operator(OP_SUB, result, a, b);
1037                 }
1038                 else if(token == STAR)
1039                 {
1040                         expr = oberon_new_operator(OP_MUL, result, a, b);
1041                 }
1042                 else if(token == SLASH)
1043                 {
1044                         expr = oberon_new_operator(OP_DIV, result, a, b);
1045                 }
1046                 else if(token == DIV)
1047                 {
1048                         expr = oberon_new_operator(OP_DIV, result, a, b);
1049                 }
1050                 else if(token == MOD)
1051                 {
1052                         expr = oberon_new_operator(OP_MOD, result, a, b);
1053                 }
1054                 else
1055                 {
1056                         oberon_error(ctx, "oberon_make_bin_op: bin wat");
1057                 }
1058         }
1059
1060         return expr;
1061 }
1062
1063 #define ISMULOP(x) \
1064         ((x) >= STAR && (x) <= AND)
1065
1066 static oberon_expr_t *
1067 oberon_term_expr(oberon_context_t * ctx)
1068 {
1069         oberon_expr_t * expr;
1070
1071         expr = oberon_factor(ctx);
1072         while(ISMULOP(ctx -> token))
1073         {
1074                 int token = ctx -> token;
1075                 oberon_read_token(ctx);
1076
1077                 oberon_expr_t * inter = oberon_factor(ctx);
1078                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1079         }
1080
1081         return expr;
1082 }
1083
1084 #define ISADDOP(x) \
1085         ((x) >= PLUS && (x) <= OR)
1086
1087 static oberon_expr_t *
1088 oberon_simple_expr(oberon_context_t * ctx)
1089 {
1090         oberon_expr_t * expr;
1091
1092         int minus = 0;
1093         if(ctx -> token == PLUS)
1094         {
1095                 minus = 0;
1096                 oberon_assert_token(ctx, PLUS);
1097         }
1098         else if(ctx -> token == MINUS)
1099         {
1100                 minus = 1;
1101                 oberon_assert_token(ctx, MINUS);
1102         }
1103
1104         expr = oberon_term_expr(ctx);
1105         while(ISADDOP(ctx -> token))
1106         {
1107                 int token = ctx -> token;
1108                 oberon_read_token(ctx);
1109
1110                 oberon_expr_t * inter = oberon_term_expr(ctx);
1111                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1112         }
1113
1114         if(minus)
1115         {
1116                 expr = oberon_make_unary_op(ctx, MINUS, expr);
1117         }
1118
1119         return expr;
1120 }
1121
1122 #define ISRELATION(x) \
1123         ((x) >= EQUAL && (x) <= GEQ)
1124
1125 static oberon_expr_t *
1126 oberon_expr(oberon_context_t * ctx)
1127 {
1128         oberon_expr_t * expr;
1129
1130         expr = oberon_simple_expr(ctx);
1131         while(ISRELATION(ctx -> token))
1132         {
1133                 int token = ctx -> token;
1134                 oberon_read_token(ctx);
1135
1136                 oberon_expr_t * inter = oberon_simple_expr(ctx);
1137                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1138         }
1139
1140         return expr;
1141 }
1142
1143 static oberon_item_t *
1144 oberon_const_expr(oberon_context_t * ctx)
1145 {
1146         oberon_expr_t * expr;
1147         expr = oberon_expr(ctx);
1148
1149         if(expr -> is_item == 0)
1150         {
1151                 oberon_error(ctx, "const expression are required");
1152         }
1153
1154         return (oberon_item_t *) expr;
1155 }
1156
1157 // =======================================================================
1158 //   PARSER
1159 // =======================================================================
1160
1161 static void oberon_statement_seq(oberon_context_t * ctx);
1162
1163 static void
1164 oberon_expect_token(oberon_context_t * ctx, int token)
1165 {
1166         if(ctx -> token != token)
1167         {
1168                 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1169         }
1170 }
1171
1172 static void
1173 oberon_assert_token(oberon_context_t * ctx, int token)
1174 {
1175         oberon_expect_token(ctx, token);
1176         oberon_read_token(ctx);
1177 }
1178
1179 static char *
1180 oberon_assert_ident(oberon_context_t * ctx)
1181 {
1182         oberon_expect_token(ctx, IDENT);
1183         char * ident = ctx -> string;
1184         oberon_read_token(ctx);
1185         return ident;
1186 }
1187
1188 static oberon_type_t *
1189 oberon_make_array_type(oberon_context_t * ctx, int dim, oberon_item_t * size, oberon_type_t * base)
1190 {
1191         assert(dim == 1);
1192         oberon_type_t * newtype;
1193
1194         if(size -> mode != MODE_INTEGER)
1195         {
1196                 oberon_error(ctx, "requires integer constant");
1197         }
1198
1199         newtype = oberon_new_type_ptr(OBERON_TYPE_ARRAY);
1200         newtype -> dim = dim;
1201         newtype -> size = size -> integer;
1202         newtype -> base = base;
1203         oberon_generator_init_type(ctx, newtype);
1204
1205         return newtype;
1206 }
1207
1208 static void
1209 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1210 {
1211         if(ctx -> token == IDENT)
1212         {
1213                 char * name;
1214                 oberon_type_t * type;
1215                 name = oberon_assert_ident(ctx);
1216                 oberon_assert_token(ctx, COLON);
1217                 type = oberon_type(ctx);
1218                 oberon_define_field(ctx, rec, name, type);
1219         }
1220 }
1221
1222 static oberon_type_t * oberon_opt_formal_pars(oberon_context_t * ctx, int class);
1223
1224 static oberon_type_t *
1225 oberon_type(oberon_context_t * ctx)
1226 {
1227         oberon_type_t * type;
1228
1229         if(ctx -> token == IDENT)
1230         {
1231                 char * name = oberon_assert_ident(ctx);
1232                 type = oberon_find_type(ctx -> decl, name);
1233         }
1234         else if(ctx -> token == ARRAY)
1235         {
1236                 oberon_assert_token(ctx, ARRAY);
1237                 oberon_item_t * size = oberon_const_expr(ctx);
1238                 oberon_assert_token(ctx, OF);
1239                 oberon_type_t * base = oberon_type(ctx);
1240                 type = oberon_make_array_type(ctx, 1, size, base);
1241         }
1242         else if(ctx -> token == RECORD)
1243         {
1244                 type = oberon_new_type_ptr(OBERON_TYPE_RECORD);
1245                 oberon_object_t * list = malloc(sizeof *list);
1246                 memset(list, 0, sizeof *list);
1247                 type -> num_decl = 0;
1248                 type -> base = NULL;
1249                 type -> decl = list;
1250
1251                 oberon_assert_token(ctx, RECORD);
1252                 oberon_field_list(ctx, type);
1253                 while(ctx -> token == SEMICOLON)
1254                 {
1255                         oberon_assert_token(ctx, SEMICOLON);
1256                         oberon_field_list(ctx, type);
1257                 }
1258                 oberon_assert_token(ctx, END);
1259
1260                 type -> decl = type -> decl -> next;
1261                 oberon_generator_init_type(ctx, type);
1262         }
1263         else if(ctx -> token == PROCEDURE)
1264         {
1265                 oberon_assert_token(ctx, PROCEDURE);
1266                 type = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE);
1267         }
1268         else
1269         {
1270                 oberon_error(ctx, "invalid type declaration");
1271         }
1272
1273         return type;
1274 }
1275
1276 static void
1277 oberon_var_decl(oberon_context_t * ctx)
1278 {
1279         char * name = oberon_assert_ident(ctx);
1280         oberon_assert_token(ctx, COLON);
1281         oberon_type_t * type = oberon_type(ctx);
1282         oberon_define_var(ctx -> decl, OBERON_CLASS_VAR, name, type);
1283 }
1284
1285 static oberon_object_t *
1286 oberon_make_param(oberon_context_t * ctx, int token, char * name, oberon_type_t * type)
1287 {
1288         oberon_object_t * param;
1289
1290         if(token == VAR)
1291         {
1292                 param = oberon_define_var(ctx -> decl, OBERON_CLASS_VAR_PARAM, name, type);
1293         }
1294         else if(token == IDENT)
1295         {
1296                 param = oberon_define_var(ctx -> decl, OBERON_CLASS_PARAM, name, type);
1297         }
1298         else
1299         {
1300                 oberon_error(ctx, "oberon_make_param: wat");
1301         }
1302
1303         return param;
1304 }
1305
1306 static oberon_object_t *
1307 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1308 {
1309         int modifer_token = ctx -> token;
1310         if(ctx -> token == VAR)
1311         {
1312                 oberon_read_token(ctx);
1313         }
1314
1315         char * name;
1316         name = oberon_assert_ident(ctx);
1317
1318         oberon_assert_token(ctx, COLON);
1319
1320         oberon_type_t * type;
1321         type = oberon_type(ctx);
1322
1323         oberon_object_t * first;
1324         first = oberon_make_param(ctx, modifer_token, name, type);
1325
1326         *num_decl += 1;
1327         return first;
1328 }
1329
1330 #define ISFPSECTION \
1331         ((ctx -> token == VAR) || (ctx -> token == IDENT))
1332
1333 static oberon_type_t *
1334 oberon_formal_pars(oberon_context_t * ctx)
1335 {
1336         oberon_type_t * tp;
1337         tp = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
1338         tp -> num_decl = 0;
1339         tp -> base = ctx -> void_type;
1340         tp -> decl = NULL;
1341
1342         oberon_assert_token(ctx, LPAREN);
1343
1344         if(ISFPSECTION)
1345         {
1346                 tp -> decl = oberon_fp_section(ctx, &tp -> num_decl);
1347                 while(ctx -> token == SEMICOLON)
1348                 {
1349                         oberon_assert_token(ctx, SEMICOLON);
1350                         oberon_fp_section(ctx, &tp -> num_decl);
1351                 }
1352         }
1353
1354         oberon_assert_token(ctx, RPAREN);
1355
1356         if(ctx -> token == COLON)
1357         {
1358                 oberon_assert_token(ctx, COLON);
1359                 tp -> base = oberon_type(ctx);
1360         }
1361
1362         oberon_generator_init_type(ctx, tp);
1363         return tp;
1364 }
1365
1366 static oberon_type_t *
1367 oberon_opt_formal_pars(oberon_context_t * ctx, int class)
1368 {
1369         oberon_type_t * signature;
1370
1371         if(ctx -> token == LPAREN)
1372         {
1373                 signature = oberon_formal_pars(ctx);
1374         }
1375         else
1376         {
1377                 signature = oberon_new_type_ptr(class);
1378                 signature -> num_decl = 0;
1379                 signature -> base = ctx -> void_type;
1380                 signature -> decl = NULL;
1381                 oberon_generator_init_type(ctx, signature);
1382         }
1383
1384         return signature;
1385 }
1386
1387 static void
1388 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1389 {
1390         if(ctx -> result_type -> class == OBERON_TYPE_VOID)
1391         {
1392                 if(expr != NULL)
1393                 {
1394                         oberon_error(ctx, "procedure has no result type");
1395                 }
1396         }
1397         else
1398         {
1399                 if(expr == NULL)
1400                 {
1401                         oberon_error(ctx, "procedure requires expression on result");
1402                 }
1403
1404                 oberon_autocast_to(ctx, expr, ctx -> result_type);
1405         }
1406
1407         ctx -> has_return = 1;
1408
1409         oberon_generate_return(ctx, expr);
1410 }
1411
1412 static void
1413 oberon_proc_decl(oberon_context_t * ctx)
1414 {
1415         oberon_assert_token(ctx, PROCEDURE);
1416
1417         char * name;
1418         name = oberon_assert_ident(ctx);
1419
1420         oberon_scope_t * this_proc_def_scope = ctx -> decl;
1421         oberon_open_scope(ctx);
1422
1423         oberon_type_t * signature;
1424         signature = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE);
1425
1426         oberon_object_t * proc;
1427         proc = oberon_define_proc(this_proc_def_scope, name, signature);
1428
1429         ctx -> result_type = signature -> base;
1430         ctx -> has_return = 0;
1431
1432         oberon_assert_token(ctx, SEMICOLON);
1433
1434         oberon_generate_begin_proc(ctx, proc);
1435
1436         // TODO declarations
1437
1438         if(ctx -> token == BEGIN)
1439         {
1440                 oberon_assert_token(ctx, BEGIN);
1441                 oberon_statement_seq(ctx);
1442         }
1443
1444         oberon_assert_token(ctx, END);
1445         char * name2 = oberon_assert_ident(ctx);
1446         if(strcmp(name2, name) != 0)
1447         {
1448                 oberon_error(ctx, "procedure name not matched");
1449         }
1450
1451         if(signature -> base -> class == OBERON_TYPE_VOID)
1452         {
1453                 oberon_make_return(ctx, NULL);
1454         }
1455
1456         if(ctx -> has_return == 0)
1457         {
1458                 oberon_error(ctx, "procedure requires return");
1459         }
1460         ctx -> result_type = NULL;
1461
1462         oberon_generate_end_proc(ctx);
1463         oberon_close_scope(ctx -> decl);
1464 }
1465
1466 static void
1467 oberon_const_decl(oberon_context_t * ctx)
1468 {
1469         char * name;
1470         oberon_item_t * value;
1471         oberon_object_t * constant;
1472
1473         name = oberon_assert_ident(ctx);
1474         oberon_assert_token(ctx, EQUAL);
1475         value = oberon_const_expr(ctx);
1476
1477         constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST);
1478         constant -> value = value;
1479 }
1480
1481 static void
1482 oberon_type_decl(oberon_context_t * ctx)
1483 {
1484         char * name;
1485         oberon_object_t * newtype;
1486         oberon_type_t * type;
1487
1488         name = oberon_assert_ident(ctx);
1489         oberon_assert_token(ctx, EQUAL);
1490         type = oberon_type(ctx);
1491
1492         newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1493         newtype -> type = type;
1494 }
1495
1496 static void
1497 oberon_decl_seq(oberon_context_t * ctx)
1498 {
1499         if(ctx -> token == CONST)
1500         {
1501                 oberon_assert_token(ctx, CONST);
1502                 while(ctx -> token == IDENT)
1503                 {
1504                         oberon_const_decl(ctx);
1505                         oberon_assert_token(ctx, SEMICOLON);
1506                 }
1507         }
1508
1509         if(ctx -> token == TYPE)
1510         {
1511                 oberon_assert_token(ctx, TYPE);
1512                 while(ctx -> token == IDENT)
1513                 {
1514                         oberon_type_decl(ctx);
1515                         oberon_assert_token(ctx, SEMICOLON);
1516                 }
1517         }
1518
1519         if(ctx -> token == VAR)
1520         {
1521                 oberon_assert_token(ctx, VAR);
1522                 while(ctx -> token == IDENT)
1523                 {
1524                         oberon_var_decl(ctx);
1525                         oberon_assert_token(ctx, SEMICOLON);
1526                 }
1527         }
1528
1529         while(ctx -> token == PROCEDURE)
1530         {
1531                 oberon_proc_decl(ctx);
1532                 oberon_assert_token(ctx, SEMICOLON);
1533         }
1534 }
1535
1536 static void
1537 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
1538 {
1539         oberon_autocast_to(ctx, src, dst -> result);
1540         oberon_generate_assign(ctx, src, dst);
1541 }
1542
1543 static void
1544 oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
1545 {
1546         oberon_autocast_call(ctx, desig);
1547         oberon_generate_call_proc(ctx, desig);
1548 }
1549
1550 static void
1551 oberon_statement(oberon_context_t * ctx)
1552 {
1553         oberon_expr_t * item1;
1554         oberon_expr_t * item2;
1555
1556         if(ctx -> token == IDENT)
1557         {
1558                 item1 = oberon_designator(ctx);
1559                 if(ctx -> token == ASSIGN)
1560                 {
1561                         oberon_assert_token(ctx, ASSIGN);
1562                         item2 = oberon_expr(ctx);
1563                         oberon_assign(ctx, item2, item1);
1564                 }
1565                 else
1566                 {
1567                         item1 = oberon_opt_proc_parens(ctx, item1);
1568                         oberon_make_call(ctx, item1);
1569                 }
1570         }
1571         else if(ctx -> token == RETURN)
1572         {
1573                 oberon_assert_token(ctx, RETURN);
1574                 if(ISEXPR(ctx -> token))
1575                 {
1576                         oberon_expr_t * expr;
1577                         expr = oberon_expr(ctx);
1578                         oberon_make_return(ctx, expr);
1579                 }
1580                 else
1581                 {
1582                         oberon_make_return(ctx, NULL);
1583                 }
1584         }
1585 }
1586
1587 static void
1588 oberon_statement_seq(oberon_context_t * ctx)
1589 {
1590         oberon_statement(ctx);
1591         while(ctx -> token == SEMICOLON)
1592         {
1593                 oberon_assert_token(ctx, SEMICOLON);
1594                 oberon_statement(ctx);
1595         }
1596 }
1597
1598 static void
1599 oberon_parse_module(oberon_context_t * ctx)
1600 {
1601         char *name1, *name2;
1602         oberon_read_token(ctx);
1603
1604         oberon_assert_token(ctx, MODULE);
1605         name1 = oberon_assert_ident(ctx);
1606         oberon_assert_token(ctx, SEMICOLON);
1607         ctx -> mod -> name = name1;
1608
1609         oberon_decl_seq(ctx);
1610
1611         if(ctx -> token == BEGIN)
1612         {
1613                 oberon_assert_token(ctx, BEGIN);
1614                 oberon_generate_begin_module(ctx);
1615                 oberon_statement_seq(ctx);
1616                 oberon_generate_end_module(ctx);
1617         }
1618
1619         oberon_assert_token(ctx, END);
1620         name2 = oberon_assert_ident(ctx);
1621         oberon_assert_token(ctx, DOT);
1622
1623         if(strcmp(name1, name2) != 0)
1624         {
1625                 oberon_error(ctx, "module name not matched");
1626         }
1627 }
1628
1629 // =======================================================================
1630 //   LIBRARY
1631 // =======================================================================
1632
1633 static void
1634 register_default_types(oberon_context_t * ctx)
1635 {
1636         ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1637         oberon_generator_init_type(ctx, ctx -> void_type);
1638
1639         ctx -> int_type = oberon_new_type_integer(sizeof(int));
1640         oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
1641
1642         ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
1643         oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
1644 }
1645
1646 oberon_context_t *
1647 oberon_create_context()
1648 {
1649         oberon_context_t * ctx = malloc(sizeof *ctx);
1650         memset(ctx, 0, sizeof *ctx);
1651
1652         oberon_scope_t * world_scope;
1653         world_scope = oberon_open_scope(ctx);
1654         ctx -> world_scope = world_scope;
1655
1656         oberon_generator_init_context(ctx);
1657
1658         register_default_types(ctx);
1659
1660         return ctx;
1661 }
1662
1663 void
1664 oberon_destroy_context(oberon_context_t * ctx)
1665 {
1666         oberon_generator_destroy_context(ctx);
1667         free(ctx);
1668 }
1669
1670 oberon_module_t *
1671 oberon_compile_module(oberon_context_t * ctx, const char * code)
1672 {
1673         oberon_module_t * mod = malloc(sizeof *mod);
1674         memset(mod, 0, sizeof *mod);
1675         ctx -> mod = mod;
1676
1677         oberon_scope_t * module_scope;
1678         module_scope = oberon_open_scope(ctx);
1679         mod -> decl = module_scope;
1680
1681         oberon_init_scaner(ctx, code);
1682         oberon_parse_module(ctx);
1683
1684         oberon_generate_code(ctx);
1685
1686         ctx -> mod = NULL;
1687         return mod;
1688 }