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         else if(pref -> class == OBERON_TYPE_RECORD)
 657         {
 658                 if(expr -> result != pref)
 659                 {
 660                         printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
 661                         oberon_error(ctx, "incompatible record types");
 662                 }
 663         }
 664
 665         // TODO cast
 666
 667         return expr;
 668 }
 669
 670 static void
 671 oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
 672 {
 673         if(desig -> is_item == 0)
 674         {
 675                 oberon_error(ctx, "expected item");
 676         }
 677
 678         if(desig -> item.mode != MODE_CALL)
 679         {
 680                 oberon_error(ctx, "expected mode CALL");
 681         }
 682
 683         if(desig -> item.var -> class != OBERON_CLASS_PROC)
 684         {
 685                 oberon_error(ctx, "only procedures can be called");
 686         }
 687
 688         oberon_type_t * fn = desig -> item.var -> type;
 689         int num_args = desig -> item.num_args;
 690         int num_decl = fn -> num_decl;
 691
 692         if(num_args < num_decl)
 693         {
 694                 oberon_error(ctx, "too few arguments");
 695         }
 696         else if(num_args > num_decl)
 697         {
 698                 oberon_error(ctx, "too many arguments");
 699         }
 700
 701         oberon_expr_t * arg = desig -> item.args;
 702         oberon_object_t * param = fn -> decl;
 703         for(int i = 0; i < num_args; i++)
 704         {
 705                 oberon_autocast_to(ctx, arg, param -> type);
 706                 arg = arg -> next;
 707                 param = param -> next;
 708         }
 709 }
 710
 711 #define ISEXPR(x) \
 712         (((x) == PLUS) \
 713         || ((x) == MINUS) \
 714         || ((x) == IDENT) \
 715         || ((x) == INTEGER) \
 716         || ((x) == LPAREN) \
 717         || ((x) == NOT) \
 718         || ((x) == TRUE) \
 719         || ((x) == FALSE))
 720
 721 #define ISSELECTOR(x) \
 722         (((x) == LBRACE) \
 723         || ((x) == DOT))
 724
 725 static oberon_expr_t *
 726 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, int num_indexes, oberon_expr_t * indexes)
 727 {
 728         assert(desig -> is_item == 1);
 729
 730         if(desig -> item.mode != MODE_VAR)
 731         {
 732                 oberon_error(ctx, "not MODE_VAR");
 733         }
 734
 735         int class = desig -> item.var -> class;
 736         switch(class)
 737         {
 738                 case OBERON_CLASS_VAR:
 739                 case OBERON_CLASS_VAR_PARAM:
 740                 case OBERON_CLASS_PARAM:
 741                         break;
 742                 default:
 743                         oberon_error(ctx, "not variable");
 744                         break;
 745         }
 746
 747         oberon_type_t * type = desig -> item.var -> type;
 748         if(type -> class != OBERON_TYPE_ARRAY)
 749         {
 750                 oberon_error(ctx, "not array");
 751         }
 752
 753         int dim = desig -> item.var -> type -> dim;
 754         if(num_indexes != dim)
 755         {
 756                 oberon_error(ctx, "dimesions not matched");
 757         }
 758
 759         oberon_type_t * base = desig -> item.var -> type -> base;
 760
 761         oberon_expr_t * selector;
 762         selector = oberon_new_item(MODE_INDEX, base);
 763         selector -> item.parent = (oberon_item_t *) desig;
 764         selector -> item.num_args = num_indexes;
 765         selector -> item.args = indexes;
 766
 767         return selector;
 768 }
 769
 770 static oberon_expr_t *
 771 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
 772 {
 773         assert(expr -> is_item == 1);
 774
 775         int class = expr -> result -> class;
 776         if(class != OBERON_TYPE_RECORD)
 777         {
 778                 oberon_error(ctx, "not record");
 779         }
 780
 781         oberon_type_t * rec = expr -> result;
 782
 783         oberon_object_t * field;
 784         field = oberon_find_field(ctx, rec, name);
 785
 786         oberon_expr_t * selector;
 787         selector = oberon_new_item(MODE_FIELD, field -> type);
 788         selector -> item.var = field;
 789         selector -> item.parent = (oberon_item_t *) expr;
 790
 791         return selector;
 792 }
 793
 794 static oberon_expr_t *
 795 oberon_designator(oberon_context_t * ctx)
 796 {
 797         char * name;
 798         oberon_object_t * var;
 799         oberon_expr_t * expr;
 800
 801         name = oberon_assert_ident(ctx);
 802         var = oberon_find_object(ctx -> decl, name);
 803
 804         switch(var -> class)
 805         {
 806                 case OBERON_CLASS_CONST:
 807                         // TODO copy value
 808                         expr = (oberon_expr_t *) var -> value;
 809                         break;
 810                 case OBERON_CLASS_VAR:
 811                 case OBERON_CLASS_VAR_PARAM:
 812                 case OBERON_CLASS_PARAM:
 813                         expr = oberon_new_item(MODE_VAR, var -> type);
 814                         break;
 815                 case OBERON_CLASS_PROC:
 816                         expr = oberon_new_item(MODE_CALL, var -> type);
 817                         break;
 818                 default:
 819                         oberon_error(ctx, "invalid designator");
 820                         break;
 821         }
 822         expr -> item.var = var;
 823
 824         while(ISSELECTOR(ctx -> token))
 825         {
 826                 switch(ctx -> token)
 827                 {
 828                         case DOT:
 829                                 oberon_assert_token(ctx, DOT);
 830                                 name = oberon_assert_ident(ctx);
 831                                 expr = oberon_make_record_selector(ctx, expr, name);
 832                                 break;
 833                         case LBRACE:
 834                                 oberon_assert_token(ctx, LBRACE);
 835                                 int num_indexes = 0;
 836                                 oberon_expr_t * indexes = NULL;
 837                                 oberon_expr_list(ctx, &num_indexes, &indexes);
 838                                 oberon_assert_token(ctx, RBRACE);
 839                                 expr = oberon_make_array_selector(ctx, expr, num_indexes, indexes);
 840                                 break;
 841                         default:
 842                                 oberon_error(ctx, "oberon_designator: wat");
 843                                 break;
 844                 }
 845         }
 846         return expr;
 847 }
 848
 849 static oberon_expr_t *
 850 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
 851 {
 852         assert(expr -> is_item == 1);
 853
 854         if(ctx -> token == LPAREN)
 855         {
 856                 if(expr -> result -> class != OBERON_TYPE_PROCEDURE)
 857                 {
 858                         oberon_error(ctx, "not a procedure");
 859                 }
 860
 861                 oberon_assert_token(ctx, LPAREN);
 862
 863                 int num_args = 0;
 864                 oberon_expr_t * arguments = NULL;
 865
 866                 if(ISEXPR(ctx -> token))
 867                 {
 868                         oberon_expr_list(ctx, &num_args, &arguments);
 869                 }
 870
 871                 expr -> result = expr -> item.var -> type -> base;
 872                 expr -> item.mode = MODE_CALL;
 873                 expr -> item.num_args = num_args;
 874                 expr -> item.args = arguments;
 875                 oberon_assert_token(ctx, RPAREN);
 876
 877                 oberon_autocast_call(ctx, expr);
 878         }
 879
 880         return expr;
 881 }
 882
 883 static oberon_expr_t *
 884 oberon_factor(oberon_context_t * ctx)
 885 {
 886         oberon_expr_t * expr;
 887
 888         switch(ctx -> token)
 889         {
 890                 case IDENT:
 891                         expr = oberon_designator(ctx);
 892                         expr = oberon_opt_proc_parens(ctx, expr);
 893                         break;
 894                 case INTEGER:
 895                         expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
 896                         expr -> item.integer = ctx -> integer;
 897                         oberon_assert_token(ctx, INTEGER);
 898                         break;
 899                 case TRUE:
 900                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 901                         expr -> item.boolean = 1;
 902                         oberon_assert_token(ctx, TRUE);
 903                         break;
 904                 case FALSE:
 905                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 906                         expr -> item.boolean = 0;
 907                         oberon_assert_token(ctx, FALSE);
 908                         break;
 909                 case LPAREN:
 910                         oberon_assert_token(ctx, LPAREN);
 911                         expr = oberon_expr(ctx);
 912                         oberon_assert_token(ctx, RPAREN);
 913                         break;
 914                 case NOT:
 915                         oberon_assert_token(ctx, NOT);
 916                         expr = oberon_factor(ctx);
 917                         expr = oberon_make_unary_op(ctx, NOT, expr);
 918                         break;
 919                 default:
 920                         oberon_error(ctx, "invalid expression");
 921         }
 922
 923         return expr;
 924 }
 925
 926 /*
 927  * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
 928  *   1. Классы обоих типов должны быть одинаковы
 929  *   2. В качестве результата должен быть выбран больший тип.
 930  *   3. Если размер результат не должен быть меньше чем базовый int
 931  */
 932
 933 static void
 934 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
 935 {
 936         if((a -> class) != (b -> class))
 937         {
 938                 oberon_error(ctx, "incompatible types");
 939         }
 940
 941         if((a -> size) > (b -> size))
 942         {
 943                 *result = a;
 944         }
 945         else
 946         {
 947                 *result = b;
 948         }
 949
 950         if(((*result) -> class) == OBERON_TYPE_INTEGER)
 951         {
 952                 if(((*result) -> size) < (ctx -> int_type -> size))
 953                 {
 954                         *result = ctx -> int_type;
 955                 }
 956         }
 957
 958         /* TODO: cast types */
 959 }
 960
 961 #define ITMAKESBOOLEAN(x) \
 962         (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
 963
 964 #define ITUSEONLYINTEGER(x) \
 965         ((x) >= LESS && (x) <= GEQ)
 966
 967 #define ITUSEONLYBOOLEAN(x) \
 968         (((x) == OR) || ((x) == AND))
 969
 970 static oberon_expr_t *
 971 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
 972 {
 973         oberon_expr_t * expr;
 974         oberon_type_t * result;
 975
 976         if(ITMAKESBOOLEAN(token))
 977         {
 978                 if(ITUSEONLYINTEGER(token))
 979                 {
 980                         if(a -> result -> class != OBERON_TYPE_INTEGER
 981                                 || b -> result -> class != OBERON_TYPE_INTEGER)
 982                         {
 983                                 oberon_error(ctx, "used only with integer types");
 984                         }
 985                 }
 986                 else if(ITUSEONLYBOOLEAN(token))
 987                 {
 988                         if(a -> result -> class != OBERON_TYPE_BOOLEAN
 989                                 || b -> result -> class != OBERON_TYPE_BOOLEAN)
 990                         {
 991                                 oberon_error(ctx, "used only with boolean type");
 992                         }
 993                 }
 994
 995                 result = ctx -> bool_type;
 996
 997                 if(token == EQUAL)
 998                 {
 999                         expr = oberon_new_operator(OP_EQ, result, a, b);
1000                 }
1001                 else if(token == NEQ)
1002                 {
1003                         expr = oberon_new_operator(OP_NEQ, result, a, b);
1004                 }
1005                 else if(token == LESS)
1006                 {
1007                         expr = oberon_new_operator(OP_LSS, result, a, b);
1008                 }
1009                 else if(token == LEQ)
1010                 {
1011                         expr = oberon_new_operator(OP_LEQ, result, a, b);
1012                 }
1013                 else if(token == GREAT)
1014                 {
1015                         expr = oberon_new_operator(OP_GRT, result, a, b);
1016                 }
1017                 else if(token == GEQ)
1018                 {
1019                         expr = oberon_new_operator(OP_GEQ, result, a, b);
1020                 }
1021                 else if(token == OR)
1022                 {
1023                         expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1024                 }
1025                 else if(token == AND)
1026                 {
1027                         expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1028                 }
1029                 else
1030                 {
1031                         oberon_error(ctx, "oberon_make_bin_op: bool wat");
1032                 }
1033         }
1034         else
1035         {
1036                 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1037
1038                 if(token == PLUS)
1039                 {
1040                         expr = oberon_new_operator(OP_ADD, result, a, b);
1041                 }
1042                 else if(token == MINUS)
1043                 {
1044                         expr = oberon_new_operator(OP_SUB, result, a, b);
1045                 }
1046                 else if(token == STAR)
1047                 {
1048                         expr = oberon_new_operator(OP_MUL, result, a, b);
1049                 }
1050                 else if(token == SLASH)
1051                 {
1052                         expr = oberon_new_operator(OP_DIV, result, a, b);
1053                 }
1054                 else if(token == DIV)
1055                 {
1056                         expr = oberon_new_operator(OP_DIV, result, a, b);
1057                 }
1058                 else if(token == MOD)
1059                 {
1060                         expr = oberon_new_operator(OP_MOD, result, a, b);
1061                 }
1062                 else
1063                 {
1064                         oberon_error(ctx, "oberon_make_bin_op: bin wat");
1065                 }
1066         }
1067
1068         return expr;
1069 }
1070
1071 #define ISMULOP(x) \
1072         ((x) >= STAR && (x) <= AND)
1073
1074 static oberon_expr_t *
1075 oberon_term_expr(oberon_context_t * ctx)
1076 {
1077         oberon_expr_t * expr;
1078
1079         expr = oberon_factor(ctx);
1080         while(ISMULOP(ctx -> token))
1081         {
1082                 int token = ctx -> token;
1083                 oberon_read_token(ctx);
1084
1085                 oberon_expr_t * inter = oberon_factor(ctx);
1086                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1087         }
1088
1089         return expr;
1090 }
1091
1092 #define ISADDOP(x) \
1093         ((x) >= PLUS && (x) <= OR)
1094
1095 static oberon_expr_t *
1096 oberon_simple_expr(oberon_context_t * ctx)
1097 {
1098         oberon_expr_t * expr;
1099
1100         int minus = 0;
1101         if(ctx -> token == PLUS)
1102         {
1103                 minus = 0;
1104                 oberon_assert_token(ctx, PLUS);
1105         }
1106         else if(ctx -> token == MINUS)
1107         {
1108                 minus = 1;
1109                 oberon_assert_token(ctx, MINUS);
1110         }
1111
1112         expr = oberon_term_expr(ctx);
1113         while(ISADDOP(ctx -> token))
1114         {
1115                 int token = ctx -> token;
1116                 oberon_read_token(ctx);
1117
1118                 oberon_expr_t * inter = oberon_term_expr(ctx);
1119                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1120         }
1121
1122         if(minus)
1123         {
1124                 expr = oberon_make_unary_op(ctx, MINUS, expr);
1125         }
1126
1127         return expr;
1128 }
1129
1130 #define ISRELATION(x) \
1131         ((x) >= EQUAL && (x) <= GEQ)
1132
1133 static oberon_expr_t *
1134 oberon_expr(oberon_context_t * ctx)
1135 {
1136         oberon_expr_t * expr;
1137
1138         expr = oberon_simple_expr(ctx);
1139         while(ISRELATION(ctx -> token))
1140         {
1141                 int token = ctx -> token;
1142                 oberon_read_token(ctx);
1143
1144                 oberon_expr_t * inter = oberon_simple_expr(ctx);
1145                 expr = oberon_make_bin_op(ctx, token, expr, inter);
1146         }
1147
1148         return expr;
1149 }
1150
1151 static oberon_item_t *
1152 oberon_const_expr(oberon_context_t * ctx)
1153 {
1154         oberon_expr_t * expr;
1155         expr = oberon_expr(ctx);
1156
1157         if(expr -> is_item == 0)
1158         {
1159                 oberon_error(ctx, "const expression are required");
1160         }
1161
1162         return (oberon_item_t *) expr;
1163 }
1164
1165 // =======================================================================
1166 //   PARSER
1167 // =======================================================================
1168
1169 static void oberon_statement_seq(oberon_context_t * ctx);
1170
1171 static void
1172 oberon_expect_token(oberon_context_t * ctx, int token)
1173 {
1174         if(ctx -> token != token)
1175         {
1176                 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1177         }
1178 }
1179
1180 static void
1181 oberon_assert_token(oberon_context_t * ctx, int token)
1182 {
1183         oberon_expect_token(ctx, token);
1184         oberon_read_token(ctx);
1185 }
1186
1187 static char *
1188 oberon_assert_ident(oberon_context_t * ctx)
1189 {
1190         oberon_expect_token(ctx, IDENT);
1191         char * ident = ctx -> string;
1192         oberon_read_token(ctx);
1193         return ident;
1194 }
1195
1196 static oberon_type_t *
1197 oberon_make_array_type(oberon_context_t * ctx, int dim, oberon_item_t * size, oberon_type_t * base)
1198 {
1199         assert(dim == 1);
1200         oberon_type_t * newtype;
1201
1202         if(size -> mode != MODE_INTEGER)
1203         {
1204                 oberon_error(ctx, "requires integer constant");
1205         }
1206
1207         newtype = oberon_new_type_ptr(OBERON_TYPE_ARRAY);
1208         newtype -> dim = dim;
1209         newtype -> size = size -> integer;
1210         newtype -> base = base;
1211         oberon_generator_init_type(ctx, newtype);
1212
1213         return newtype;
1214 }
1215
1216 static void
1217 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1218 {
1219         if(ctx -> token == IDENT)
1220         {
1221                 char * name;
1222                 oberon_type_t * type;
1223                 name = oberon_assert_ident(ctx);
1224                 oberon_assert_token(ctx, COLON);
1225                 type = oberon_type(ctx);
1226                 oberon_define_field(ctx, rec, name, type);
1227         }
1228 }
1229
1230 static oberon_type_t * oberon_opt_formal_pars(oberon_context_t * ctx, int class);
1231
1232 static oberon_type_t *
1233 oberon_type(oberon_context_t * ctx)
1234 {
1235         oberon_type_t * type;
1236
1237         if(ctx -> token == IDENT)
1238         {
1239                 char * name = oberon_assert_ident(ctx);
1240                 type = oberon_find_type(ctx -> decl, name);
1241         }
1242         else if(ctx -> token == ARRAY)
1243         {
1244                 oberon_assert_token(ctx, ARRAY);
1245                 oberon_item_t * size = oberon_const_expr(ctx);
1246                 oberon_assert_token(ctx, OF);
1247                 oberon_type_t * base = oberon_type(ctx);
1248                 type = oberon_make_array_type(ctx, 1, size, base);
1249         }
1250         else if(ctx -> token == RECORD)
1251         {
1252                 type = oberon_new_type_ptr(OBERON_TYPE_RECORD);
1253                 oberon_object_t * list = malloc(sizeof *list);
1254                 memset(list, 0, sizeof *list);
1255                 type -> num_decl = 0;
1256                 type -> base = NULL;
1257                 type -> decl = list;
1258
1259                 oberon_assert_token(ctx, RECORD);
1260                 oberon_field_list(ctx, type);
1261                 while(ctx -> token == SEMICOLON)
1262                 {
1263                         oberon_assert_token(ctx, SEMICOLON);
1264                         oberon_field_list(ctx, type);
1265                 }
1266                 oberon_assert_token(ctx, END);
1267
1268                 type -> decl = type -> decl -> next;
1269                 oberon_generator_init_type(ctx, type);
1270         }
1271         else if(ctx -> token == PROCEDURE)
1272         {
1273                 oberon_assert_token(ctx, PROCEDURE);
1274                 type = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE);
1275         }
1276         else
1277         {
1278                 oberon_error(ctx, "invalid type declaration");
1279         }
1280
1281         return type;
1282 }
1283
1284 static void
1285 oberon_var_decl(oberon_context_t * ctx)
1286 {
1287         char * name = oberon_assert_ident(ctx);
1288         oberon_assert_token(ctx, COLON);
1289         oberon_type_t * type = oberon_type(ctx);
1290         oberon_define_var(ctx -> decl, OBERON_CLASS_VAR, name, type);
1291 }
1292
1293 static oberon_object_t *
1294 oberon_make_param(oberon_context_t * ctx, int token, char * name, oberon_type_t * type)
1295 {
1296         oberon_object_t * param;
1297
1298         if(token == VAR)
1299         {
1300                 param = oberon_define_var(ctx -> decl, OBERON_CLASS_VAR_PARAM, name, type);
1301         }
1302         else if(token == IDENT)
1303         {
1304                 param = oberon_define_var(ctx -> decl, OBERON_CLASS_PARAM, name, type);
1305         }
1306         else
1307         {
1308                 oberon_error(ctx, "oberon_make_param: wat");
1309         }
1310
1311         return param;
1312 }
1313
1314 static oberon_object_t *
1315 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1316 {
1317         int modifer_token = ctx -> token;
1318         if(ctx -> token == VAR)
1319         {
1320                 oberon_read_token(ctx);
1321         }
1322
1323         char * name;
1324         name = oberon_assert_ident(ctx);
1325
1326         oberon_assert_token(ctx, COLON);
1327
1328         oberon_type_t * type;
1329         type = oberon_type(ctx);
1330
1331         oberon_object_t * first;
1332         first = oberon_make_param(ctx, modifer_token, name, type);
1333
1334         *num_decl += 1;
1335         return first;
1336 }
1337
1338 #define ISFPSECTION \
1339         ((ctx -> token == VAR) || (ctx -> token == IDENT))
1340
1341 static oberon_type_t *
1342 oberon_formal_pars(oberon_context_t * ctx)
1343 {
1344         oberon_type_t * tp;
1345         tp = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
1346         tp -> num_decl = 0;
1347         tp -> base = ctx -> void_type;
1348         tp -> decl = NULL;
1349
1350         oberon_assert_token(ctx, LPAREN);
1351
1352         if(ISFPSECTION)
1353         {
1354                 tp -> decl = oberon_fp_section(ctx, &tp -> num_decl);
1355                 while(ctx -> token == SEMICOLON)
1356                 {
1357                         oberon_assert_token(ctx, SEMICOLON);
1358                         oberon_fp_section(ctx, &tp -> num_decl);
1359                 }
1360         }
1361
1362         oberon_assert_token(ctx, RPAREN);
1363
1364         if(ctx -> token == COLON)
1365         {
1366                 oberon_assert_token(ctx, COLON);
1367                 tp -> base = oberon_type(ctx);
1368         }
1369
1370         oberon_generator_init_type(ctx, tp);
1371         return tp;
1372 }
1373
1374 static oberon_type_t *
1375 oberon_opt_formal_pars(oberon_context_t * ctx, int class)
1376 {
1377         oberon_type_t * signature;
1378
1379         if(ctx -> token == LPAREN)
1380         {
1381                 signature = oberon_formal_pars(ctx);
1382         }
1383         else
1384         {
1385                 signature = oberon_new_type_ptr(class);
1386                 signature -> num_decl = 0;
1387                 signature -> base = ctx -> void_type;
1388                 signature -> decl = NULL;
1389                 oberon_generator_init_type(ctx, signature);
1390         }
1391
1392         return signature;
1393 }
1394
1395 static void
1396 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1397 {
1398         if(ctx -> result_type -> class == OBERON_TYPE_VOID)
1399         {
1400                 if(expr != NULL)
1401                 {
1402                         oberon_error(ctx, "procedure has no result type");
1403                 }
1404         }
1405         else
1406         {
1407                 if(expr == NULL)
1408                 {
1409                         oberon_error(ctx, "procedure requires expression on result");
1410                 }
1411
1412                 oberon_autocast_to(ctx, expr, ctx -> result_type);
1413         }
1414
1415         ctx -> has_return = 1;
1416
1417         oberon_generate_return(ctx, expr);
1418 }
1419
1420 static void
1421 oberon_proc_decl(oberon_context_t * ctx)
1422 {
1423         oberon_assert_token(ctx, PROCEDURE);
1424
1425         char * name;
1426         name = oberon_assert_ident(ctx);
1427
1428         oberon_scope_t * this_proc_def_scope = ctx -> decl;
1429         oberon_open_scope(ctx);
1430
1431         oberon_type_t * signature;
1432         signature = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE);
1433
1434         oberon_object_t * proc;
1435         proc = oberon_define_proc(this_proc_def_scope, name, signature);
1436
1437         ctx -> result_type = signature -> base;
1438         ctx -> has_return = 0;
1439
1440         oberon_assert_token(ctx, SEMICOLON);
1441
1442         oberon_generate_begin_proc(ctx, proc);
1443
1444         // TODO declarations
1445
1446         if(ctx -> token == BEGIN)
1447         {
1448                 oberon_assert_token(ctx, BEGIN);
1449                 oberon_statement_seq(ctx);
1450         }
1451
1452         oberon_assert_token(ctx, END);
1453         char * name2 = oberon_assert_ident(ctx);
1454         if(strcmp(name2, name) != 0)
1455         {
1456                 oberon_error(ctx, "procedure name not matched");
1457         }
1458
1459         if(signature -> base -> class == OBERON_TYPE_VOID)
1460         {
1461                 oberon_make_return(ctx, NULL);
1462         }
1463
1464         if(ctx -> has_return == 0)
1465         {
1466                 oberon_error(ctx, "procedure requires return");
1467         }
1468         ctx -> result_type = NULL;
1469
1470         oberon_generate_end_proc(ctx);
1471         oberon_close_scope(ctx -> decl);
1472 }
1473
1474 static void
1475 oberon_const_decl(oberon_context_t * ctx)
1476 {
1477         char * name;
1478         oberon_item_t * value;
1479         oberon_object_t * constant;
1480
1481         name = oberon_assert_ident(ctx);
1482         oberon_assert_token(ctx, EQUAL);
1483         value = oberon_const_expr(ctx);
1484
1485         constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST);
1486         constant -> value = value;
1487 }
1488
1489 static void
1490 oberon_type_decl(oberon_context_t * ctx)
1491 {
1492         char * name;
1493         oberon_object_t * newtype;
1494         oberon_type_t * type;
1495
1496         name = oberon_assert_ident(ctx);
1497         oberon_assert_token(ctx, EQUAL);
1498         type = oberon_type(ctx);
1499
1500         newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1501         newtype -> type = type;
1502 }
1503
1504 static void
1505 oberon_decl_seq(oberon_context_t * ctx)
1506 {
1507         if(ctx -> token == CONST)
1508         {
1509                 oberon_assert_token(ctx, CONST);
1510                 while(ctx -> token == IDENT)
1511                 {
1512                         oberon_const_decl(ctx);
1513                         oberon_assert_token(ctx, SEMICOLON);
1514                 }
1515         }
1516
1517         if(ctx -> token == TYPE)
1518         {
1519                 oberon_assert_token(ctx, TYPE);
1520                 while(ctx -> token == IDENT)
1521                 {
1522                         oberon_type_decl(ctx);
1523                         oberon_assert_token(ctx, SEMICOLON);
1524                 }
1525         }
1526
1527         if(ctx -> token == VAR)
1528         {
1529                 oberon_assert_token(ctx, VAR);
1530                 while(ctx -> token == IDENT)
1531                 {
1532                         oberon_var_decl(ctx);
1533                         oberon_assert_token(ctx, SEMICOLON);
1534                 }
1535         }
1536
1537         while(ctx -> token == PROCEDURE)
1538         {
1539                 oberon_proc_decl(ctx);
1540                 oberon_assert_token(ctx, SEMICOLON);
1541         }
1542 }
1543
1544 static void
1545 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
1546 {
1547         oberon_autocast_to(ctx, src, dst -> result);
1548         oberon_generate_assign(ctx, src, dst);
1549 }
1550
1551 static void
1552 oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
1553 {
1554         oberon_autocast_call(ctx, desig);
1555         oberon_generate_call_proc(ctx, desig);
1556 }
1557
1558 static void
1559 oberon_statement(oberon_context_t * ctx)
1560 {
1561         oberon_expr_t * item1;
1562         oberon_expr_t * item2;
1563
1564         if(ctx -> token == IDENT)
1565         {
1566                 item1 = oberon_designator(ctx);
1567                 if(ctx -> token == ASSIGN)
1568                 {
1569                         oberon_assert_token(ctx, ASSIGN);
1570                         item2 = oberon_expr(ctx);
1571                         oberon_assign(ctx, item2, item1);
1572                 }
1573                 else
1574                 {
1575                         item1 = oberon_opt_proc_parens(ctx, item1);
1576                         oberon_make_call(ctx, item1);
1577                 }
1578         }
1579         else if(ctx -> token == RETURN)
1580         {
1581                 oberon_assert_token(ctx, RETURN);
1582                 if(ISEXPR(ctx -> token))
1583                 {
1584                         oberon_expr_t * expr;
1585                         expr = oberon_expr(ctx);
1586                         oberon_make_return(ctx, expr);
1587                 }
1588                 else
1589                 {
1590                         oberon_make_return(ctx, NULL);
1591                 }
1592         }
1593 }
1594
1595 static void
1596 oberon_statement_seq(oberon_context_t * ctx)
1597 {
1598         oberon_statement(ctx);
1599         while(ctx -> token == SEMICOLON)
1600         {
1601                 oberon_assert_token(ctx, SEMICOLON);
1602                 oberon_statement(ctx);
1603         }
1604 }
1605
1606 static void
1607 oberon_parse_module(oberon_context_t * ctx)
1608 {
1609         char *name1, *name2;
1610         oberon_read_token(ctx);
1611
1612         oberon_assert_token(ctx, MODULE);
1613         name1 = oberon_assert_ident(ctx);
1614         oberon_assert_token(ctx, SEMICOLON);
1615         ctx -> mod -> name = name1;
1616
1617         oberon_decl_seq(ctx);
1618
1619         if(ctx -> token == BEGIN)
1620         {
1621                 oberon_assert_token(ctx, BEGIN);
1622                 oberon_generate_begin_module(ctx);
1623                 oberon_statement_seq(ctx);
1624                 oberon_generate_end_module(ctx);
1625         }
1626
1627         oberon_assert_token(ctx, END);
1628         name2 = oberon_assert_ident(ctx);
1629         oberon_assert_token(ctx, DOT);
1630
1631         if(strcmp(name1, name2) != 0)
1632         {
1633                 oberon_error(ctx, "module name not matched");
1634         }
1635 }
1636
1637 // =======================================================================
1638 //   LIBRARY
1639 // =======================================================================
1640
1641 static void
1642 register_default_types(oberon_context_t * ctx)
1643 {
1644         ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1645         oberon_generator_init_type(ctx, ctx -> void_type);
1646
1647         ctx -> int_type = oberon_new_type_integer(sizeof(int));
1648         oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
1649
1650         ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
1651         oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
1652 }
1653
1654 oberon_context_t *
1655 oberon_create_context()
1656 {
1657         oberon_context_t * ctx = malloc(sizeof *ctx);
1658         memset(ctx, 0, sizeof *ctx);
1659
1660         oberon_scope_t * world_scope;
1661         world_scope = oberon_open_scope(ctx);
1662         ctx -> world_scope = world_scope;
1663
1664         oberon_generator_init_context(ctx);
1665
1666         register_default_types(ctx);
1667
1668         return ctx;
1669 }
1670
1671 void
1672 oberon_destroy_context(oberon_context_t * ctx)
1673 {
1674         oberon_generator_destroy_context(ctx);
1675         free(ctx);
1676 }
1677
1678 oberon_module_t *
1679 oberon_compile_module(oberon_context_t * ctx, const char * code)
1680 {
1681         oberon_module_t * mod = malloc(sizeof *mod);
1682         memset(mod, 0, sizeof *mod);
1683         ctx -> mod = mod;
1684
1685         oberon_scope_t * module_scope;
1686         module_scope = oberon_open_scope(ctx);
1687         mod -> decl = module_scope;
1688
1689         oberon_init_scaner(ctx, code);
1690         oberon_parse_module(ctx);
1691
1692         oberon_generate_code(ctx);
1693
1694         ctx -> mod = NULL;
1695         return mod;
1696 }