oberon.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <stdarg.h>
   4 #include <ctype.h>
   5 #include <string.h>
   6
   7 #include "oberon.h"
   8 #include "generator.h"
   9
  10 enum {
  11         EOF_ = 0,
  12         IDENT,
  13         MODULE,
  14         SEMICOLON,
  15         END,
  16         DOT,
  17         VAR,
  18         COLON,
  19         BEGIN,
  20         ASSIGN,
  21         INTEGER,
  22         TRUE,
  23         FALSE,
  24         LPAREN,
  25         RPAREN,
  26         EQUAL,
  27         NEQ,
  28         LESS,
  29         LEQ,
  30         GREAT,
  31         GEQ,
  32         PLUS,
  33         MINUS,
  34         OR,
  35         STAR,
  36         SLASH,
  37         DIV,
  38         MOD,
  39         AND,
  40         NOT,
  41         PROCEDURE
  42 };
  43
  44 // =======================================================================
  45 //   UTILS
  46 // =======================================================================
  47
  48 void
  49 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
  50 {
  51         va_list ptr;
  52         va_start(ptr, fmt);
  53         fprintf(stderr, "error: ");
  54         vfprintf(stderr, fmt, ptr);
  55         fprintf(stderr, "\n");
  56         fprintf(stderr, "  code_index = %i\n", ctx -> code_index);
  57         fprintf(stderr, "  c          = %c\n", ctx -> c);
  58         fprintf(stderr, "  token      = %i\n", ctx -> token);
  59         va_end(ptr);
  60         exit(1);
  61 }
  62
  63 // =======================================================================
  64 //   TABLE
  65 // =======================================================================
  66
  67 static oberon_scope_t *
  68 oberon_open_scope(oberon_context_t * ctx)
  69 {
  70         oberon_scope_t * scope = malloc(sizeof *scope);
  71         memset(scope, 0, sizeof *scope);
  72
  73         oberon_object_t * list = malloc(sizeof *list);
  74         memset(list, 0, sizeof *list);
  75
  76         scope -> ctx = ctx;
  77         scope -> list = list;
  78         scope -> up = ctx -> decl;
  79
  80         ctx -> decl = scope;
  81         return scope;
  82 }
  83
  84 static void
  85 oberon_close_scope(oberon_scope_t * scope)
  86 {
  87         oberon_context_t * ctx = scope -> ctx;
  88         ctx -> decl = scope -> up;
  89 }
  90
  91 static oberon_object_t *
  92 oberon_define_object(oberon_scope_t * scope, char * name, int class)
  93 {
  94         oberon_object_t * x = scope -> list;
  95         while(x -> next && strcmp(x -> next -> name, name) != 0)
  96         {
  97                 x = x -> next;
  98         }
  99
 100         if(x -> next)
 101         {
 102                 oberon_error(scope -> ctx, "already defined");
 103         }
 104
 105         oberon_object_t * newvar = malloc(sizeof *newvar);
 106         memset(newvar, 0, sizeof *newvar);
 107         newvar -> name = name;
 108         newvar -> class = class;
 109
 110         x -> next = newvar;
 111
 112         return newvar;
 113 }
 114
 115 static oberon_object_t *
 116 oberon_find_object_in_list(oberon_object_t * list, char * name)
 117 {
 118         oberon_object_t * x = list;
 119         while(x -> next && strcmp(x -> next -> name, name) != 0)
 120         {
 121                 x = x -> next;
 122         }
 123         return x -> next;
 124 }
 125
 126 static oberon_object_t *
 127 oberon_find_object(oberon_scope_t * scope, char * name)
 128 {
 129         oberon_object_t * result = NULL;
 130
 131         oberon_scope_t * s = scope;
 132         while(result == NULL && s != NULL)
 133         {
 134                 result = oberon_find_object_in_list(s -> list, name);
 135                 s = s -> up;
 136         }
 137
 138         if(result == NULL)
 139         {
 140                 oberon_error(scope -> ctx, "undefined ident %s", name);
 141         }
 142
 143         return result;
 144 }
 145
 146 static void
 147 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type)
 148 {
 149         oberon_object_t * id;
 150         id = oberon_define_object(scope, name, OBERON_CLASS_TYPE);
 151         id -> type = type;
 152         oberon_generator_init_type(scope -> ctx, type);
 153 }
 154
 155 static oberon_type_t *
 156 oberon_find_type(oberon_scope_t * scope, char * name)
 157 {
 158         oberon_object_t * x = oberon_find_object(scope, name);
 159         if(x -> class != OBERON_CLASS_TYPE)
 160         {
 161                 oberon_error(scope -> ctx, "%s not a type", name);
 162         }
 163
 164         return x -> type;
 165 }
 166
 167 static void
 168 oberon_define_var(oberon_scope_t * scope, char * name, oberon_type_t * type)
 169 {
 170         oberon_object_t * var;
 171         var = oberon_define_object(scope, name, OBERON_CLASS_VAR);
 172         var -> type = type;
 173         oberon_generator_init_var(scope -> ctx, var);
 174 }
 175
 176 /*
 177 static oberon_object_t *
 178 oberon_find_var(oberon_scope_t * scope, char * name)
 179 {
 180         oberon_object_t * x = oberon_find_object(scope, name);
 181
 182         if(x -> class != OBERON_CLASS_VAR)
 183         {
 184                 oberon_error(scope -> ctx, "%s not a var", name);
 185         }
 186
 187         return x;
 188 }
 189 */
 190
 191 static oberon_object_t *
 192 oberon_define_proc(oberon_scope_t * scope, char * name)
 193 {
 194         oberon_object_t * proc;
 195         proc = oberon_define_object(scope, name, OBERON_CLASS_PROC);
 196         oberon_generator_init_proc(scope -> ctx, proc);
 197         return proc;
 198 }
 199
 200 // =======================================================================
 201 //   SCANER
 202 // =======================================================================
 203
 204 static void
 205 oberon_get_char(oberon_context_t * ctx)
 206 {
 207         ctx -> code_index += 1;
 208         ctx -> c = ctx -> code[ctx -> code_index];
 209 }
 210
 211 static void
 212 oberon_init_scaner(oberon_context_t * ctx, const char * code)
 213 {
 214         ctx -> code = code;
 215         ctx -> code_index = 0;
 216         ctx -> c = ctx -> code[ctx -> code_index];
 217 }
 218
 219 static void
 220 oberon_read_ident(oberon_context_t * ctx)
 221 {
 222         int len = 0;
 223         int i = ctx -> code_index;
 224
 225         int c = ctx -> code[i];
 226         while(isalnum(c))
 227         {
 228                 i += 1;
 229                 len += 1;
 230                 c = ctx -> code[i];
 231         }
 232
 233         char * ident = malloc(len + 1);
 234         memcpy(ident, &ctx->code[ctx->code_index], len);
 235         ident[len] = 0;
 236
 237         ctx -> code_index = i;
 238         ctx -> c = ctx -> code[i];
 239         ctx -> string = ident;
 240         ctx -> token = IDENT;
 241
 242         if(strcmp(ident, "MODULE") == 0)
 243         {
 244                 ctx -> token = MODULE;
 245         }
 246         else if(strcmp(ident, "END") == 0)
 247         {
 248                 ctx -> token = END;
 249         }
 250         else if(strcmp(ident, "VAR") == 0)
 251         {
 252                 ctx -> token = VAR;
 253         }
 254         else if(strcmp(ident, "BEGIN") == 0)
 255         {
 256                 ctx -> token = BEGIN;
 257         }
 258         else if(strcmp(ident, "TRUE") == 0)
 259         {
 260                 ctx -> token = TRUE;
 261         }
 262         else if(strcmp(ident, "FALSE") == 0)
 263         {
 264                 ctx -> token = FALSE;
 265         }
 266         else if(strcmp(ident, "OR") == 0)
 267         {
 268                 ctx -> token = OR;
 269         }
 270         else if(strcmp(ident, "DIV") == 0)
 271         {
 272                 ctx -> token = DIV;
 273         }
 274         else if(strcmp(ident, "MOD") == 0)
 275         {
 276                 ctx -> token = MOD;
 277         }
 278         else if(strcmp(ident, "PROCEDURE") == 0)
 279         {
 280                 ctx -> token = PROCEDURE;
 281         }
 282 }
 283
 284 static void
 285 oberon_read_integer(oberon_context_t * ctx)
 286 {
 287         int len = 0;
 288         int i = ctx -> code_index;
 289
 290         int c = ctx -> code[i];
 291         while(isdigit(c))
 292         {
 293                 i += 1;
 294                 len += 1;
 295                 c = ctx -> code[i];
 296         }
 297
 298         char * ident = malloc(len + 2);
 299         memcpy(ident, &ctx->code[ctx->code_index], len);
 300         ident[len + 1] = 0;
 301
 302         ctx -> code_index = i;
 303         ctx -> c = ctx -> code[i];
 304         ctx -> string = ident;
 305         ctx -> integer = atoi(ident);
 306         ctx -> token = INTEGER;
 307 }
 308
 309 static void
 310 oberon_skip_space(oberon_context_t * ctx)
 311 {
 312         while(isspace(ctx -> c))
 313         {
 314                 oberon_get_char(ctx);
 315         }
 316 }
 317
 318 static void
 319 oberon_read_symbol(oberon_context_t * ctx)
 320 {
 321         int c = ctx -> c;
 322         switch(c)
 323         {
 324                 case 0:
 325                         ctx -> token = EOF_;
 326                         break;
 327                 case ';':
 328                         ctx -> token = SEMICOLON;
 329                         oberon_get_char(ctx);
 330                         break;
 331                 case ':':
 332                         ctx -> token = COLON;
 333                         oberon_get_char(ctx);
 334                         if(ctx -> c == '=')
 335                         {
 336                                 ctx -> token = ASSIGN;
 337                                 oberon_get_char(ctx);
 338                         }
 339                         break;
 340                 case '.':
 341                         ctx -> token = DOT;
 342                         oberon_get_char(ctx);
 343                         break;
 344                 case '(':
 345                         ctx -> token = LPAREN;
 346                         oberon_get_char(ctx);
 347                         break;
 348                 case ')':
 349                         ctx -> token = RPAREN;
 350                         oberon_get_char(ctx);
 351                         break;
 352                 case '=':
 353                         ctx -> token = EQUAL;
 354                         oberon_get_char(ctx);
 355                         break;
 356                 case '#':
 357                         ctx -> token = NEQ;
 358                         oberon_get_char(ctx);
 359                         break;
 360                 case '<':
 361                         ctx -> token = LESS;
 362                         oberon_get_char(ctx);
 363                         if(ctx -> c == '=')
 364                         {
 365                                 ctx -> token = LEQ;
 366                                 oberon_get_char(ctx);
 367                         }
 368                         break;
 369                 case '>':
 370                         ctx -> token = GREAT;
 371                         oberon_get_char(ctx);
 372                         if(ctx -> c == '=')
 373                         {
 374                                 ctx -> token = GEQ;
 375                                 oberon_get_char(ctx);
 376                         }
 377                         break;
 378                 case '+':
 379                         ctx -> token = PLUS;
 380                         oberon_get_char(ctx);
 381                         break;
 382                 case '-':
 383                         ctx -> token = MINUS;
 384                         oberon_get_char(ctx);
 385                         break;
 386                 case '*':
 387                         ctx -> token = STAR;
 388                         oberon_get_char(ctx);
 389                         break;
 390                 case '/':
 391                         ctx -> token = SLASH;
 392                         oberon_get_char(ctx);
 393                         break;
 394                 case '&':
 395                         ctx -> token = AND;
 396                         oberon_get_char(ctx);
 397                         break;
 398                 case '~':
 399                         ctx -> token = NOT;
 400                         oberon_get_char(ctx);
 401                         break;
 402                 default:
 403                         oberon_error(ctx, "invalid char");
 404                         break;
 405         }
 406 }
 407
 408 static void
 409 oberon_read_token(oberon_context_t * ctx)
 410 {
 411         oberon_skip_space(ctx);
 412
 413         int c = ctx -> c;
 414         if(isalpha(c))
 415         {
 416                 oberon_read_ident(ctx);
 417         }
 418         else if(isdigit(c))
 419         {
 420                 oberon_read_integer(ctx);
 421         }
 422         else
 423         {
 424                 oberon_read_symbol(ctx);
 425         }
 426 }
 427
 428 // =======================================================================
 429 //   EXPRESSION
 430 // =======================================================================
 431
 432 static void oberon_expect_token(oberon_context_t * ctx, int token);
 433 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
 434 static void oberon_assert_token(oberon_context_t * ctx, int token);
 435 static char * oberon_assert_ident(oberon_context_t * ctx);
 436
 437 static oberon_expr_t *
 438 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
 439 {
 440         oberon_oper_t * operator;
 441         operator = malloc(sizeof *operator);
 442         memset(operator, 0, sizeof *operator);
 443
 444         operator -> is_item = 0;
 445         operator -> result = result;
 446         operator -> op = op;
 447         operator -> left = left;
 448         operator -> right = right;
 449
 450         return (oberon_expr_t *) operator;
 451 }
 452
 453 static oberon_expr_t *
 454 oberon_new_item(int mode, oberon_type_t * result)
 455 {
 456         oberon_item_t * item;
 457         item = malloc(sizeof *item);
 458         memset(item, 0, sizeof *item);
 459
 460         item -> is_item = 1;
 461         item -> result = result;
 462         item -> mode = mode;
 463
 464         return (oberon_expr_t *)item;
 465 }
 466
 467 static oberon_expr_t *
 468 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
 469 {
 470         oberon_expr_t * expr;
 471         oberon_type_t * result;
 472
 473         result = a -> result;
 474
 475         if(token == MINUS)
 476         {
 477                 if(result -> class != OBERON_TYPE_INTEGER)
 478                 {
 479                         oberon_error(ctx, "incompatible operator type");
 480                 }
 481
 482                 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
 483         }
 484         else if(token == NOT)
 485         {
 486                 if(result -> class != OBERON_TYPE_BOOLEAN)
 487                 {
 488                         oberon_error(ctx, "incompatible operator type");
 489                 }
 490
 491                 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
 492         }
 493         else
 494         {
 495                 oberon_error(ctx, "oberon_make_unary_op: wat");
 496         }
 497
 498         return expr;
 499 }
 500
 501 static oberon_expr_t *
 502 oberon_factor(oberon_context_t * ctx)
 503 {
 504         char * name;
 505         oberon_object_t * var;
 506         oberon_expr_t * expr;
 507
 508         switch(ctx -> token)
 509         {
 510                 case IDENT:
 511                         name = oberon_assert_ident(ctx);
 512                         var = oberon_find_object(ctx -> decl, name);
 513                         if(var -> class == OBERON_CLASS_VAR)
 514                         {
 515                                 expr = oberon_new_item(MODE_VAR, var -> type);
 516                         }
 517                         else if(var -> class == OBERON_CLASS_PROC)
 518                         {
 519                                 expr = oberon_new_item(MODE_CALL, var -> type);
 520                         }
 521                         else
 522                         {
 523                                 oberon_error(ctx, "invalid designator");
 524                         }
 525
 526                         expr -> item.var = var;
 527                         if(ctx -> token == LPAREN)
 528                         {
 529                                 oberon_assert_token(ctx, LPAREN);
 530                                 expr -> item.mode = MODE_CALL;
 531                                 oberon_assert_token(ctx, RPAREN);
 532                         }
 533                         break;
 534                 case INTEGER:
 535                         expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
 536                         expr -> item.integer = ctx -> integer;
 537                         oberon_assert_token(ctx, INTEGER);
 538                         break;
 539                 case TRUE:
 540                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 541                         expr -> item.boolean = 1;
 542                         oberon_assert_token(ctx, TRUE);
 543                         break;
 544                 case FALSE:
 545                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 546                         expr -> item.boolean = 0;
 547                         oberon_assert_token(ctx, FALSE);
 548                         break;
 549                 case LPAREN:
 550                         oberon_assert_token(ctx, LPAREN);
 551                         expr = oberon_expr(ctx);
 552                         oberon_assert_token(ctx, RPAREN);
 553                         break;
 554                 case NOT:
 555                         oberon_assert_token(ctx, NOT);
 556                         expr = oberon_factor(ctx);
 557                         expr = oberon_make_unary_op(ctx, NOT, expr);
 558                         break;
 559                 default:
 560                         oberon_error(ctx, "invalid expression");
 561         }
 562
 563         return expr;
 564 }
 565
 566 /*
 567  * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
 568  *   1. Классы обоих типов должны быть одинаковы
 569  *   2. В качестве результата должен быть выбран больший тип.
 570  *   3. Если размер результат не должен быть меньше чем базовый int
 571  */
 572
 573 static void
 574 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
 575 {
 576         if((a -> class) != (b -> class))
 577         {
 578                 oberon_error(ctx, "incompatible types");
 579         }
 580
 581         if((a -> size) > (b -> size))
 582         {
 583                 *result = a;
 584         }
 585         else
 586         {
 587                 *result = b;
 588         }
 589
 590         if(((*result) -> class) == OBERON_TYPE_INTEGER)
 591         {
 592                 if(((*result) -> size) < (ctx -> int_type -> size))
 593                 {
 594                         *result = ctx -> int_type;
 595                 }
 596         }
 597
 598         /* TODO: cast types */
 599 }
 600
 601 #define ITMAKESBOOLEAN(x) \
 602         (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
 603
 604 #define ITUSEONLYINTEGER(x) \
 605         ((x) >= LESS && (x) <= GEQ)
 606
 607 #define ITUSEONLYBOOLEAN(x) \
 608         (((x) == OR) || ((x) == AND))
 609
 610 static oberon_expr_t *
 611 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
 612 {
 613         oberon_expr_t * expr;
 614         oberon_type_t * result;
 615
 616         oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
 617
 618         if(ITMAKESBOOLEAN(token))
 619         {
 620                 if(ITUSEONLYINTEGER(token))
 621                 {
 622                         if(a -> result -> class != OBERON_TYPE_INTEGER
 623                                 && b -> result -> class != OBERON_TYPE_INTEGER)
 624                         {
 625                                 oberon_error(ctx, "used only with integer types");
 626                         }
 627                 }
 628                 else if(ITUSEONLYBOOLEAN(token))
 629                 {
 630                         if(a -> result -> class != OBERON_TYPE_BOOLEAN
 631                                 && b -> result -> class != OBERON_TYPE_BOOLEAN)
 632                         {
 633                                 oberon_error(ctx, "used only with boolean type");
 634                         }
 635                 }
 636
 637                 if(token == EQUAL)
 638                 {
 639                         expr = oberon_new_operator(OP_EQ, result, a, b);
 640                 }
 641                 else if(token == NEQ)
 642                 {
 643                         expr = oberon_new_operator(OP_NEQ, result, a, b);
 644                 }
 645                 else if(token == LESS)
 646                 {
 647                         expr = oberon_new_operator(OP_LSS, result, a, b);
 648                 }
 649                 else if(token == LEQ)
 650                 {
 651                         expr = oberon_new_operator(OP_LEQ, result, a, b);
 652                 }
 653                 else if(token == GREAT)
 654                 {
 655                         expr = oberon_new_operator(OP_GRT, result, a, b);
 656                 }
 657                 else if(token == GEQ)
 658                 {
 659                         expr = oberon_new_operator(OP_GEQ, result, a, b);
 660                 }
 661                 else if(token == OR)
 662                 {
 663                         expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
 664                 }
 665                 else if(token == AND)
 666                 {
 667                         expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
 668                 }
 669                 else
 670                 {
 671                         oberon_error(ctx, "oberon_make_bin_op: bool wat");
 672                 }
 673         }
 674         else
 675         {
 676                 if(token == PLUS)
 677                 {
 678                         expr = oberon_new_operator(OP_ADD, result, a, b);
 679                 }
 680                 else if(token == MINUS)
 681                 {
 682                         expr = oberon_new_operator(OP_SUB, result, a, b);
 683                 }
 684                 else if(token == STAR)
 685                 {
 686                         expr = oberon_new_operator(OP_MUL, result, a, b);
 687                 }
 688                 else if(token == SLASH)
 689                 {
 690                         expr = oberon_new_operator(OP_DIV, result, a, b);
 691                 }
 692                 else if(token == DIV)
 693                 {
 694                         expr = oberon_new_operator(OP_DIV, result, a, b);
 695                 }
 696                 else if(token == MOD)
 697                 {
 698                         expr = oberon_new_operator(OP_MOD, result, a, b);
 699                 }
 700                 else
 701                 {
 702                         oberon_error(ctx, "oberon_make_bin_op: bin wat");
 703                 }
 704         }
 705
 706         return expr;
 707 }
 708
 709 #define ISMULOP(x) \
 710         ((x) >= STAR && (x) <= AND)
 711
 712 static oberon_expr_t *
 713 oberon_term_expr(oberon_context_t * ctx)
 714 {
 715         oberon_expr_t * expr;
 716
 717         expr = oberon_factor(ctx);
 718         while(ISMULOP(ctx -> token))
 719         {
 720                 int token = ctx -> token;
 721                 oberon_read_token(ctx);
 722
 723                 oberon_expr_t * inter = oberon_factor(ctx);
 724                 expr = oberon_make_bin_op(ctx, token, expr, inter);
 725         }
 726
 727         return expr;
 728 }
 729
 730 #define ISADDOP(x) \
 731         ((x) >= PLUS && (x) <= OR)
 732
 733 static oberon_expr_t *
 734 oberon_simple_expr(oberon_context_t * ctx)
 735 {
 736         oberon_expr_t * expr;
 737
 738         int minus = 0;
 739         if(ctx -> token == PLUS)
 740         {
 741                 minus = 0;
 742                 oberon_assert_token(ctx, PLUS);
 743         }
 744         else if(ctx -> token == MINUS)
 745         {
 746                 minus = 1;
 747                 oberon_assert_token(ctx, MINUS);
 748         }
 749
 750         expr = oberon_term_expr(ctx);
 751         while(ISADDOP(ctx -> token))
 752         {
 753                 int token = ctx -> token;
 754                 oberon_read_token(ctx);
 755
 756                 oberon_expr_t * inter = oberon_term_expr(ctx);
 757                 expr = oberon_make_bin_op(ctx, token, expr, inter);
 758         }
 759
 760         if(minus)
 761         {
 762                 expr = oberon_make_unary_op(ctx, MINUS, expr);
 763         }
 764
 765         return expr;
 766 }
 767
 768 #define ISRELATION(x) \
 769         ((x) >= EQUAL && (x) <= GEQ)
 770
 771 static oberon_expr_t *
 772 oberon_expr(oberon_context_t * ctx)
 773 {
 774         oberon_expr_t * expr;
 775
 776         expr = oberon_simple_expr(ctx);
 777         while(ISRELATION(ctx -> token))
 778         {
 779                 int token = ctx -> token;
 780                 oberon_read_token(ctx);
 781
 782                 oberon_expr_t * inter = oberon_simple_expr(ctx);
 783                 expr = oberon_make_bin_op(ctx, token, expr, inter);
 784         }
 785
 786         return expr;
 787 }
 788
 789 // =======================================================================
 790 //   PARSER
 791 // =======================================================================
 792
 793 static void oberon_statement_seq(oberon_context_t * ctx);
 794
 795 static void
 796 oberon_expect_token(oberon_context_t * ctx, int token)
 797 {
 798         if(ctx -> token != token)
 799         {
 800                 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
 801         }
 802 }
 803
 804 static void
 805 oberon_assert_token(oberon_context_t * ctx, int token)
 806 {
 807         oberon_expect_token(ctx, token);
 808         oberon_read_token(ctx);
 809 }
 810
 811 static char *
 812 oberon_assert_ident(oberon_context_t * ctx)
 813 {
 814         oberon_expect_token(ctx, IDENT);
 815         char * ident = ctx -> string;
 816         oberon_read_token(ctx);
 817         return ident;
 818 }
 819
 820 static oberon_type_t *
 821 oberon_type(oberon_context_t * ctx)
 822 {
 823         char * name = oberon_assert_ident(ctx);
 824         oberon_type_t * type = oberon_find_type(ctx -> decl, name);
 825         return type;
 826 }
 827
 828 static void
 829 oberon_var_decl(oberon_context_t * ctx)
 830 {
 831         char * name = oberon_assert_ident(ctx);
 832         oberon_assert_token(ctx, COLON);
 833         oberon_type_t * type = oberon_type(ctx);
 834         oberon_define_var(ctx -> decl, name, type);
 835 }
 836
 837 static void
 838 oberon_make_procedure_begin(oberon_context_t * ctx, char * name)
 839 {
 840         oberon_object_t * proc;
 841         proc = oberon_define_proc(ctx -> decl, name);
 842
 843         oberon_open_scope(ctx);
 844
 845         oberon_generate_begin_proc(ctx, proc);
 846 }
 847
 848 static void
 849 oberon_make_procedure_end(oberon_context_t * ctx)
 850 {
 851         oberon_generate_end_proc(ctx);
 852
 853         oberon_close_scope(ctx -> decl);
 854 }
 855
 856 static void
 857 oberon_proc_decl(oberon_context_t * ctx)
 858 {
 859         oberon_assert_token(ctx, PROCEDURE);
 860
 861         char * name;
 862         name = oberon_assert_ident(ctx);
 863
 864         oberon_assert_token(ctx, SEMICOLON);
 865
 866         oberon_make_procedure_begin(ctx, name);
 867         if(ctx -> token == BEGIN)
 868         {
 869                 oberon_assert_token(ctx, BEGIN);
 870                 oberon_statement_seq(ctx);
 871         }
 872         oberon_make_procedure_end(ctx);
 873
 874         oberon_assert_token(ctx, END);
 875         char * name2 = oberon_assert_ident(ctx);
 876
 877         if(strcmp(name2, name) != 0)
 878         {
 879                 oberon_error(ctx, "procedure name not matched");
 880         }
 881 }
 882
 883 static void
 884 oberon_decl_seq(oberon_context_t * ctx)
 885 {
 886         if(ctx -> token == VAR)
 887         {
 888                 oberon_assert_token(ctx, VAR);
 889                 while(ctx -> token == IDENT)
 890                 {
 891                         oberon_var_decl(ctx);
 892                         oberon_assert_token(ctx, SEMICOLON);
 893                 }
 894         }
 895
 896         if(ctx -> token == PROCEDURE)
 897         {
 898                 oberon_proc_decl(ctx);
 899                 oberon_assert_token(ctx, SEMICOLON);
 900         }
 901 }
 902
 903 static void
 904 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
 905 {
 906         if(src -> result -> class != dst -> result -> class)
 907         {
 908                 oberon_error(ctx, "incompatible assignment types");
 909         }
 910
 911         if(dst -> result -> class == OBERON_TYPE_INTEGER)
 912         {
 913                 if((dst -> result -> size) < (src -> result -> size))
 914                 {
 915                         oberon_error(ctx, "incompatible assignment type size");
 916                 }
 917         }
 918
 919         oberon_generate_assign(ctx, src, dst);
 920 }
 921
 922 static void
 923 oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
 924 {
 925         if(desig -> is_item == 0)
 926         {
 927                 oberon_error(ctx, "expected item");
 928         }
 929
 930         if(desig -> item.mode != MODE_CALL)
 931         {
 932                 oberon_error(ctx, "expected mode CALL");
 933         }
 934
 935         if(desig -> item.var -> class != OBERON_CLASS_PROC)
 936         {
 937                 oberon_error(ctx, "only procedures can be called");
 938         }
 939
 940         // TODO check arguments
 941
 942         oberon_generate_call_proc(ctx, desig);
 943 }
 944
 945 static void
 946 oberon_statement(oberon_context_t * ctx)
 947 {
 948         oberon_expr_t * item1;
 949         oberon_expr_t * item2;
 950
 951         if(ctx -> token == IDENT)
 952         {
 953                 item1 = oberon_expr(ctx);
 954                 if(ctx -> token == ASSIGN)
 955                 {
 956                         oberon_assert_token(ctx, ASSIGN);
 957                         item2 = oberon_expr(ctx);
 958                         oberon_assign(ctx, item2, item1);
 959                 }
 960                 else
 961                 {
 962                         oberon_make_call(ctx, item1);
 963                 }
 964         }
 965 }
 966
 967 static void
 968 oberon_statement_seq(oberon_context_t * ctx)
 969 {
 970         oberon_statement(ctx);
 971         while(ctx -> token == SEMICOLON)
 972         {
 973                 oberon_assert_token(ctx, SEMICOLON);
 974                 oberon_statement(ctx);
 975         }
 976 }
 977
 978 static void
 979 oberon_parse_module(oberon_context_t * ctx)
 980 {
 981         char *name1, *name2;
 982         oberon_read_token(ctx);
 983
 984         oberon_assert_token(ctx, MODULE);
 985         name1 = oberon_assert_ident(ctx);
 986         oberon_assert_token(ctx, SEMICOLON);
 987         ctx -> mod -> name = name1;
 988
 989         oberon_decl_seq(ctx);
 990
 991         if(ctx -> token == BEGIN)
 992         {
 993                 oberon_assert_token(ctx, BEGIN);
 994                 oberon_generate_begin_module(ctx);
 995                 oberon_statement_seq(ctx);
 996                 oberon_generate_end_module(ctx);
 997         }
 998
 999         oberon_assert_token(ctx, END);
1000         name2 = oberon_assert_ident(ctx);
1001         oberon_assert_token(ctx, DOT);
1002
1003         if(strcmp(name1, name2) != 0)
1004         {
1005                 oberon_error(ctx, "module name not matched");
1006         }
1007 }
1008
1009 // =======================================================================
1010 //   LIBRARY
1011 // =======================================================================
1012
1013 static oberon_type_t *
1014 oberon_new_type_ptr(int class)
1015 {
1016         oberon_type_t * x = malloc(sizeof *x);
1017         memset(x, 0, sizeof *x);
1018         x -> class = class;
1019         return x;
1020 }
1021
1022 static oberon_type_t *
1023 oberon_new_type_integer(int size)
1024 {
1025         oberon_type_t * x;
1026         x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
1027         x -> size = size;
1028         return x;
1029 }
1030
1031 static oberon_type_t *
1032 oberon_new_type_boolean(int size)
1033 {
1034         oberon_type_t * x;
1035         x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
1036         x -> size = size;
1037         return x;
1038 }
1039
1040 static void
1041 register_default_types(oberon_context_t * ctx)
1042 {
1043         ctx -> int_type = oberon_new_type_integer(sizeof(int));
1044         ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
1045
1046         oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
1047         oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
1048 }
1049
1050 oberon_context_t *
1051 oberon_create_context()
1052 {
1053         oberon_context_t * ctx = malloc(sizeof *ctx);
1054         memset(ctx, 0, sizeof *ctx);
1055
1056         oberon_scope_t * world_scope;
1057         world_scope = oberon_open_scope(ctx);
1058         ctx -> world_scope = world_scope;
1059
1060         oberon_generator_init_context(ctx);
1061
1062         register_default_types(ctx);
1063
1064         return ctx;
1065 }
1066
1067 void
1068 oberon_destroy_context(oberon_context_t * ctx)
1069 {
1070         oberon_generator_destroy_context(ctx);
1071         free(ctx);
1072 }
1073
1074 oberon_module_t *
1075 oberon_compile_module(oberon_context_t * ctx, const char * code)
1076 {
1077         oberon_module_t * mod = malloc(sizeof *mod);
1078         memset(mod, 0, sizeof *mod);
1079         ctx -> mod = mod;
1080
1081         oberon_scope_t * module_scope;
1082         module_scope = oberon_open_scope(ctx);
1083         mod -> decl = module_scope;
1084
1085         oberon_init_scaner(ctx, code);
1086         oberon_parse_module(ctx);
1087
1088         oberon_generate_code(ctx);
1089
1090         ctx -> mod = NULL;
1091         return mod;
1092 }