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 desinator");
 524                         }
 525                         expr -> item.var = var;
 526                         break;
 527                 case INTEGER:
 528                         expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
 529                         expr -> item.integer = ctx -> integer;
 530                         oberon_assert_token(ctx, INTEGER);
 531                         break;
 532                 case TRUE:
 533                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 534                         expr -> item.boolean = 1;
 535                         oberon_assert_token(ctx, TRUE);
 536                         break;
 537                 case FALSE:
 538                         expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
 539                         expr -> item.boolean = 0;
 540                         oberon_assert_token(ctx, FALSE);
 541                         break;
 542                 case LPAREN:
 543                         oberon_assert_token(ctx, LPAREN);
 544                         expr = oberon_expr(ctx);
 545                         oberon_assert_token(ctx, RPAREN);
 546                         break;
 547                 case NOT:
 548                         oberon_assert_token(ctx, NOT);
 549                         expr = oberon_factor(ctx);
 550                         expr = oberon_make_unary_op(ctx, NOT, expr);
 551                         break;
 552                 default:
 553                         oberon_error(ctx, "invalid expression");
 554         }
 555
 556         return expr;
 557 }
 558
 559 /*
 560  * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
 561  *   1. Классы обоих типов должны быть одинаковы
 562  *   2. В качестве результата должен быть выбран больший тип.
 563  *   3. Если размер результат не должен быть меньше чем базовый int
 564  */
 565
 566 static void
 567 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
 568 {
 569         if((a -> class) != (b -> class))
 570         {
 571                 oberon_error(ctx, "incompatible types");
 572         }
 573
 574         if((a -> size) > (b -> size))
 575         {
 576                 *result = a;
 577         }
 578         else
 579         {
 580                 *result = b;
 581         }
 582
 583         if(((*result) -> class) == OBERON_TYPE_INTEGER)
 584         {
 585                 if(((*result) -> size) < (ctx -> int_type -> size))
 586                 {
 587                         *result = ctx -> int_type;
 588                 }
 589         }
 590
 591         /* TODO: cast types */
 592 }
 593
 594 #define ITMAKESBOOLEAN(x) \
 595         (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
 596
 597 #define ITUSEONLYINTEGER(x) \
 598         ((x) >= LESS && (x) <= GEQ)
 599
 600 #define ITUSEONLYBOOLEAN(x) \
 601         (((x) == OR) || ((x) == AND))
 602
 603 static oberon_expr_t *
 604 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
 605 {
 606         oberon_expr_t * expr;
 607         oberon_type_t * result;
 608
 609         oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
 610
 611         if(ITMAKESBOOLEAN(token))
 612         {
 613                 if(ITUSEONLYINTEGER(token))
 614                 {
 615                         if(a -> result -> class != OBERON_TYPE_INTEGER
 616                                 && b -> result -> class != OBERON_TYPE_INTEGER)
 617                         {
 618                                 oberon_error(ctx, "used only with integer types");
 619                         }
 620                 }
 621                 else if(ITUSEONLYBOOLEAN(token))
 622                 {
 623                         if(a -> result -> class != OBERON_TYPE_BOOLEAN
 624                                 && b -> result -> class != OBERON_TYPE_BOOLEAN)
 625                         {
 626                                 oberon_error(ctx, "used only with boolean type");
 627                         }
 628                 }
 629
 630                 if(token == EQUAL)
 631                 {
 632                         expr = oberon_new_operator(OP_EQ, result, a, b);
 633                 }
 634                 else if(token == NEQ)
 635                 {
 636                         expr = oberon_new_operator(OP_NEQ, result, a, b);
 637                 }
 638                 else if(token == LESS)
 639                 {
 640                         expr = oberon_new_operator(OP_LSS, result, a, b);
 641                 }
 642                 else if(token == LEQ)
 643                 {
 644                         expr = oberon_new_operator(OP_LEQ, result, a, b);
 645                 }
 646                 else if(token == GREAT)
 647                 {
 648                         expr = oberon_new_operator(OP_GRT, result, a, b);
 649                 }
 650                 else if(token == GEQ)
 651                 {
 652                         expr = oberon_new_operator(OP_GEQ, result, a, b);
 653                 }
 654                 else if(token == OR)
 655                 {
 656                         expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
 657                 }
 658                 else if(token == AND)
 659                 {
 660                         expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
 661                 }
 662                 else
 663                 {
 664                         oberon_error(ctx, "oberon_make_bin_op: bool wat");
 665                 }
 666         }
 667         else
 668         {
 669                 if(token == PLUS)
 670                 {
 671                         expr = oberon_new_operator(OP_ADD, result, a, b);
 672                 }
 673                 else if(token == MINUS)
 674                 {
 675                         expr = oberon_new_operator(OP_SUB, result, a, b);
 676                 }
 677                 else if(token == STAR)
 678                 {
 679                         expr = oberon_new_operator(OP_MUL, result, a, b);
 680                 }
 681                 else if(token == SLASH)
 682                 {
 683                         expr = oberon_new_operator(OP_DIV, result, a, b);
 684                 }
 685                 else if(token == DIV)
 686                 {
 687                         expr = oberon_new_operator(OP_DIV, result, a, b);
 688                 }
 689                 else if(token == MOD)
 690                 {
 691                         expr = oberon_new_operator(OP_MOD, result, a, b);
 692                 }
 693                 else
 694                 {
 695                         oberon_error(ctx, "oberon_make_bin_op: bin wat");
 696                 }
 697         }
 698
 699         return expr;
 700 }
 701
 702 #define ISMULOP(x) \
 703         ((x) >= STAR && (x) <= AND)
 704
 705 static oberon_expr_t *
 706 oberon_term_expr(oberon_context_t * ctx)
 707 {
 708         oberon_expr_t * expr;
 709
 710         expr = oberon_factor(ctx);
 711         while(ISMULOP(ctx -> token))
 712         {
 713                 int token = ctx -> token;
 714                 oberon_read_token(ctx);
 715
 716                 oberon_expr_t * inter = oberon_factor(ctx);
 717                 expr = oberon_make_bin_op(ctx, token, expr, inter);
 718         }
 719
 720         return expr;
 721 }
 722
 723 #define ISADDOP(x) \
 724         ((x) >= PLUS && (x) <= OR)
 725
 726 static oberon_expr_t *
 727 oberon_simple_expr(oberon_context_t * ctx)
 728 {
 729         oberon_expr_t * expr;
 730
 731         int minus = 0;
 732         if(ctx -> token == PLUS)
 733         {
 734                 minus = 0;
 735                 oberon_assert_token(ctx, PLUS);
 736         }
 737         else if(ctx -> token == MINUS)
 738         {
 739                 minus = 1;
 740                 oberon_assert_token(ctx, MINUS);
 741         }
 742
 743         expr = oberon_term_expr(ctx);
 744         while(ISADDOP(ctx -> token))
 745         {
 746                 int token = ctx -> token;
 747                 oberon_read_token(ctx);
 748
 749                 oberon_expr_t * inter = oberon_term_expr(ctx);
 750                 expr = oberon_make_bin_op(ctx, token, expr, inter);
 751         }
 752
 753         if(minus)
 754         {
 755                 expr = oberon_make_unary_op(ctx, MINUS, expr);
 756         }
 757
 758         return expr;
 759 }
 760
 761 #define ISRELATION(x) \
 762         ((x) >= EQUAL && (x) <= GEQ)
 763
 764 static oberon_expr_t *
 765 oberon_expr(oberon_context_t * ctx)
 766 {
 767         oberon_expr_t * expr;
 768
 769         expr = oberon_simple_expr(ctx);
 770         while(ISRELATION(ctx -> token))
 771         {
 772                 int token = ctx -> token;
 773                 oberon_read_token(ctx);
 774
 775                 oberon_expr_t * inter = oberon_simple_expr(ctx);
 776                 expr = oberon_make_bin_op(ctx, token, expr, inter);
 777         }
 778
 779         return expr;
 780 }
 781
 782 // =======================================================================
 783 //   PARSER
 784 // =======================================================================
 785
 786 static void oberon_statement_seq(oberon_context_t * ctx);
 787
 788 static void
 789 oberon_expect_token(oberon_context_t * ctx, int token)
 790 {
 791         if(ctx -> token != token)
 792         {
 793                 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
 794         }
 795 }
 796
 797 static void
 798 oberon_assert_token(oberon_context_t * ctx, int token)
 799 {
 800         oberon_expect_token(ctx, token);
 801         oberon_read_token(ctx);
 802 }
 803
 804 static char *
 805 oberon_assert_ident(oberon_context_t * ctx)
 806 {
 807         oberon_expect_token(ctx, IDENT);
 808         char * ident = ctx -> string;
 809         oberon_read_token(ctx);
 810         return ident;
 811 }
 812
 813 static oberon_type_t *
 814 oberon_type(oberon_context_t * ctx)
 815 {
 816         char * name = oberon_assert_ident(ctx);
 817         oberon_type_t * type = oberon_find_type(ctx -> decl, name);
 818         return type;
 819 }
 820
 821 static void
 822 oberon_var_decl(oberon_context_t * ctx)
 823 {
 824         char * name = oberon_assert_ident(ctx);
 825         oberon_assert_token(ctx, COLON);
 826         oberon_type_t * type = oberon_type(ctx);
 827         oberon_define_var(ctx -> decl, name, type);
 828 }
 829
 830 static void
 831 oberon_make_procedure_begin(oberon_context_t * ctx, char * name)
 832 {
 833         oberon_object_t * proc;
 834         proc = oberon_define_proc(ctx -> decl, name);
 835
 836         oberon_open_scope(ctx);
 837
 838         oberon_generate_begin_proc(ctx, proc);
 839 }
 840
 841 static void
 842 oberon_make_procedure_end(oberon_context_t * ctx)
 843 {
 844         oberon_generate_end_proc(ctx);
 845
 846         oberon_close_scope(ctx -> decl);
 847 }
 848
 849 static void
 850 oberon_proc_decl(oberon_context_t * ctx)
 851 {
 852         oberon_assert_token(ctx, PROCEDURE);
 853
 854         char * name;
 855         name = oberon_assert_ident(ctx);
 856
 857         oberon_assert_token(ctx, SEMICOLON);
 858
 859         oberon_make_procedure_begin(ctx, name);
 860         if(ctx -> token == BEGIN)
 861         {
 862                 oberon_assert_token(ctx, BEGIN);
 863                 oberon_statement_seq(ctx);
 864         }
 865         oberon_make_procedure_end(ctx);
 866
 867         oberon_assert_token(ctx, END);
 868         char * name2 = oberon_assert_ident(ctx);
 869
 870         if(strcmp(name2, name) != 0)
 871         {
 872                 oberon_error(ctx, "procedure name not matched");
 873         }
 874 }
 875
 876 static void
 877 oberon_decl_seq(oberon_context_t * ctx)
 878 {
 879         if(ctx -> token == VAR)
 880         {
 881                 oberon_assert_token(ctx, VAR);
 882                 while(ctx -> token == IDENT)
 883                 {
 884                         oberon_var_decl(ctx);
 885                         oberon_assert_token(ctx, SEMICOLON);
 886                 }
 887         }
 888
 889         if(ctx -> token == PROCEDURE)
 890         {
 891                 oberon_proc_decl(ctx);
 892                 oberon_assert_token(ctx, SEMICOLON);
 893         }
 894 }
 895
 896 static void
 897 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
 898 {
 899         if(src -> result -> class != dst -> result -> class)
 900         {
 901                 oberon_error(ctx, "incompatible assignment types");
 902         }
 903
 904         if(dst -> result -> class == OBERON_TYPE_INTEGER)
 905         {
 906                 if((dst -> result -> size) < (src -> result -> size))
 907                 {
 908                         oberon_error(ctx, "incompatible assignment type size");
 909                 }
 910         }
 911
 912         oberon_generate_assign(ctx, src, dst);
 913 }
 914
 915 static void
 916 oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
 917 {
 918         if(desig -> is_item == 0)
 919         {
 920                 oberon_error(ctx, "expected item");
 921         }
 922
 923         if(desig -> item.mode != MODE_CALL)
 924         {
 925                 oberon_error(ctx, "expected mode CALL");
 926         }
 927
 928         if(desig -> item.var -> class != OBERON_CLASS_PROC)
 929         {
 930                 oberon_error(ctx, "only procedures can be called");
 931         }
 932
 933         // TODO check arguments
 934
 935         oberon_generate_call_proc(ctx, desig);
 936 }
 937
 938 static void
 939 oberon_statement(oberon_context_t * ctx)
 940 {
 941         oberon_expr_t * item1;
 942         oberon_expr_t * item2;
 943
 944         if(ctx -> token == IDENT)
 945         {
 946                 item1 = oberon_expr(ctx);
 947                 if(ctx -> token == ASSIGN)
 948                 {
 949                         oberon_assert_token(ctx, ASSIGN);
 950                         item2 = oberon_expr(ctx);
 951                         oberon_assign(ctx, item2, item1);
 952                 }
 953                 else
 954                 {
 955                         oberon_make_call(ctx, item1);
 956                 }
 957         }
 958 }
 959
 960 static void
 961 oberon_statement_seq(oberon_context_t * ctx)
 962 {
 963         oberon_statement(ctx);
 964         while(ctx -> token == SEMICOLON)
 965         {
 966                 oberon_assert_token(ctx, SEMICOLON);
 967                 oberon_statement(ctx);
 968         }
 969 }
 970
 971 static void
 972 oberon_parse_module(oberon_context_t * ctx)
 973 {
 974         char *name1, *name2;
 975         oberon_read_token(ctx);
 976
 977         oberon_assert_token(ctx, MODULE);
 978         name1 = oberon_assert_ident(ctx);
 979         oberon_assert_token(ctx, SEMICOLON);
 980         ctx -> mod -> name = name1;
 981
 982         oberon_decl_seq(ctx);
 983
 984         if(ctx -> token == BEGIN)
 985         {
 986                 oberon_assert_token(ctx, BEGIN);
 987                 oberon_generate_begin_module(ctx);
 988                 oberon_statement_seq(ctx);
 989                 oberon_generate_end_module(ctx);
 990         }
 991
 992         oberon_assert_token(ctx, END);
 993         name2 = oberon_assert_ident(ctx);
 994         oberon_assert_token(ctx, DOT);
 995
 996         if(strcmp(name1, name2) != 0)
 997         {
 998                 oberon_error(ctx, "module name not matched");
 999         }
1000 }
1001
1002 // =======================================================================
1003 //   LIBRARY
1004 // =======================================================================
1005
1006 static oberon_type_t *
1007 oberon_new_type_ptr(int class)
1008 {
1009         oberon_type_t * x = malloc(sizeof *x);
1010         memset(x, 0, sizeof *x);
1011         x -> class = class;
1012         return x;
1013 }
1014
1015 static oberon_type_t *
1016 oberon_new_type_integer(int size)
1017 {
1018         oberon_type_t * x;
1019         x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
1020         x -> size = size;
1021         return x;
1022 }
1023
1024 static oberon_type_t *
1025 oberon_new_type_boolean(int size)
1026 {
1027         oberon_type_t * x;
1028         x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
1029         x -> size = size;
1030         return x;
1031 }
1032
1033 static void
1034 register_default_types(oberon_context_t * ctx)
1035 {
1036         ctx -> int_type = oberon_new_type_integer(sizeof(int));
1037         ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
1038
1039         oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
1040         oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
1041 }
1042
1043 oberon_context_t *
1044 oberon_create_context()
1045 {
1046         oberon_context_t * ctx = malloc(sizeof *ctx);
1047         memset(ctx, 0, sizeof *ctx);
1048
1049         oberon_scope_t * world_scope;
1050         world_scope = oberon_open_scope(ctx);
1051         ctx -> world_scope = world_scope;
1052
1053         oberon_generator_init_context(ctx);
1054
1055         register_default_types(ctx);
1056
1057         return ctx;
1058 }
1059
1060 void
1061 oberon_destroy_context(oberon_context_t * ctx)
1062 {
1063         oberon_generator_destroy_context(ctx);
1064         free(ctx);
1065 }
1066
1067 oberon_module_t *
1068 oberon_compile_module(oberon_context_t * ctx, const char * code)
1069 {
1070         oberon_module_t * mod = malloc(sizeof *mod);
1071         memset(mod, 0, sizeof *mod);
1072         ctx -> mod = mod;
1073
1074         oberon_scope_t * module_scope;
1075         module_scope = oberon_open_scope(ctx);
1076         mod -> decl = module_scope;
1077
1078         oberon_init_scaner(ctx, code);
1079         oberon_parse_module(ctx);
1080
1081         oberon_generate_code(ctx);
1082
1083         ctx -> mod = NULL;
1084         return mod;
1085 }