DEADSOFTWARE

JVM: Добавлено копирование массивов
[dsw-obn.git] / src / 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 #include <stdbool.h>
9 #include "../include/oberon.h"
11 #include "oberon-internals.h"
12 #include "generator.h"
14 enum {
15 EOF_ = 0,
16 IDENT,
17 MODULE,
18 SEMICOLON,
19 END,
20 DOT,
21 VAR,
22 COLON,
23 BEGIN,
24 ASSIGN,
25 INTEGER,
26 TRUE,
27 FALSE,
28 LPAREN,
29 RPAREN,
30 EQUAL,
31 NEQ,
32 LESS,
33 LEQ,
34 GREAT,
35 GEQ,
36 PLUS,
37 MINUS,
38 OR,
39 STAR,
40 SLASH,
41 DIV,
42 MOD,
43 AND,
44 NOT,
45 PROCEDURE,
46 COMMA,
47 RETURN,
48 CONST,
49 TYPE,
50 ARRAY,
51 OF,
52 LBRACE,
53 RBRACE,
54 RECORD,
55 POINTER,
56 TO,
57 UPARROW,
58 NIL,
59 IMPORT,
60 REAL
61 };
63 // =======================================================================
64 // UTILS
65 // =======================================================================
67 static void
68 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
69 {
70 va_list ptr;
71 va_start(ptr, fmt);
72 fprintf(stderr, "error: ");
73 vfprintf(stderr, fmt, ptr);
74 fprintf(stderr, "\n");
75 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
76 fprintf(stderr, " c = %c\n", ctx -> c);
77 fprintf(stderr, " token = %i\n", ctx -> token);
78 va_end(ptr);
79 exit(1);
80 }
82 static oberon_type_t *
83 oberon_new_type_ptr(int class)
84 {
85 oberon_type_t * x = malloc(sizeof *x);
86 memset(x, 0, sizeof *x);
87 x -> class = class;
88 return x;
89 }
91 static oberon_type_t *
92 oberon_new_type_integer(int size)
93 {
94 oberon_type_t * x;
95 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
96 x -> size = size;
97 return x;
98 }
100 static oberon_type_t *
101 oberon_new_type_boolean(int size)
103 oberon_type_t * x;
104 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
105 x -> size = size;
106 return x;
109 static oberon_type_t *
110 oberon_new_type_real(int size)
112 oberon_type_t * x;
113 x = oberon_new_type_ptr(OBERON_TYPE_REAL);
114 x -> size = size;
115 return x;
118 // =======================================================================
119 // TABLE
120 // =======================================================================
122 static oberon_scope_t *
123 oberon_open_scope(oberon_context_t * ctx)
125 oberon_scope_t * scope = calloc(1, sizeof *scope);
126 oberon_object_t * list = calloc(1, sizeof *list);
128 scope -> ctx = ctx;
129 scope -> list = list;
130 scope -> up = ctx -> decl;
132 if(scope -> up)
134 scope -> local = scope -> up -> local;
135 scope -> parent = scope -> up -> parent;
136 scope -> parent_type = scope -> up -> parent_type;
139 ctx -> decl = scope;
140 return scope;
143 static void
144 oberon_close_scope(oberon_scope_t * scope)
146 oberon_context_t * ctx = scope -> ctx;
147 ctx -> decl = scope -> up;
150 static oberon_object_t *
151 oberon_define_object(oberon_scope_t * scope, char * name, int class, int export, int read_only)
153 oberon_object_t * x = scope -> list;
154 while(x -> next && strcmp(x -> next -> name, name) != 0)
156 x = x -> next;
159 if(x -> next)
161 oberon_error(scope -> ctx, "already defined");
164 oberon_object_t * newvar = malloc(sizeof *newvar);
165 memset(newvar, 0, sizeof *newvar);
166 newvar -> name = name;
167 newvar -> class = class;
168 newvar -> export = export;
169 newvar -> read_only = read_only;
170 newvar -> local = scope -> local;
171 newvar -> parent = scope -> parent;
172 newvar -> parent_type = scope -> parent_type;
173 newvar -> module = scope -> ctx -> mod;
175 x -> next = newvar;
177 return newvar;
180 static oberon_object_t *
181 oberon_find_object_in_list(oberon_object_t * list, char * name)
183 oberon_object_t * x = list;
184 while(x -> next && strcmp(x -> next -> name, name) != 0)
186 x = x -> next;
188 return x -> next;
191 static oberon_object_t *
192 oberon_find_object(oberon_scope_t * scope, char * name, int check_it)
194 oberon_object_t * result = NULL;
196 oberon_scope_t * s = scope;
197 while(result == NULL && s != NULL)
199 result = oberon_find_object_in_list(s -> list, name);
200 s = s -> up;
203 if(check_it && result == NULL)
205 oberon_error(scope -> ctx, "undefined ident %s", name);
208 return result;
211 static oberon_object_t *
212 oberon_find_field(oberon_context_t * ctx, oberon_type_t * rec, char * name)
214 oberon_object_t * x = rec -> decl;
215 for(int i = 0; i < rec -> num_decl; i++)
217 if(strcmp(x -> name, name) == 0)
219 return x;
221 x = x -> next;
224 oberon_error(ctx, "field not defined");
226 return NULL;
229 static oberon_object_t *
230 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export)
232 oberon_object_t * id;
233 id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, 0);
234 id -> type = type;
235 oberon_generator_init_type(scope -> ctx, type);
236 return id;
239 // =======================================================================
240 // SCANER
241 // =======================================================================
243 static void
244 oberon_get_char(oberon_context_t * ctx)
246 if(ctx -> code[ctx -> code_index])
248 ctx -> code_index += 1;
249 ctx -> c = ctx -> code[ctx -> code_index];
253 static void
254 oberon_init_scaner(oberon_context_t * ctx, const char * code)
256 ctx -> code = code;
257 ctx -> code_index = 0;
258 ctx -> c = ctx -> code[ctx -> code_index];
261 static void
262 oberon_read_ident(oberon_context_t * ctx)
264 int len = 0;
265 int i = ctx -> code_index;
267 int c = ctx -> code[i];
268 while(isalnum(c))
270 i += 1;
271 len += 1;
272 c = ctx -> code[i];
275 char * ident = malloc(len + 1);
276 memcpy(ident, &ctx->code[ctx->code_index], len);
277 ident[len] = 0;
279 ctx -> code_index = i;
280 ctx -> c = ctx -> code[i];
281 ctx -> string = ident;
282 ctx -> token = IDENT;
284 if(strcmp(ident, "MODULE") == 0)
286 ctx -> token = MODULE;
288 else if(strcmp(ident, "END") == 0)
290 ctx -> token = END;
292 else if(strcmp(ident, "VAR") == 0)
294 ctx -> token = VAR;
296 else if(strcmp(ident, "BEGIN") == 0)
298 ctx -> token = BEGIN;
300 else if(strcmp(ident, "TRUE") == 0)
302 ctx -> token = TRUE;
304 else if(strcmp(ident, "FALSE") == 0)
306 ctx -> token = FALSE;
308 else if(strcmp(ident, "OR") == 0)
310 ctx -> token = OR;
312 else if(strcmp(ident, "DIV") == 0)
314 ctx -> token = DIV;
316 else if(strcmp(ident, "MOD") == 0)
318 ctx -> token = MOD;
320 else if(strcmp(ident, "PROCEDURE") == 0)
322 ctx -> token = PROCEDURE;
324 else if(strcmp(ident, "RETURN") == 0)
326 ctx -> token = RETURN;
328 else if(strcmp(ident, "CONST") == 0)
330 ctx -> token = CONST;
332 else if(strcmp(ident, "TYPE") == 0)
334 ctx -> token = TYPE;
336 else if(strcmp(ident, "ARRAY") == 0)
338 ctx -> token = ARRAY;
340 else if(strcmp(ident, "OF") == 0)
342 ctx -> token = OF;
344 else if(strcmp(ident, "RECORD") == 0)
346 ctx -> token = RECORD;
348 else if(strcmp(ident, "POINTER") == 0)
350 ctx -> token = POINTER;
352 else if(strcmp(ident, "TO") == 0)
354 ctx -> token = TO;
356 else if(strcmp(ident, "NIL") == 0)
358 ctx -> token = NIL;
360 else if(strcmp(ident, "IMPORT") == 0)
362 ctx -> token = IMPORT;
366 static void
367 oberon_read_number(oberon_context_t * ctx)
369 long integer;
370 double real;
371 char * ident;
372 int start_i;
373 int exp_i;
374 int end_i;
376 /*
377 * mode = 0 == DEC
378 * mode = 1 == HEX
379 * mode = 2 == REAL
380 * mode = 3 == LONGREAL
381 */
382 int mode = 0;
383 start_i = ctx -> code_index;
385 while(isdigit(ctx -> c))
387 oberon_get_char(ctx);
390 end_i = ctx -> code_index;
392 if(isxdigit(ctx -> c))
394 mode = 1;
395 while(isxdigit(ctx -> c))
397 oberon_get_char(ctx);
400 end_i = ctx -> code_index;
402 if(ctx -> c != 'H')
404 oberon_error(ctx, "invalid hex number");
406 oberon_get_char(ctx);
408 else if(ctx -> c == '.')
410 mode = 2;
411 oberon_get_char(ctx);
413 while(isdigit(ctx -> c))
415 oberon_get_char(ctx);
418 if(ctx -> c == 'E' || ctx -> c == 'D')
420 exp_i = ctx -> code_index;
422 if(ctx -> c == 'D')
424 mode = 3;
427 oberon_get_char(ctx);
429 if(ctx -> c == '+' || ctx -> c == '-')
431 oberon_get_char(ctx);
434 while(isdigit(ctx -> c))
436 oberon_get_char(ctx);
441 end_i = ctx -> code_index;
444 int len = end_i - start_i;
445 ident = malloc(len + 1);
446 memcpy(ident, &ctx -> code[start_i], len);
447 ident[len] = 0;
449 if(mode == 3)
451 int i = exp_i - start_i;
452 ident[i] = 'E';
455 switch(mode)
457 case 0:
458 integer = atol(ident);
459 real = integer;
460 ctx -> token = INTEGER;
461 break;
462 case 1:
463 sscanf(ident, "%lx", &integer);
464 real = integer;
465 ctx -> token = INTEGER;
466 break;
467 case 2:
468 case 3:
469 sscanf(ident, "%lf", &real);
470 ctx -> token = REAL;
471 break;
472 default:
473 oberon_error(ctx, "oberon_read_number: wat");
474 break;
477 ctx -> string = ident;
478 ctx -> integer = integer;
479 ctx -> real = real;
482 static void
483 oberon_skip_space(oberon_context_t * ctx)
485 while(isspace(ctx -> c))
487 oberon_get_char(ctx);
491 static void
492 oberon_read_comment(oberon_context_t * ctx)
494 int nesting = 1;
495 while(nesting >= 1)
497 if(ctx -> c == '(')
499 oberon_get_char(ctx);
500 if(ctx -> c == '*')
502 oberon_get_char(ctx);
503 nesting += 1;
506 else if(ctx -> c == '*')
508 oberon_get_char(ctx);
509 if(ctx -> c == ')')
511 oberon_get_char(ctx);
512 nesting -= 1;
515 else if(ctx -> c == 0)
517 oberon_error(ctx, "unterminated comment");
519 else
521 oberon_get_char(ctx);
526 static void oberon_read_token(oberon_context_t * ctx);
528 static void
529 oberon_read_symbol(oberon_context_t * ctx)
531 int c = ctx -> c;
532 switch(c)
534 case 0:
535 ctx -> token = EOF_;
536 break;
537 case ';':
538 ctx -> token = SEMICOLON;
539 oberon_get_char(ctx);
540 break;
541 case ':':
542 ctx -> token = COLON;
543 oberon_get_char(ctx);
544 if(ctx -> c == '=')
546 ctx -> token = ASSIGN;
547 oberon_get_char(ctx);
549 break;
550 case '.':
551 ctx -> token = DOT;
552 oberon_get_char(ctx);
553 break;
554 case '(':
555 ctx -> token = LPAREN;
556 oberon_get_char(ctx);
557 if(ctx -> c == '*')
559 oberon_get_char(ctx);
560 oberon_read_comment(ctx);
561 oberon_read_token(ctx);
563 break;
564 case ')':
565 ctx -> token = RPAREN;
566 oberon_get_char(ctx);
567 break;
568 case '=':
569 ctx -> token = EQUAL;
570 oberon_get_char(ctx);
571 break;
572 case '#':
573 ctx -> token = NEQ;
574 oberon_get_char(ctx);
575 break;
576 case '<':
577 ctx -> token = LESS;
578 oberon_get_char(ctx);
579 if(ctx -> c == '=')
581 ctx -> token = LEQ;
582 oberon_get_char(ctx);
584 break;
585 case '>':
586 ctx -> token = GREAT;
587 oberon_get_char(ctx);
588 if(ctx -> c == '=')
590 ctx -> token = GEQ;
591 oberon_get_char(ctx);
593 break;
594 case '+':
595 ctx -> token = PLUS;
596 oberon_get_char(ctx);
597 break;
598 case '-':
599 ctx -> token = MINUS;
600 oberon_get_char(ctx);
601 break;
602 case '*':
603 ctx -> token = STAR;
604 oberon_get_char(ctx);
605 if(ctx -> c == ')')
607 oberon_get_char(ctx);
608 oberon_error(ctx, "unstarted comment");
610 break;
611 case '/':
612 ctx -> token = SLASH;
613 oberon_get_char(ctx);
614 break;
615 case '&':
616 ctx -> token = AND;
617 oberon_get_char(ctx);
618 break;
619 case '~':
620 ctx -> token = NOT;
621 oberon_get_char(ctx);
622 break;
623 case ',':
624 ctx -> token = COMMA;
625 oberon_get_char(ctx);
626 break;
627 case '[':
628 ctx -> token = LBRACE;
629 oberon_get_char(ctx);
630 break;
631 case ']':
632 ctx -> token = RBRACE;
633 oberon_get_char(ctx);
634 break;
635 case '^':
636 ctx -> token = UPARROW;
637 oberon_get_char(ctx);
638 break;
639 default:
640 oberon_error(ctx, "invalid char %c", ctx -> c);
641 break;
645 static void
646 oberon_read_token(oberon_context_t * ctx)
648 oberon_skip_space(ctx);
650 int c = ctx -> c;
651 if(isalpha(c))
653 oberon_read_ident(ctx);
655 else if(isdigit(c))
657 oberon_read_number(ctx);
659 else
661 oberon_read_symbol(ctx);
665 // =======================================================================
666 // EXPRESSION
667 // =======================================================================
669 static void oberon_expect_token(oberon_context_t * ctx, int token);
670 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
671 static void oberon_assert_token(oberon_context_t * ctx, int token);
672 static char * oberon_assert_ident(oberon_context_t * ctx);
673 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
674 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
676 static oberon_expr_t *
677 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
679 oberon_oper_t * operator;
680 operator = malloc(sizeof *operator);
681 memset(operator, 0, sizeof *operator);
683 operator -> is_item = 0;
684 operator -> result = result;
685 operator -> read_only = 1;
686 operator -> op = op;
687 operator -> left = left;
688 operator -> right = right;
690 return (oberon_expr_t *) operator;
693 static oberon_expr_t *
694 oberon_new_item(int mode, oberon_type_t * result, int read_only)
696 oberon_item_t * item;
697 item = malloc(sizeof *item);
698 memset(item, 0, sizeof *item);
700 item -> is_item = 1;
701 item -> result = result;
702 item -> read_only = read_only;
703 item -> mode = mode;
705 return (oberon_expr_t *)item;
708 static oberon_expr_t *
709 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
711 oberon_expr_t * expr;
712 oberon_type_t * result;
714 result = a -> result;
716 if(token == MINUS)
718 if(result -> class != OBERON_TYPE_INTEGER)
720 oberon_error(ctx, "incompatible operator type");
723 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
725 else if(token == NOT)
727 if(result -> class != OBERON_TYPE_BOOLEAN)
729 oberon_error(ctx, "incompatible operator type");
732 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
734 else
736 oberon_error(ctx, "oberon_make_unary_op: wat");
739 return expr;
742 static void
743 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
745 oberon_expr_t * last;
747 *num_expr = 1;
748 *first = last = oberon_expr(ctx);
749 while(ctx -> token == COMMA)
751 oberon_assert_token(ctx, COMMA);
752 oberon_expr_t * current;
754 if(const_expr)
756 current = (oberon_expr_t *) oberon_const_expr(ctx);
758 else
760 current = oberon_expr(ctx);
763 last -> next = current;
764 last = current;
765 *num_expr += 1;
769 static oberon_expr_t *
770 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
772 if(pref -> class != expr -> result -> class)
774 if(pref -> class != OBERON_TYPE_PROCEDURE)
776 if(expr -> result -> class != OBERON_TYPE_POINTER)
778 oberon_error(ctx, "incompatible types");
783 if(pref -> class == OBERON_TYPE_INTEGER)
785 if(expr -> result -> class > pref -> class)
787 oberon_error(ctx, "incompatible size");
790 else if(pref -> class == OBERON_TYPE_RECORD)
792 if(expr -> result != pref)
794 printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
795 oberon_error(ctx, "incompatible record types");
798 else if(pref -> class == OBERON_TYPE_POINTER)
800 if(expr -> result -> base != pref -> base)
802 if(expr -> result -> base -> class != OBERON_TYPE_VOID)
804 oberon_error(ctx, "incompatible pointer types");
809 // TODO cast
811 return expr;
814 static void
815 oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
817 if(desig -> is_item == 0)
819 oberon_error(ctx, "expected item");
822 if(desig -> item.mode != MODE_CALL)
824 oberon_error(ctx, "expected mode CALL");
827 if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE)
829 oberon_error(ctx, "only procedures can be called");
832 oberon_type_t * fn = desig -> item.var -> type;
833 int num_args = desig -> item.num_args;
834 int num_decl = fn -> num_decl;
836 if(num_args < num_decl)
838 oberon_error(ctx, "too few arguments");
840 else if(num_args > num_decl)
842 oberon_error(ctx, "too many arguments");
845 oberon_expr_t * arg = desig -> item.args;
846 oberon_object_t * param = fn -> decl;
847 for(int i = 0; i < num_args; i++)
849 if(param -> class == OBERON_CLASS_VAR_PARAM)
851 if(arg -> read_only)
853 oberon_error(ctx, "assign to read-only var");
856 //if(arg -> is_item)
857 //{
858 // switch(arg -> item.mode)
859 // {
860 // case MODE_VAR:
861 // case MODE_INDEX:
862 // case MODE_FIELD:
863 // // Допустимо разыменование?
864 // //case MODE_DEREF:
865 // break;
866 // default:
867 // oberon_error(ctx, "var-parameter accept only variables");
868 // break;
869 // }
870 //}
872 oberon_autocast_to(ctx, arg, param -> type);
873 arg = arg -> next;
874 param = param -> next;
878 static oberon_expr_t *
879 oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
881 switch(proc -> class)
883 case OBERON_CLASS_PROC:
884 if(proc -> class != OBERON_CLASS_PROC)
886 oberon_error(ctx, "not a procedure");
888 break;
889 case OBERON_CLASS_VAR:
890 case OBERON_CLASS_VAR_PARAM:
891 case OBERON_CLASS_PARAM:
892 if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
894 oberon_error(ctx, "not a procedure");
896 break;
897 default:
898 oberon_error(ctx, "not a procedure");
899 break;
902 oberon_expr_t * call;
904 if(proc -> sysproc)
906 if(proc -> genfunc == NULL)
908 oberon_error(ctx, "not a function-procedure");
911 call = proc -> genfunc(ctx, num_args, list_args);
913 else
915 if(proc -> type -> base -> class == OBERON_TYPE_VOID)
917 oberon_error(ctx, "attempt to call procedure in expression");
920 call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
921 call -> item.var = proc;
922 call -> item.num_args = num_args;
923 call -> item.args = list_args;
924 oberon_autocast_call(ctx, call);
927 return call;
930 static void
931 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
933 switch(proc -> class)
935 case OBERON_CLASS_PROC:
936 if(proc -> class != OBERON_CLASS_PROC)
938 oberon_error(ctx, "not a procedure");
940 break;
941 case OBERON_CLASS_VAR:
942 case OBERON_CLASS_VAR_PARAM:
943 case OBERON_CLASS_PARAM:
944 if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
946 oberon_error(ctx, "not a procedure");
948 break;
949 default:
950 oberon_error(ctx, "not a procedure");
951 break;
954 if(proc -> sysproc)
956 if(proc -> genproc == NULL)
958 oberon_error(ctx, "requres non-typed procedure");
961 proc -> genproc(ctx, num_args, list_args);
963 else
965 if(proc -> type -> base -> class != OBERON_TYPE_VOID)
967 oberon_error(ctx, "attempt to call function as non-typed procedure");
970 oberon_expr_t * call;
971 call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
972 call -> item.var = proc;
973 call -> item.num_args = num_args;
974 call -> item.args = list_args;
975 oberon_autocast_call(ctx, call);
976 oberon_generate_call_proc(ctx, call);
980 #define ISEXPR(x) \
981 (((x) == PLUS) \
982 || ((x) == MINUS) \
983 || ((x) == IDENT) \
984 || ((x) == INTEGER) \
985 || ((x) == LPAREN) \
986 || ((x) == NOT) \
987 || ((x) == TRUE) \
988 || ((x) == FALSE))
990 static oberon_expr_t *
991 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
993 if(expr -> result -> class != OBERON_TYPE_POINTER)
995 oberon_error(ctx, "not a pointer");
998 assert(expr -> is_item);
1000 oberon_expr_t * selector;
1001 selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
1002 selector -> item.parent = (oberon_item_t *) expr;
1004 return selector;
1007 static oberon_expr_t *
1008 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
1010 if(desig -> result -> class == OBERON_TYPE_POINTER)
1012 desig = oberno_make_dereferencing(ctx, desig);
1015 assert(desig -> is_item);
1017 if(desig -> result -> class != OBERON_TYPE_ARRAY)
1019 oberon_error(ctx, "not array");
1022 oberon_type_t * base;
1023 base = desig -> result -> base;
1025 if(index -> result -> class != OBERON_TYPE_INTEGER)
1027 oberon_error(ctx, "index must be integer");
1030 // Статическая проверка границ массива
1031 if(desig -> result -> size != 0)
1033 if(index -> is_item)
1035 if(index -> item.mode == MODE_INTEGER)
1037 int arr_size = desig -> result -> size;
1038 int index_int = index -> item.integer;
1039 if(index_int < 0 || index_int > arr_size - 1)
1041 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
1047 oberon_expr_t * selector;
1048 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
1049 selector -> item.parent = (oberon_item_t *) desig;
1050 selector -> item.num_args = 1;
1051 selector -> item.args = index;
1053 return selector;
1056 static oberon_expr_t *
1057 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
1059 if(expr -> result -> class == OBERON_TYPE_POINTER)
1061 expr = oberno_make_dereferencing(ctx, expr);
1064 assert(expr -> is_item == 1);
1066 if(expr -> result -> class != OBERON_TYPE_RECORD)
1068 oberon_error(ctx, "not record");
1071 oberon_type_t * rec = expr -> result;
1073 oberon_object_t * field;
1074 field = oberon_find_field(ctx, rec, name);
1076 if(field -> export == 0)
1078 if(field -> module != ctx -> mod)
1080 oberon_error(ctx, "field not exported");
1084 int read_only = 0;
1085 if(field -> read_only)
1087 if(field -> module != ctx -> mod)
1089 read_only = 1;
1093 oberon_expr_t * selector;
1094 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
1095 selector -> item.var = field;
1096 selector -> item.parent = (oberon_item_t *) expr;
1098 return selector;
1101 #define ISSELECTOR(x) \
1102 (((x) == LBRACE) \
1103 || ((x) == DOT) \
1104 || ((x) == UPARROW))
1106 static oberon_object_t *
1107 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1109 char * name;
1110 oberon_object_t * x;
1112 name = oberon_assert_ident(ctx);
1113 x = oberon_find_object(ctx -> decl, name, check);
1115 if(x != NULL)
1117 if(x -> class == OBERON_CLASS_MODULE)
1119 oberon_assert_token(ctx, DOT);
1120 name = oberon_assert_ident(ctx);
1121 /* Наличие объектов в левых модулях всегда проверяется */
1122 x = oberon_find_object(x -> module -> decl, name, 1);
1124 if(x -> export == 0)
1126 oberon_error(ctx, "not exported");
1131 if(xname)
1133 *xname = name;
1136 return x;
1139 static oberon_expr_t *
1140 oberon_designator(oberon_context_t * ctx)
1142 char * name;
1143 oberon_object_t * var;
1144 oberon_expr_t * expr;
1146 var = oberon_qualident(ctx, NULL, 1);
1148 int read_only = 0;
1149 if(var -> read_only)
1151 if(var -> module != ctx -> mod)
1153 read_only = 1;
1157 switch(var -> class)
1159 case OBERON_CLASS_CONST:
1160 // TODO copy value
1161 expr = (oberon_expr_t *) var -> value;
1162 break;
1163 case OBERON_CLASS_VAR:
1164 case OBERON_CLASS_VAR_PARAM:
1165 case OBERON_CLASS_PARAM:
1166 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1167 break;
1168 case OBERON_CLASS_PROC:
1169 expr = oberon_new_item(MODE_VAR, var -> type, 1);
1170 break;
1171 default:
1172 oberon_error(ctx, "invalid designator");
1173 break;
1175 expr -> item.var = var;
1177 while(ISSELECTOR(ctx -> token))
1179 switch(ctx -> token)
1181 case DOT:
1182 oberon_assert_token(ctx, DOT);
1183 name = oberon_assert_ident(ctx);
1184 expr = oberon_make_record_selector(ctx, expr, name);
1185 break;
1186 case LBRACE:
1187 oberon_assert_token(ctx, LBRACE);
1188 int num_indexes = 0;
1189 oberon_expr_t * indexes = NULL;
1190 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1191 oberon_assert_token(ctx, RBRACE);
1193 for(int i = 0; i < num_indexes; i++)
1195 expr = oberon_make_array_selector(ctx, expr, indexes);
1196 indexes = indexes -> next;
1198 break;
1199 case UPARROW:
1200 oberon_assert_token(ctx, UPARROW);
1201 expr = oberno_make_dereferencing(ctx, expr);
1202 break;
1203 default:
1204 oberon_error(ctx, "oberon_designator: wat");
1205 break;
1208 return expr;
1211 static oberon_expr_t *
1212 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1214 assert(expr -> is_item == 1);
1216 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1217 if(ctx -> token == LPAREN)
1219 oberon_assert_token(ctx, LPAREN);
1221 int num_args = 0;
1222 oberon_expr_t * arguments = NULL;
1224 if(ISEXPR(ctx -> token))
1226 oberon_expr_list(ctx, &num_args, &arguments, 0);
1229 expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
1231 oberon_assert_token(ctx, RPAREN);
1234 return expr;
1237 static void
1238 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1240 assert(expr -> is_item == 1);
1242 int num_args = 0;
1243 oberon_expr_t * arguments = NULL;
1245 if(ctx -> token == LPAREN)
1247 oberon_assert_token(ctx, LPAREN);
1249 if(ISEXPR(ctx -> token))
1251 oberon_expr_list(ctx, &num_args, &arguments, 0);
1254 oberon_assert_token(ctx, RPAREN);
1257 /* Вызов происходит даже без скобок */
1258 oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
1261 static oberon_expr_t *
1262 oberon_factor(oberon_context_t * ctx)
1264 oberon_expr_t * expr;
1266 switch(ctx -> token)
1268 case IDENT:
1269 expr = oberon_designator(ctx);
1270 expr = oberon_opt_func_parens(ctx, expr);
1271 break;
1272 case INTEGER:
1273 expr = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
1274 expr -> item.integer = ctx -> integer;
1275 oberon_assert_token(ctx, INTEGER);
1276 break;
1277 case REAL:
1278 expr = oberon_new_item(MODE_REAL, ctx -> real_type, 1);
1279 expr -> item.real = ctx -> real;
1280 oberon_assert_token(ctx, REAL);
1281 break;
1282 case TRUE:
1283 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1284 expr -> item.boolean = 1;
1285 oberon_assert_token(ctx, TRUE);
1286 break;
1287 case FALSE:
1288 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1289 expr -> item.boolean = 0;
1290 oberon_assert_token(ctx, FALSE);
1291 break;
1292 case LPAREN:
1293 oberon_assert_token(ctx, LPAREN);
1294 expr = oberon_expr(ctx);
1295 oberon_assert_token(ctx, RPAREN);
1296 break;
1297 case NOT:
1298 oberon_assert_token(ctx, NOT);
1299 expr = oberon_factor(ctx);
1300 expr = oberon_make_unary_op(ctx, NOT, expr);
1301 break;
1302 case NIL:
1303 oberon_assert_token(ctx, NIL);
1304 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, 1);
1305 break;
1306 default:
1307 oberon_error(ctx, "invalid expression");
1310 return expr;
1313 /*
1314 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1315 * 1. Классы обоих типов должны быть одинаковы
1316 * 2. В качестве результата должен быть выбран больший тип.
1317 * 3. Если размер результат не должен быть меньше чем базовый int
1318 */
1320 static void
1321 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
1323 if((a -> class) != (b -> class))
1325 oberon_error(ctx, "incompatible types");
1328 if((a -> size) > (b -> size))
1330 *result = a;
1332 else
1334 *result = b;
1337 if(((*result) -> class) == OBERON_TYPE_INTEGER)
1339 if(((*result) -> size) < (ctx -> int_type -> size))
1341 *result = ctx -> int_type;
1345 /* TODO: cast types */
1348 #define ITMAKESBOOLEAN(x) \
1349 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1351 #define ITUSEONLYINTEGER(x) \
1352 ((x) >= LESS && (x) <= GEQ)
1354 #define ITUSEONLYBOOLEAN(x) \
1355 (((x) == OR) || ((x) == AND))
1357 static oberon_expr_t *
1358 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1360 oberon_expr_t * expr;
1361 oberon_type_t * result;
1363 if(ITMAKESBOOLEAN(token))
1365 if(ITUSEONLYINTEGER(token))
1367 if(a -> result -> class != OBERON_TYPE_INTEGER
1368 || b -> result -> class != OBERON_TYPE_INTEGER)
1370 oberon_error(ctx, "used only with integer types");
1373 else if(ITUSEONLYBOOLEAN(token))
1375 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1376 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1378 oberon_error(ctx, "used only with boolean type");
1382 result = ctx -> bool_type;
1384 if(token == EQUAL)
1386 expr = oberon_new_operator(OP_EQ, result, a, b);
1388 else if(token == NEQ)
1390 expr = oberon_new_operator(OP_NEQ, result, a, b);
1392 else if(token == LESS)
1394 expr = oberon_new_operator(OP_LSS, result, a, b);
1396 else if(token == LEQ)
1398 expr = oberon_new_operator(OP_LEQ, result, a, b);
1400 else if(token == GREAT)
1402 expr = oberon_new_operator(OP_GRT, result, a, b);
1404 else if(token == GEQ)
1406 expr = oberon_new_operator(OP_GEQ, result, a, b);
1408 else if(token == OR)
1410 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1412 else if(token == AND)
1414 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1416 else
1418 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1421 else if(token == SLASH)
1423 if(a -> result -> class != OBERON_TYPE_REAL)
1425 if(a -> result -> class == OBERON_TYPE_INTEGER)
1427 oberon_error(ctx, "TODO cast int -> real");
1429 else
1431 oberon_error(ctx, "operator / requires numeric type");
1435 if(b -> result -> class != OBERON_TYPE_REAL)
1437 if(b -> result -> class == OBERON_TYPE_INTEGER)
1439 oberon_error(ctx, "TODO cast int -> real");
1441 else
1443 oberon_error(ctx, "operator / requires numeric type");
1447 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1448 expr = oberon_new_operator(OP_DIV, result, a, b);
1450 else if(token == DIV)
1452 if(a -> result -> class != OBERON_TYPE_INTEGER
1453 || b -> result -> class != OBERON_TYPE_INTEGER)
1455 oberon_error(ctx, "operator DIV requires integer type");
1458 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1459 expr = oberon_new_operator(OP_DIV, result, a, b);
1461 else
1463 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1465 if(token == PLUS)
1467 expr = oberon_new_operator(OP_ADD, result, a, b);
1469 else if(token == MINUS)
1471 expr = oberon_new_operator(OP_SUB, result, a, b);
1473 else if(token == STAR)
1475 expr = oberon_new_operator(OP_MUL, result, a, b);
1477 else if(token == MOD)
1479 expr = oberon_new_operator(OP_MOD, result, a, b);
1481 else
1483 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1487 return expr;
1490 #define ISMULOP(x) \
1491 ((x) >= STAR && (x) <= AND)
1493 static oberon_expr_t *
1494 oberon_term_expr(oberon_context_t * ctx)
1496 oberon_expr_t * expr;
1498 expr = oberon_factor(ctx);
1499 while(ISMULOP(ctx -> token))
1501 int token = ctx -> token;
1502 oberon_read_token(ctx);
1504 oberon_expr_t * inter = oberon_factor(ctx);
1505 expr = oberon_make_bin_op(ctx, token, expr, inter);
1508 return expr;
1511 #define ISADDOP(x) \
1512 ((x) >= PLUS && (x) <= OR)
1514 static oberon_expr_t *
1515 oberon_simple_expr(oberon_context_t * ctx)
1517 oberon_expr_t * expr;
1519 int minus = 0;
1520 if(ctx -> token == PLUS)
1522 minus = 0;
1523 oberon_assert_token(ctx, PLUS);
1525 else if(ctx -> token == MINUS)
1527 minus = 1;
1528 oberon_assert_token(ctx, MINUS);
1531 expr = oberon_term_expr(ctx);
1533 if(minus)
1535 expr = oberon_make_unary_op(ctx, MINUS, expr);
1538 while(ISADDOP(ctx -> token))
1540 int token = ctx -> token;
1541 oberon_read_token(ctx);
1543 oberon_expr_t * inter = oberon_term_expr(ctx);
1544 expr = oberon_make_bin_op(ctx, token, expr, inter);
1547 return expr;
1550 #define ISRELATION(x) \
1551 ((x) >= EQUAL && (x) <= GEQ)
1553 static oberon_expr_t *
1554 oberon_expr(oberon_context_t * ctx)
1556 oberon_expr_t * expr;
1558 expr = oberon_simple_expr(ctx);
1559 while(ISRELATION(ctx -> token))
1561 int token = ctx -> token;
1562 oberon_read_token(ctx);
1564 oberon_expr_t * inter = oberon_simple_expr(ctx);
1565 expr = oberon_make_bin_op(ctx, token, expr, inter);
1568 return expr;
1571 static oberon_item_t *
1572 oberon_const_expr(oberon_context_t * ctx)
1574 oberon_expr_t * expr;
1575 expr = oberon_expr(ctx);
1577 if(expr -> is_item == 0)
1579 oberon_error(ctx, "const expression are required");
1582 return (oberon_item_t *) expr;
1585 // =======================================================================
1586 // PARSER
1587 // =======================================================================
1589 static void oberon_decl_seq(oberon_context_t * ctx);
1590 static void oberon_statement_seq(oberon_context_t * ctx);
1591 static void oberon_initialize_decl(oberon_context_t * ctx);
1593 static void
1594 oberon_expect_token(oberon_context_t * ctx, int token)
1596 if(ctx -> token != token)
1598 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1602 static void
1603 oberon_assert_token(oberon_context_t * ctx, int token)
1605 oberon_expect_token(ctx, token);
1606 oberon_read_token(ctx);
1609 static char *
1610 oberon_assert_ident(oberon_context_t * ctx)
1612 oberon_expect_token(ctx, IDENT);
1613 char * ident = ctx -> string;
1614 oberon_read_token(ctx);
1615 return ident;
1618 static void
1619 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
1621 switch(ctx -> token)
1623 case STAR:
1624 oberon_assert_token(ctx, STAR);
1625 *export = 1;
1626 *read_only = 0;
1627 break;
1628 case MINUS:
1629 oberon_assert_token(ctx, MINUS);
1630 *export = 1;
1631 *read_only = 1;
1632 break;
1633 default:
1634 *export = 0;
1635 *read_only = 0;
1636 break;
1640 static oberon_object_t *
1641 oberon_ident_def(oberon_context_t * ctx, int class)
1643 char * name;
1644 int export;
1645 int read_only;
1646 oberon_object_t * x;
1648 name = oberon_assert_ident(ctx);
1649 oberon_def(ctx, &export, &read_only);
1651 x = oberon_define_object(ctx -> decl, name, class, export, read_only);
1652 return x;
1655 static void
1656 oberon_ident_list(oberon_context_t * ctx, int class, int * num, oberon_object_t ** list)
1658 *num = 1;
1659 *list = oberon_ident_def(ctx, class);
1660 while(ctx -> token == COMMA)
1662 oberon_assert_token(ctx, COMMA);
1663 oberon_ident_def(ctx, class);
1664 *num += 1;
1668 static void
1669 oberon_var_decl(oberon_context_t * ctx)
1671 int num;
1672 oberon_object_t * list;
1673 oberon_type_t * type;
1674 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1676 oberon_ident_list(ctx, OBERON_CLASS_VAR, &num, &list);
1677 oberon_assert_token(ctx, COLON);
1678 oberon_type(ctx, &type);
1680 oberon_object_t * var = list;
1681 for(int i = 0; i < num; i++)
1683 var -> type = type;
1684 var = var -> next;
1688 static oberon_object_t *
1689 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1691 int class = OBERON_CLASS_PARAM;
1692 if(ctx -> token == VAR)
1694 oberon_read_token(ctx);
1695 class = OBERON_CLASS_VAR_PARAM;
1698 int num;
1699 oberon_object_t * list;
1700 oberon_ident_list(ctx, class, &num, &list);
1702 oberon_assert_token(ctx, COLON);
1704 oberon_type_t * type;
1705 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1706 oberon_type(ctx, &type);
1708 oberon_object_t * param = list;
1709 for(int i = 0; i < num; i++)
1711 param -> type = type;
1712 param = param -> next;
1715 *num_decl += num;
1716 return list;
1719 #define ISFPSECTION \
1720 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1722 static void
1723 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1725 oberon_assert_token(ctx, LPAREN);
1727 if(ISFPSECTION)
1729 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
1730 while(ctx -> token == SEMICOLON)
1732 oberon_assert_token(ctx, SEMICOLON);
1733 oberon_fp_section(ctx, &signature -> num_decl);
1737 oberon_assert_token(ctx, RPAREN);
1739 if(ctx -> token == COLON)
1741 oberon_assert_token(ctx, COLON);
1743 oberon_object_t * typeobj;
1744 typeobj = oberon_qualident(ctx, NULL, 1);
1745 if(typeobj -> class != OBERON_CLASS_TYPE)
1747 oberon_error(ctx, "function result is not type");
1749 signature -> base = typeobj -> type;
1753 static void
1754 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
1756 oberon_type_t * signature;
1757 signature = *type;
1758 signature -> class = OBERON_TYPE_PROCEDURE;
1759 signature -> num_decl = 0;
1760 signature -> base = ctx -> void_type;
1761 signature -> decl = NULL;
1763 if(ctx -> token == LPAREN)
1765 oberon_formal_pars(ctx, signature);
1769 static void
1770 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1772 if(a -> num_decl != b -> num_decl)
1774 oberon_error(ctx, "number parameters not matched");
1777 int num_param = a -> num_decl;
1778 oberon_object_t * param_a = a -> decl;
1779 oberon_object_t * param_b = b -> decl;
1780 for(int i = 0; i < num_param; i++)
1782 if(strcmp(param_a -> name, param_b -> name) != 0)
1784 oberon_error(ctx, "param %i name not matched", i + 1);
1787 if(param_a -> type != param_b -> type)
1789 oberon_error(ctx, "param %i type not matched", i + 1);
1792 param_a = param_a -> next;
1793 param_b = param_b -> next;
1797 static void
1798 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1800 oberon_object_t * proc = ctx -> decl -> parent;
1801 oberon_type_t * result_type = proc -> type -> base;
1803 if(result_type -> class == OBERON_TYPE_VOID)
1805 if(expr != NULL)
1807 oberon_error(ctx, "procedure has no result type");
1810 else
1812 if(expr == NULL)
1814 oberon_error(ctx, "procedure requires expression on result");
1817 oberon_autocast_to(ctx, expr, result_type);
1820 proc -> has_return = 1;
1822 oberon_generate_return(ctx, expr);
1825 static void
1826 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
1828 oberon_assert_token(ctx, SEMICOLON);
1830 ctx -> decl = proc -> scope;
1832 oberon_decl_seq(ctx);
1834 oberon_generate_begin_proc(ctx, proc);
1836 if(ctx -> token == BEGIN)
1838 oberon_assert_token(ctx, BEGIN);
1839 oberon_statement_seq(ctx);
1842 oberon_assert_token(ctx, END);
1843 char * name = oberon_assert_ident(ctx);
1844 if(strcmp(name, proc -> name) != 0)
1846 oberon_error(ctx, "procedure name not matched");
1849 if(proc -> type -> base -> class == OBERON_TYPE_VOID
1850 && proc -> has_return == 0)
1852 oberon_make_return(ctx, NULL);
1855 if(proc -> has_return == 0)
1857 oberon_error(ctx, "procedure requires return");
1860 oberon_generate_end_proc(ctx);
1861 oberon_close_scope(ctx -> decl);
1864 static void
1865 oberon_proc_decl(oberon_context_t * ctx)
1867 oberon_assert_token(ctx, PROCEDURE);
1869 int forward = 0;
1870 if(ctx -> token == UPARROW)
1872 oberon_assert_token(ctx, UPARROW);
1873 forward = 1;
1876 char * name;
1877 int export;
1878 int read_only;
1879 name = oberon_assert_ident(ctx);
1880 oberon_def(ctx, &export, &read_only);
1882 oberon_scope_t * proc_scope;
1883 proc_scope = oberon_open_scope(ctx);
1884 ctx -> decl -> local = 1;
1886 oberon_type_t * signature;
1887 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
1888 oberon_opt_formal_pars(ctx, &signature);
1890 oberon_initialize_decl(ctx);
1891 oberon_generator_init_type(ctx, signature);
1892 oberon_close_scope(ctx -> decl);
1894 oberon_object_t * proc;
1895 proc = oberon_find_object(ctx -> decl, name, 0);
1896 if(proc != NULL)
1898 if(proc -> class != OBERON_CLASS_PROC)
1900 oberon_error(ctx, "mult definition");
1903 if(forward == 0)
1905 if(proc -> linked)
1907 oberon_error(ctx, "mult procedure definition");
1911 if(proc -> export != export || proc -> read_only != read_only)
1913 oberon_error(ctx, "export type not matched");
1916 oberon_compare_signatures(ctx, proc -> type, signature);
1918 else
1920 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only);
1921 proc -> type = signature;
1922 proc -> scope = proc_scope;
1923 oberon_generator_init_proc(ctx, proc);
1926 proc -> scope -> parent = proc;
1928 if(forward == 0)
1930 proc -> linked = 1;
1931 oberon_proc_decl_body(ctx, proc);
1935 static void
1936 oberon_const_decl(oberon_context_t * ctx)
1938 oberon_item_t * value;
1939 oberon_object_t * constant;
1941 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST);
1942 oberon_assert_token(ctx, EQUAL);
1943 value = oberon_const_expr(ctx);
1944 constant -> value = value;
1947 static void
1948 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
1950 if(size -> is_item == 0)
1952 oberon_error(ctx, "requires constant");
1955 if(size -> item.mode != MODE_INTEGER)
1957 oberon_error(ctx, "requires integer constant");
1960 oberon_type_t * arr;
1961 arr = *type;
1962 arr -> class = OBERON_TYPE_ARRAY;
1963 arr -> size = size -> item.integer;
1964 arr -> base = base;
1967 static void
1968 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1970 if(ctx -> token == IDENT)
1972 int num;
1973 oberon_object_t * list;
1974 oberon_type_t * type;
1975 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1977 oberon_ident_list(ctx, OBERON_CLASS_FIELD, &num, &list);
1978 oberon_assert_token(ctx, COLON);
1979 oberon_type(ctx, &type);
1981 oberon_object_t * field = list;
1982 for(int i = 0; i < num; i++)
1984 field -> type = type;
1985 field = field -> next;
1988 rec -> num_decl += num;
1992 static void
1993 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
1995 char * name;
1996 oberon_object_t * to;
1998 to = oberon_qualident(ctx, &name, 0);
2000 //name = oberon_assert_ident(ctx);
2001 //to = oberon_find_object(ctx -> decl, name, 0);
2003 if(to != NULL)
2005 if(to -> class != OBERON_CLASS_TYPE)
2007 oberon_error(ctx, "not a type");
2010 else
2012 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, 0, 0);
2013 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2016 *type = to -> type;
2019 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2021 /*
2022 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2023 */
2025 static void
2026 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2028 if(sizes == NULL)
2030 *type = base;
2031 return;
2034 oberon_type_t * dim;
2035 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2037 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2039 oberon_make_array_type(ctx, sizes, dim, type);
2042 static void
2043 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2045 type -> class = OBERON_TYPE_ARRAY;
2046 type -> size = 0;
2047 type -> base = base;
2050 static void
2051 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2053 if(ctx -> token == IDENT)
2055 oberon_qualident_type(ctx, type);
2057 else if(ctx -> token == ARRAY)
2059 oberon_assert_token(ctx, ARRAY);
2061 int num_sizes = 0;
2062 oberon_expr_t * sizes;
2064 if(ISEXPR(ctx -> token))
2066 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2069 oberon_assert_token(ctx, OF);
2071 oberon_type_t * base;
2072 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2073 oberon_type(ctx, &base);
2075 if(num_sizes == 0)
2077 oberon_make_open_array(ctx, base, *type);
2079 else
2081 oberon_make_multiarray(ctx, sizes, base, type);
2084 else if(ctx -> token == RECORD)
2086 oberon_type_t * rec;
2087 rec = *type;
2088 rec -> class = OBERON_TYPE_RECORD;
2089 rec -> module = ctx -> mod;
2091 oberon_scope_t * record_scope;
2092 record_scope = oberon_open_scope(ctx);
2093 record_scope -> local = 1;
2094 record_scope -> parent = NULL;
2095 record_scope -> parent_type = rec;
2097 oberon_assert_token(ctx, RECORD);
2098 oberon_field_list(ctx, rec);
2099 while(ctx -> token == SEMICOLON)
2101 oberon_assert_token(ctx, SEMICOLON);
2102 oberon_field_list(ctx, rec);
2104 oberon_assert_token(ctx, END);
2106 rec -> decl = record_scope -> list -> next;
2107 oberon_close_scope(record_scope);
2109 *type = rec;
2111 else if(ctx -> token == POINTER)
2113 oberon_assert_token(ctx, POINTER);
2114 oberon_assert_token(ctx, TO);
2116 oberon_type_t * base;
2117 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2118 oberon_type(ctx, &base);
2120 oberon_type_t * ptr;
2121 ptr = *type;
2122 ptr -> class = OBERON_TYPE_POINTER;
2123 ptr -> base = base;
2125 else if(ctx -> token == PROCEDURE)
2127 oberon_open_scope(ctx);
2128 oberon_assert_token(ctx, PROCEDURE);
2129 oberon_opt_formal_pars(ctx, type);
2130 oberon_close_scope(ctx -> decl);
2132 else
2134 oberon_error(ctx, "invalid type declaration");
2138 static void
2139 oberon_type_decl(oberon_context_t * ctx)
2141 char * name;
2142 oberon_object_t * newtype;
2143 oberon_type_t * type;
2144 int export;
2145 int read_only;
2147 name = oberon_assert_ident(ctx);
2148 oberon_def(ctx, &export, &read_only);
2150 newtype = oberon_find_object(ctx -> decl, name, 0);
2151 if(newtype == NULL)
2153 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only);
2154 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2155 assert(newtype -> type);
2157 else
2159 if(newtype -> class != OBERON_CLASS_TYPE)
2161 oberon_error(ctx, "mult definition");
2164 if(newtype -> linked)
2166 oberon_error(ctx, "mult definition - already linked");
2169 newtype -> export = export;
2170 newtype -> read_only = read_only;
2173 oberon_assert_token(ctx, EQUAL);
2175 type = newtype -> type;
2176 oberon_type(ctx, &type);
2178 if(type -> class == OBERON_TYPE_VOID)
2180 oberon_error(ctx, "recursive alias declaration");
2183 newtype -> type = type;
2184 newtype -> linked = 1;
2187 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2188 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2190 static void
2191 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2193 if(type -> class != OBERON_TYPE_POINTER
2194 && type -> class != OBERON_TYPE_ARRAY)
2196 return;
2199 if(type -> recursive)
2201 oberon_error(ctx, "recursive pointer declaration");
2204 if(type -> class == OBERON_TYPE_POINTER
2205 && type -> base -> class == OBERON_TYPE_POINTER)
2207 oberon_error(ctx, "attempt to make pointer to pointer");
2210 type -> recursive = 1;
2212 oberon_prevent_recursive_pointer(ctx, type -> base);
2214 type -> recursive = 0;
2217 static void
2218 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2220 if(type -> class != OBERON_TYPE_RECORD)
2222 return;
2225 if(type -> recursive)
2227 oberon_error(ctx, "recursive record declaration");
2230 type -> recursive = 1;
2232 int num_fields = type -> num_decl;
2233 oberon_object_t * field = type -> decl;
2234 for(int i = 0; i < num_fields; i++)
2236 oberon_prevent_recursive_object(ctx, field);
2237 field = field -> next;
2240 type -> recursive = 0;
2242 static void
2243 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2245 if(type -> class != OBERON_TYPE_PROCEDURE)
2247 return;
2250 if(type -> recursive)
2252 oberon_error(ctx, "recursive procedure declaration");
2255 type -> recursive = 1;
2257 int num_fields = type -> num_decl;
2258 oberon_object_t * field = type -> decl;
2259 for(int i = 0; i < num_fields; i++)
2261 oberon_prevent_recursive_object(ctx, field);
2262 field = field -> next;
2265 type -> recursive = 0;
2268 static void
2269 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2271 if(type -> class != OBERON_TYPE_ARRAY)
2273 return;
2276 if(type -> recursive)
2278 oberon_error(ctx, "recursive array declaration");
2281 type -> recursive = 1;
2283 oberon_prevent_recursive_type(ctx, type -> base);
2285 type -> recursive = 0;
2288 static void
2289 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2291 if(type -> class == OBERON_TYPE_POINTER)
2293 oberon_prevent_recursive_pointer(ctx, type);
2295 else if(type -> class == OBERON_TYPE_RECORD)
2297 oberon_prevent_recursive_record(ctx, type);
2299 else if(type -> class == OBERON_TYPE_ARRAY)
2301 oberon_prevent_recursive_array(ctx, type);
2303 else if(type -> class == OBERON_TYPE_PROCEDURE)
2305 oberon_prevent_recursive_procedure(ctx, type);
2309 static void
2310 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2312 switch(x -> class)
2314 case OBERON_CLASS_VAR:
2315 case OBERON_CLASS_TYPE:
2316 case OBERON_CLASS_PARAM:
2317 case OBERON_CLASS_VAR_PARAM:
2318 case OBERON_CLASS_FIELD:
2319 oberon_prevent_recursive_type(ctx, x -> type);
2320 break;
2321 case OBERON_CLASS_CONST:
2322 case OBERON_CLASS_PROC:
2323 case OBERON_CLASS_MODULE:
2324 break;
2325 default:
2326 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2327 break;
2331 static void
2332 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2334 oberon_object_t * x = ctx -> decl -> list -> next;
2336 while(x)
2338 oberon_prevent_recursive_object(ctx, x);
2339 x = x -> next;
2343 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2344 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2346 static void
2347 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2349 if(type -> class != OBERON_TYPE_RECORD)
2351 return;
2354 int num_fields = type -> num_decl;
2355 oberon_object_t * field = type -> decl;
2356 for(int i = 0; i < num_fields; i++)
2358 if(field -> type -> class == OBERON_TYPE_POINTER)
2360 oberon_initialize_type(ctx, field -> type);
2363 oberon_initialize_object(ctx, field);
2364 field = field -> next;
2367 oberon_generator_init_record(ctx, type);
2370 static void
2371 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2373 if(type -> class == OBERON_TYPE_VOID)
2375 oberon_error(ctx, "undeclarated type");
2378 if(type -> initialized)
2380 return;
2383 type -> initialized = 1;
2385 if(type -> class == OBERON_TYPE_POINTER)
2387 oberon_initialize_type(ctx, type -> base);
2388 oberon_generator_init_type(ctx, type);
2390 else if(type -> class == OBERON_TYPE_ARRAY)
2392 if(type -> size != 0)
2394 if(type -> base -> class == OBERON_TYPE_ARRAY)
2396 if(type -> base -> size == 0)
2398 oberon_error(ctx, "open array not allowed as array element");
2403 oberon_initialize_type(ctx, type -> base);
2404 oberon_generator_init_type(ctx, type);
2406 else if(type -> class == OBERON_TYPE_RECORD)
2408 oberon_generator_init_type(ctx, type);
2409 oberon_initialize_record_fields(ctx, type);
2411 else if(type -> class == OBERON_TYPE_PROCEDURE)
2413 int num_fields = type -> num_decl;
2414 oberon_object_t * field = type -> decl;
2415 for(int i = 0; i < num_fields; i++)
2417 oberon_initialize_object(ctx, field);
2418 field = field -> next;
2419 }
2421 oberon_generator_init_type(ctx, type);
2423 else
2425 oberon_generator_init_type(ctx, type);
2429 static void
2430 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2432 if(x -> initialized)
2434 return;
2437 x -> initialized = 1;
2439 switch(x -> class)
2441 case OBERON_CLASS_TYPE:
2442 oberon_initialize_type(ctx, x -> type);
2443 break;
2444 case OBERON_CLASS_VAR:
2445 case OBERON_CLASS_FIELD:
2446 if(x -> type -> class == OBERON_TYPE_ARRAY)
2448 if(x -> type -> size == 0)
2450 oberon_error(ctx, "open array not allowed as variable or field");
2453 oberon_initialize_type(ctx, x -> type);
2454 oberon_generator_init_var(ctx, x);
2455 break;
2456 case OBERON_CLASS_PARAM:
2457 case OBERON_CLASS_VAR_PARAM:
2458 oberon_initialize_type(ctx, x -> type);
2459 oberon_generator_init_var(ctx, x);
2460 break;
2461 case OBERON_CLASS_CONST:
2462 case OBERON_CLASS_PROC:
2463 case OBERON_CLASS_MODULE:
2464 break;
2465 default:
2466 oberon_error(ctx, "oberon_initialize_object: wat");
2467 break;
2471 static void
2472 oberon_initialize_decl(oberon_context_t * ctx)
2474 oberon_object_t * x = ctx -> decl -> list;
2476 while(x -> next)
2478 oberon_initialize_object(ctx, x -> next);
2479 x = x -> next;
2480 }
2483 static void
2484 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2486 oberon_object_t * x = ctx -> decl -> list;
2488 while(x -> next)
2490 if(x -> next -> class == OBERON_CLASS_PROC)
2492 if(x -> next -> linked == 0)
2494 oberon_error(ctx, "unresolved forward declaration");
2497 x = x -> next;
2498 }
2501 static void
2502 oberon_decl_seq(oberon_context_t * ctx)
2504 if(ctx -> token == CONST)
2506 oberon_assert_token(ctx, CONST);
2507 while(ctx -> token == IDENT)
2509 oberon_const_decl(ctx);
2510 oberon_assert_token(ctx, SEMICOLON);
2514 if(ctx -> token == TYPE)
2516 oberon_assert_token(ctx, TYPE);
2517 while(ctx -> token == IDENT)
2519 oberon_type_decl(ctx);
2520 oberon_assert_token(ctx, SEMICOLON);
2524 if(ctx -> token == VAR)
2526 oberon_assert_token(ctx, VAR);
2527 while(ctx -> token == IDENT)
2529 oberon_var_decl(ctx);
2530 oberon_assert_token(ctx, SEMICOLON);
2534 oberon_prevent_recursive_decl(ctx);
2535 oberon_initialize_decl(ctx);
2537 while(ctx -> token == PROCEDURE)
2539 oberon_proc_decl(ctx);
2540 oberon_assert_token(ctx, SEMICOLON);
2543 oberon_prevent_undeclarated_procedures(ctx);
2546 static void
2547 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2549 if(dst -> read_only)
2551 oberon_error(ctx, "read-only destination");
2554 oberon_autocast_to(ctx, src, dst -> result);
2555 oberon_generate_assign(ctx, src, dst);
2558 static void
2559 oberon_statement(oberon_context_t * ctx)
2561 oberon_expr_t * item1;
2562 oberon_expr_t * item2;
2564 if(ctx -> token == IDENT)
2566 item1 = oberon_designator(ctx);
2567 if(ctx -> token == ASSIGN)
2569 oberon_assert_token(ctx, ASSIGN);
2570 item2 = oberon_expr(ctx);
2571 oberon_assign(ctx, item2, item1);
2573 else
2575 oberon_opt_proc_parens(ctx, item1);
2578 else if(ctx -> token == RETURN)
2580 oberon_assert_token(ctx, RETURN);
2581 if(ISEXPR(ctx -> token))
2583 oberon_expr_t * expr;
2584 expr = oberon_expr(ctx);
2585 oberon_make_return(ctx, expr);
2587 else
2589 oberon_make_return(ctx, NULL);
2594 static void
2595 oberon_statement_seq(oberon_context_t * ctx)
2597 oberon_statement(ctx);
2598 while(ctx -> token == SEMICOLON)
2600 oberon_assert_token(ctx, SEMICOLON);
2601 oberon_statement(ctx);
2605 static void
2606 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
2608 oberon_module_t * m = ctx -> module_list;
2609 while(m && strcmp(m -> name, name) != 0)
2611 m = m -> next;
2614 if(m == NULL)
2616 const char * code;
2617 code = ctx -> import_module(name);
2618 if(code == NULL)
2620 oberon_error(ctx, "no such module");
2623 m = oberon_compile_module(ctx, code);
2624 assert(m);
2627 if(m -> ready == 0)
2629 oberon_error(ctx, "cyclic module import");
2632 oberon_object_t * ident;
2633 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, 0, 0);
2634 ident -> module = m;
2637 static void
2638 oberon_import_decl(oberon_context_t * ctx)
2640 char * alias;
2641 char * name;
2643 alias = name = oberon_assert_ident(ctx);
2644 if(ctx -> token == ASSIGN)
2646 oberon_assert_token(ctx, ASSIGN);
2647 name = oberon_assert_ident(ctx);
2650 oberon_import_module(ctx, alias, name);
2653 static void
2654 oberon_import_list(oberon_context_t * ctx)
2656 oberon_assert_token(ctx, IMPORT);
2658 oberon_import_decl(ctx);
2659 while(ctx -> token == COMMA)
2661 oberon_assert_token(ctx, COMMA);
2662 oberon_import_decl(ctx);
2665 oberon_assert_token(ctx, SEMICOLON);
2668 static void
2669 oberon_parse_module(oberon_context_t * ctx)
2671 char * name1;
2672 char * name2;
2673 oberon_read_token(ctx);
2675 oberon_assert_token(ctx, MODULE);
2676 name1 = oberon_assert_ident(ctx);
2677 oberon_assert_token(ctx, SEMICOLON);
2678 ctx -> mod -> name = name1;
2680 oberon_generator_init_module(ctx, ctx -> mod);
2682 if(ctx -> token == IMPORT)
2684 oberon_import_list(ctx);
2687 oberon_decl_seq(ctx);
2689 oberon_generate_begin_module(ctx);
2690 if(ctx -> token == BEGIN)
2692 oberon_assert_token(ctx, BEGIN);
2693 oberon_statement_seq(ctx);
2695 oberon_generate_end_module(ctx);
2697 oberon_assert_token(ctx, END);
2698 name2 = oberon_assert_ident(ctx);
2699 oberon_assert_token(ctx, DOT);
2701 if(strcmp(name1, name2) != 0)
2703 oberon_error(ctx, "module name not matched");
2706 oberon_generator_fini_module(ctx -> mod);
2709 // =======================================================================
2710 // LIBRARY
2711 // =======================================================================
2713 static void
2714 register_default_types(oberon_context_t * ctx)
2716 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2717 oberon_generator_init_type(ctx, ctx -> void_type);
2719 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
2720 ctx -> void_ptr_type -> base = ctx -> void_type;
2721 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
2723 ctx -> int_type = oberon_new_type_integer(sizeof(int));
2724 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
2726 ctx -> bool_type = oberon_new_type_boolean(sizeof(bool));
2727 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
2729 ctx -> real_type = oberon_new_type_real(sizeof(float));
2730 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
2733 static void
2734 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
2736 oberon_object_t * proc;
2737 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, 1, 0);
2738 proc -> sysproc = 1;
2739 proc -> genfunc = f;
2740 proc -> genproc = p;
2741 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
2744 static oberon_expr_t *
2745 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2747 if(num_args < 1)
2749 oberon_error(ctx, "too few arguments");
2752 if(num_args > 1)
2754 oberon_error(ctx, "too mach arguments");
2757 oberon_expr_t * arg;
2758 arg = list_args;
2760 oberon_type_t * result_type;
2761 result_type = arg -> result;
2763 if(result_type -> class != OBERON_TYPE_INTEGER)
2765 oberon_error(ctx, "ABS accepts only integers");
2769 oberon_expr_t * expr;
2770 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
2771 return expr;
2774 static void
2775 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2777 if(num_args < 1)
2779 oberon_error(ctx, "too few arguments");
2782 oberon_expr_t * dst;
2783 dst = list_args;
2785 oberon_type_t * type;
2786 type = dst -> result;
2788 if(type -> class != OBERON_TYPE_POINTER)
2790 oberon_error(ctx, "not a pointer");
2793 type = type -> base;
2795 oberon_expr_t * src;
2796 src = oberon_new_item(MODE_NEW, dst -> result, 0);
2797 src -> item.num_args = 0;
2798 src -> item.args = NULL;
2800 int max_args = 1;
2801 if(type -> class == OBERON_TYPE_ARRAY)
2803 if(type -> size == 0)
2805 oberon_type_t * x = type;
2806 while(x -> class == OBERON_TYPE_ARRAY)
2808 if(x -> size == 0)
2810 max_args += 1;
2812 x = x -> base;
2816 if(num_args < max_args)
2818 oberon_error(ctx, "too few arguments");
2821 if(num_args > max_args)
2823 oberon_error(ctx, "too mach arguments");
2826 int num_sizes = max_args - 1;
2827 oberon_expr_t * size_list = list_args -> next;
2829 oberon_expr_t * arg = size_list;
2830 for(int i = 0; i < max_args - 1; i++)
2832 if(arg -> result -> class != OBERON_TYPE_INTEGER)
2834 oberon_error(ctx, "size must be integer");
2836 arg = arg -> next;
2839 src -> item.num_args = num_sizes;
2840 src -> item.args = size_list;
2842 else if(type -> class != OBERON_TYPE_RECORD)
2844 oberon_error(ctx, "oberon_make_new_call: wat");
2847 if(num_args > max_args)
2849 oberon_error(ctx, "too mach arguments");
2852 oberon_assign(ctx, src, dst);
2855 oberon_context_t *
2856 oberon_create_context(ModuleImportCallback import_module)
2858 oberon_context_t * ctx = calloc(1, sizeof *ctx);
2860 oberon_scope_t * world_scope;
2861 world_scope = oberon_open_scope(ctx);
2862 ctx -> world_scope = world_scope;
2864 ctx -> import_module = import_module;
2866 oberon_generator_init_context(ctx);
2868 register_default_types(ctx);
2869 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
2870 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
2872 return ctx;
2875 void
2876 oberon_destroy_context(oberon_context_t * ctx)
2878 oberon_generator_destroy_context(ctx);
2879 free(ctx);
2882 oberon_module_t *
2883 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
2885 const char * code = ctx -> code;
2886 int code_index = ctx -> code_index;
2887 char c = ctx -> c;
2888 int token = ctx -> token;
2889 char * string = ctx -> string;
2890 int integer = ctx -> integer;
2891 oberon_scope_t * decl = ctx -> decl;
2892 oberon_module_t * mod = ctx -> mod;
2894 oberon_scope_t * module_scope;
2895 module_scope = oberon_open_scope(ctx);
2897 oberon_module_t * module;
2898 module = calloc(1, sizeof *module);
2899 module -> decl = module_scope;
2900 module -> next = ctx -> module_list;
2902 ctx -> mod = module;
2903 ctx -> module_list = module;
2905 oberon_init_scaner(ctx, newcode);
2906 oberon_parse_module(ctx);
2908 module -> ready = 1;
2910 ctx -> code = code;
2911 ctx -> code_index = code_index;
2912 ctx -> c = c;
2913 ctx -> token = token;
2914 ctx -> string = string;
2915 ctx -> integer = integer;
2916 ctx -> decl = decl;
2917 ctx -> mod = mod;
2919 return module;