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