oberon.c

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