oberon.c

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