oberon.c

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