DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / dsw-obn.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
JVM: Исправлено сравнение LongInt, Real и LongReal
[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>
8
9 #include "../include/oberon.h"
10
11 #include "oberon-internals.h"
12 #include "generator.h"
13
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 IN,
37 IS,
38 PLUS,
39 MINUS,
40 OR,
41 STAR,
42 SLASH,
43 DIV,
44 MOD,
45 AND,
46 NOT,
47 PROCEDURE,
48 COMMA,
49 RETURN,
50 CONST,
51 TYPE,
52 ARRAY,
53 OF,
54 LBRACE,
55 RBRACE,
56 RECORD,
57 POINTER,
58 TO,
59 UPARROW,
60 NIL,
61 IMPORT,
62 REAL,
63 CHAR,
64 STRING,
65 IF,
66 THEN,
67 ELSE
68 };
69
70 // =======================================================================
71 // UTILS
72 // =======================================================================
73
74 static void
75 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
76 {
77 va_list ptr;
78 va_start(ptr, fmt);
79 fprintf(stderr, "error: ");
80 vfprintf(stderr, fmt, ptr);
81 fprintf(stderr, "\n");
82 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
83 fprintf(stderr, " c = %c\n", ctx -> c);
84 fprintf(stderr, " token = %i\n", ctx -> token);
85 va_end(ptr);
86 exit(1);
87 }
88
89 static oberon_type_t *
90 oberon_new_type_ptr(int class)
91 {
92 oberon_type_t * x = malloc(sizeof *x);
93 memset(x, 0, sizeof *x);
94 x -> class = class;
95 return x;
96 }
97
98 static oberon_type_t *
99 oberon_new_type_integer(int size)
100 {
101 oberon_type_t * x;
102 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
103 x -> size = size;
104 return x;
105 }
106
107 static oberon_type_t *
108 oberon_new_type_boolean()
109 {
110 oberon_type_t * x;
111 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
112 return x;
113 }
114
115 static oberon_type_t *
116 oberon_new_type_real(int size)
117 {
118 oberon_type_t * x;
119 x = oberon_new_type_ptr(OBERON_TYPE_REAL);
120 x -> size = size;
121 return x;
122 }
123
124 static oberon_type_t *
125 oberon_new_type_char(int size)
126 {
127 oberon_type_t * x;
128 x = oberon_new_type_ptr(OBERON_TYPE_CHAR);
129 x -> size = size;
130 return x;
131 }
132
133 static oberon_type_t *
134 oberon_new_type_string(int size)
135 {
136 oberon_type_t * x;
137 x = oberon_new_type_ptr(OBERON_TYPE_STRING);
138 x -> size = size;
139 return x;
140 }
141
142 // =======================================================================
143 // TABLE
144 // =======================================================================
145
146 static oberon_scope_t *
147 oberon_open_scope(oberon_context_t * ctx)
148 {
149 oberon_scope_t * scope = calloc(1, sizeof *scope);
150 oberon_object_t * list = calloc(1, sizeof *list);
151
152 scope -> ctx = ctx;
153 scope -> list = list;
154 scope -> up = ctx -> decl;
155
156 if(scope -> up)
157 {
158 scope -> local = scope -> up -> local;
159 scope -> parent = scope -> up -> parent;
160 scope -> parent_type = scope -> up -> parent_type;
161 }
162
163 ctx -> decl = scope;
164 return scope;
165 }
166
167 static void
168 oberon_close_scope(oberon_scope_t * scope)
169 {
170 oberon_context_t * ctx = scope -> ctx;
171 ctx -> decl = scope -> up;
172 }
173
174 static oberon_object_t *
175 oberon_find_object_in_list(oberon_object_t * list, char * name)
176 {
177 oberon_object_t * x = list;
178 while(x -> next && strcmp(x -> next -> name, name) != 0)
179 {
180 x = x -> next;
181 }
182 return x -> next;
183 }
184
185 static oberon_object_t *
186 oberon_find_object(oberon_scope_t * scope, char * name, bool check_it)
187 {
188 oberon_object_t * result = NULL;
189
190 oberon_scope_t * s = scope;
191 while(result == NULL && s != NULL)
192 {
193 result = oberon_find_object_in_list(s -> list, name);
194 s = s -> up;
195 }
196
197 if(check_it && result == NULL)
198 {
199 oberon_error(scope -> ctx, "undefined ident %s", name);
200 }
201
202 return result;
203 }
204
205 static oberon_object_t *
206 oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only, bool check_upscope)
207 {
208 if(check_upscope)
209 {
210 if(oberon_find_object(scope -> up, name, false))
211 {
212 oberon_error(scope -> ctx, "already defined");
213 }
214 }
215
216 oberon_object_t * x = scope -> list;
217 while(x -> next && strcmp(x -> next -> name, name) != 0)
218 {
219 x = x -> next;
220 }
221
222 if(x -> next)
223 {
224 oberon_error(scope -> ctx, "already defined");
225 }
226
227 oberon_object_t * newvar = malloc(sizeof *newvar);
228 memset(newvar, 0, sizeof *newvar);
229 newvar -> name = name;
230 newvar -> class = class;
231 newvar -> export = export;
232 newvar -> read_only = read_only;
233 newvar -> local = scope -> local;
234 newvar -> parent = scope -> parent;
235 newvar -> parent_type = scope -> parent_type;
236 newvar -> module = scope -> ctx -> mod;
237
238 x -> next = newvar;
239
240 return newvar;
241 }
242
243 static oberon_object_t *
244 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export)
245 {
246 oberon_object_t * id;
247 id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, false, false);
248 id -> type = type;
249 oberon_generator_init_type(scope -> ctx, type);
250 return id;
251 }
252
253 // =======================================================================
254 // SCANER
255 // =======================================================================
256
257 static void
258 oberon_get_char(oberon_context_t * ctx)
259 {
260 if(ctx -> code[ctx -> code_index])
261 {
262 ctx -> code_index += 1;
263 ctx -> c = ctx -> code[ctx -> code_index];
264 }
265 }
266
267 static void
268 oberon_init_scaner(oberon_context_t * ctx, const char * code)
269 {
270 ctx -> code = code;
271 ctx -> code_index = 0;
272 ctx -> c = ctx -> code[ctx -> code_index];
273 }
274
275 static void
276 oberon_read_ident(oberon_context_t * ctx)
277 {
278 int len = 0;
279 int i = ctx -> code_index;
280
281 int c = ctx -> code[i];
282 while(isalnum(c))
283 {
284 i += 1;
285 len += 1;
286 c = ctx -> code[i];
287 }
288
289 char * ident = malloc(len + 1);
290 memcpy(ident, &ctx->code[ctx->code_index], len);
291 ident[len] = 0;
292
293 ctx -> code_index = i;
294 ctx -> c = ctx -> code[i];
295 ctx -> string = ident;
296 ctx -> token = IDENT;
297
298 if(strcmp(ident, "MODULE") == 0)
299 {
300 ctx -> token = MODULE;
301 }
302 else if(strcmp(ident, "END") == 0)
303 {
304 ctx -> token = END;
305 }
306 else if(strcmp(ident, "VAR") == 0)
307 {
308 ctx -> token = VAR;
309 }
310 else if(strcmp(ident, "BEGIN") == 0)
311 {
312 ctx -> token = BEGIN;
313 }
314 else if(strcmp(ident, "TRUE") == 0)
315 {
316 ctx -> token = TRUE;
317 }
318 else if(strcmp(ident, "FALSE") == 0)
319 {
320 ctx -> token = FALSE;
321 }
322 else if(strcmp(ident, "OR") == 0)
323 {
324 ctx -> token = OR;
325 }
326 else if(strcmp(ident, "DIV") == 0)
327 {
328 ctx -> token = DIV;
329 }
330 else if(strcmp(ident, "MOD") == 0)
331 {
332 ctx -> token = MOD;
333 }
334 else if(strcmp(ident, "PROCEDURE") == 0)
335 {
336 ctx -> token = PROCEDURE;
337 }
338 else if(strcmp(ident, "RETURN") == 0)
339 {
340 ctx -> token = RETURN;
341 }
342 else if(strcmp(ident, "CONST") == 0)
343 {
344 ctx -> token = CONST;
345 }
346 else if(strcmp(ident, "TYPE") == 0)
347 {
348 ctx -> token = TYPE;
349 }
350 else if(strcmp(ident, "ARRAY") == 0)
351 {
352 ctx -> token = ARRAY;
353 }
354 else if(strcmp(ident, "OF") == 0)
355 {
356 ctx -> token = OF;
357 }
358 else if(strcmp(ident, "RECORD") == 0)
359 {
360 ctx -> token = RECORD;
361 }
362 else if(strcmp(ident, "POINTER") == 0)
363 {
364 ctx -> token = POINTER;
365 }
366 else if(strcmp(ident, "TO") == 0)
367 {
368 ctx -> token = TO;
369 }
370 else if(strcmp(ident, "NIL") == 0)
371 {
372 ctx -> token = NIL;
373 }
374 else if(strcmp(ident, "IMPORT") == 0)
375 {
376 ctx -> token = IMPORT;
377 }
378 else if(strcmp(ident, "IN") == 0)
379 {
380 ctx -> token = IN;
381 }
382 else if(strcmp(ident, "IS") == 0)
383 {
384 ctx -> token = IS;
385 }
386 else if(strcmp(ident, "IF") == 0)
387 {
388 ctx -> token = IF;
389 }
390 else if(strcmp(ident, "THEN") == 0)
391 {
392 ctx -> token = THEN;
393 }
394 else if(strcmp(ident, "ELSE") == 0)
395 {
396 ctx -> token = ELSE;
397 }
398 }
399
400 static void
401 oberon_read_number(oberon_context_t * ctx)
402 {
403 long integer;
404 double real;
405 char * ident;
406 int start_i;
407 int exp_i;
408 int end_i;
409
410 /*
411 * mode = 0 == DEC
412 * mode = 1 == HEX
413 * mode = 2 == REAL
414 * mode = 3 == LONGREAL
415 * mode = 4 == CHAR
416 */
417 int mode = 0;
418 start_i = ctx -> code_index;
419
420 while(isdigit(ctx -> c))
421 {
422 oberon_get_char(ctx);
423 }
424
425 end_i = ctx -> code_index;
426
427 if(isxdigit(ctx -> c))
428 {
429 mode = 1;
430 while(isxdigit(ctx -> c))
431 {
432 oberon_get_char(ctx);
433 }
434
435 end_i = ctx -> code_index;
436
437 if(ctx -> c == 'H')
438 {
439 mode = 1;
440 oberon_get_char(ctx);
441 }
442 else if(ctx -> c == 'X')
443 {
444 mode = 4;
445 oberon_get_char(ctx);
446 }
447 else
448 {
449 oberon_error(ctx, "invalid hex number");
450 }
451 }
452 else if(ctx -> c == '.')
453 {
454 mode = 2;
455 oberon_get_char(ctx);
456
457 while(isdigit(ctx -> c))
458 {
459 oberon_get_char(ctx);
460 }
461
462 if(ctx -> c == 'E' || ctx -> c == 'D')
463 {
464 exp_i = ctx -> code_index;
465
466 if(ctx -> c == 'D')
467 {
468 mode = 3;
469 }
470
471 oberon_get_char(ctx);
472
473 if(ctx -> c == '+' || ctx -> c == '-')
474 {
475 oberon_get_char(ctx);
476 }
477
478 while(isdigit(ctx -> c))
479 {
480 oberon_get_char(ctx);
481 }
482
483 }
484
485 end_i = ctx -> code_index;
486 }
487
488 if(mode == 0)
489 {
490 if(ctx -> c == 'H')
491 {
492 mode = 1;
493 oberon_get_char(ctx);
494 }
495 else if(ctx -> c == 'X')
496 {
497 mode = 4;
498 oberon_get_char(ctx);
499 }
500 }
501
502 int len = end_i - start_i;
503 ident = malloc(len + 1);
504 memcpy(ident, &ctx -> code[start_i], len);
505 ident[len] = 0;
506
507 ctx -> longmode = false;
508 if(mode == 3)
509 {
510 int i = exp_i - start_i;
511 ident[i] = 'E';
512 ctx -> longmode = true;
513 }
514
515 switch(mode)
516 {
517 case 0:
518 integer = atol(ident);
519 real = integer;
520 ctx -> token = INTEGER;
521 break;
522 case 1:
523 sscanf(ident, "%lx", &integer);
524 real = integer;
525 ctx -> token = INTEGER;
526 break;
527 case 2:
528 case 3:
529 sscanf(ident, "%lf", &real);
530 ctx -> token = REAL;
531 break;
532 case 4:
533 sscanf(ident, "%lx", &integer);
534 real = integer;
535 ctx -> token = CHAR;
536 break;
537 default:
538 oberon_error(ctx, "oberon_read_number: wat");
539 break;
540 }
541
542 ctx -> string = ident;
543 ctx -> integer = integer;
544 ctx -> real = real;
545 }
546
547 static void
548 oberon_skip_space(oberon_context_t * ctx)
549 {
550 while(isspace(ctx -> c))
551 {
552 oberon_get_char(ctx);
553 }
554 }
555
556 static void
557 oberon_read_comment(oberon_context_t * ctx)
558 {
559 int nesting = 1;
560 while(nesting >= 1)
561 {
562 if(ctx -> c == '(')
563 {
564 oberon_get_char(ctx);
565 if(ctx -> c == '*')
566 {
567 oberon_get_char(ctx);
568 nesting += 1;
569 }
570 }
571 else if(ctx -> c == '*')
572 {
573 oberon_get_char(ctx);
574 if(ctx -> c == ')')
575 {
576 oberon_get_char(ctx);
577 nesting -= 1;
578 }
579 }
580 else if(ctx -> c == 0)
581 {
582 oberon_error(ctx, "unterminated comment");
583 }
584 else
585 {
586 oberon_get_char(ctx);
587 }
588 }
589 }
590
591 static void oberon_read_string(oberon_context_t * ctx)
592 {
593 int c = ctx -> c;
594 oberon_get_char(ctx);
595
596 int start = ctx -> code_index;
597
598 while(ctx -> c != 0 && ctx -> c != c)
599 {
600 oberon_get_char(ctx);
601 }
602
603 if(ctx -> c == 0)
604 {
605 oberon_error(ctx, "unterminated string");
606 }
607
608 int end = ctx -> code_index;
609
610 oberon_get_char(ctx);
611
612 char * string = calloc(1, end - start + 1);
613 strncpy(string, &ctx -> code[start], end - start);
614
615 ctx -> token = STRING;
616 ctx -> string = string;
617
618 printf("oberon_read_string: string ((%s))\n", string);
619 }
620
621 static void oberon_read_token(oberon_context_t * ctx);
622
623 static void
624 oberon_read_symbol(oberon_context_t * ctx)
625 {
626 int c = ctx -> c;
627 switch(c)
628 {
629 case 0:
630 ctx -> token = EOF_;
631 break;
632 case ';':
633 ctx -> token = SEMICOLON;
634 oberon_get_char(ctx);
635 break;
636 case ':':
637 ctx -> token = COLON;
638 oberon_get_char(ctx);
639 if(ctx -> c == '=')
640 {
641 ctx -> token = ASSIGN;
642 oberon_get_char(ctx);
643 }
644 break;
645 case '.':
646 ctx -> token = DOT;
647 oberon_get_char(ctx);
648 break;
649 case '(':
650 ctx -> token = LPAREN;
651 oberon_get_char(ctx);
652 if(ctx -> c == '*')
653 {
654 oberon_get_char(ctx);
655 oberon_read_comment(ctx);
656 oberon_read_token(ctx);
657 }
658 break;
659 case ')':
660 ctx -> token = RPAREN;
661 oberon_get_char(ctx);
662 break;
663 case '=':
664 ctx -> token = EQUAL;
665 oberon_get_char(ctx);
666 break;
667 case '#':
668 ctx -> token = NEQ;
669 oberon_get_char(ctx);
670 break;
671 case '<':
672 ctx -> token = LESS;
673 oberon_get_char(ctx);
674 if(ctx -> c == '=')
675 {
676 ctx -> token = LEQ;
677 oberon_get_char(ctx);
678 }
679 break;
680 case '>':
681 ctx -> token = GREAT;
682 oberon_get_char(ctx);
683 if(ctx -> c == '=')
684 {
685 ctx -> token = GEQ;
686 oberon_get_char(ctx);
687 }
688 break;
689 case '+':
690 ctx -> token = PLUS;
691 oberon_get_char(ctx);
692 break;
693 case '-':
694 ctx -> token = MINUS;
695 oberon_get_char(ctx);
696 break;
697 case '*':
698 ctx -> token = STAR;
699 oberon_get_char(ctx);
700 if(ctx -> c == ')')
701 {
702 oberon_get_char(ctx);
703 oberon_error(ctx, "unstarted comment");
704 }
705 break;
706 case '/':
707 ctx -> token = SLASH;
708 oberon_get_char(ctx);
709 break;
710 case '&':
711 ctx -> token = AND;
712 oberon_get_char(ctx);
713 break;
714 case '~':
715 ctx -> token = NOT;
716 oberon_get_char(ctx);
717 break;
718 case ',':
719 ctx -> token = COMMA;
720 oberon_get_char(ctx);
721 break;
722 case '[':
723 ctx -> token = LBRACE;
724 oberon_get_char(ctx);
725 break;
726 case ']':
727 ctx -> token = RBRACE;
728 oberon_get_char(ctx);
729 break;
730 case '^':
731 ctx -> token = UPARROW;
732 oberon_get_char(ctx);
733 break;
734 case '"':
735 oberon_read_string(ctx);
736 break;
737 case '\'':
738 oberon_read_string(ctx);
739 break;
740 default:
741 oberon_error(ctx, "invalid char %c", ctx -> c);
742 break;
743 }
744 }
745
746 static void
747 oberon_read_token(oberon_context_t * ctx)
748 {
749 oberon_skip_space(ctx);
750
751 int c = ctx -> c;
752 if(isalpha(c))
753 {
754 oberon_read_ident(ctx);
755 }
756 else if(isdigit(c))
757 {
758 oberon_read_number(ctx);
759 }
760 else
761 {
762 oberon_read_symbol(ctx);
763 }
764 }
765
766 // =======================================================================
767 // EXPRESSION
768 // =======================================================================
769
770 static void oberon_expect_token(oberon_context_t * ctx, int token);
771 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
772 static void oberon_assert_token(oberon_context_t * ctx, int token);
773 static char * oberon_assert_ident(oberon_context_t * ctx);
774 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
775 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
776 static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr);
777
778 static oberon_expr_t *
779 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
780 {
781 oberon_oper_t * operator;
782 operator = malloc(sizeof *operator);
783 memset(operator, 0, sizeof *operator);
784
785 operator -> is_item = 0;
786 operator -> result = result;
787 operator -> read_only = 1;
788 operator -> op = op;
789 operator -> left = left;
790 operator -> right = right;
791
792 return (oberon_expr_t *) operator;
793 }
794
795 static oberon_expr_t *
796 oberon_new_item(int mode, oberon_type_t * result, int read_only)
797 {
798 oberon_item_t * item;
799 item = malloc(sizeof *item);
800 memset(item, 0, sizeof *item);
801
802 item -> is_item = 1;
803 item -> result = result;
804 item -> read_only = read_only;
805 item -> mode = mode;
806
807 return (oberon_expr_t *)item;
808 }
809
810 static oberon_expr_t *
811 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
812 {
813 oberon_expr_t * expr;
814 oberon_type_t * result;
815
816 result = a -> result;
817
818 if(token == MINUS)
819 {
820 if(result -> class != OBERON_TYPE_INTEGER)
821 {
822 oberon_error(ctx, "incompatible operator type");
823 }
824
825 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
826 }
827 else if(token == NOT)
828 {
829 if(result -> class != OBERON_TYPE_BOOLEAN)
830 {
831 oberon_error(ctx, "incompatible operator type");
832 }
833
834 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
835 }
836 else
837 {
838 oberon_error(ctx, "oberon_make_unary_op: wat");
839 }
840
841 return expr;
842 }
843
844 static void
845 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
846 {
847 oberon_expr_t * last;
848
849 *num_expr = 1;
850 if(const_expr)
851 {
852 *first = last = (oberon_expr_t *) oberon_const_expr(ctx);
853 }
854 else
855 {
856 *first = last = oberon_expr(ctx);
857 }
858 while(ctx -> token == COMMA)
859 {
860 oberon_assert_token(ctx, COMMA);
861 oberon_expr_t * current;
862
863 if(const_expr)
864 {
865 current = (oberon_expr_t *) oberon_const_expr(ctx);
866 }
867 else
868 {
869 current = oberon_expr(ctx);
870 }
871
872 last -> next = current;
873 last = current;
874 *num_expr += 1;
875 }
876 }
877
878 static oberon_expr_t *
879 oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
880 {
881 return oberon_new_operator(OP_CAST, pref, expr, NULL);
882 }
883
884 static oberon_expr_t *
885 oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec)
886 {
887 oberon_type_t * from = expr -> result;
888 oberon_type_t * to = rec;
889
890 printf("oberno_make_record_cast: from class %i to class %i\n", from -> class, to -> class);
891
892 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
893 {
894 printf("oberno_make_record_cast: pointers\n");
895 from = from -> base;
896 to = to -> base;
897 }
898
899 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
900 {
901 oberon_error(ctx, "must be record type");
902 }
903
904 return oberon_cast_expr(ctx, expr, rec);
905 }
906
907 static oberon_type_t *
908 oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
909 {
910 oberon_type_t * result;
911 if(a -> class == OBERON_TYPE_REAL && b -> class == OBERON_TYPE_INTEGER)
912 {
913 result = a;
914 }
915 else if(b -> class == OBERON_TYPE_REAL && a -> class == OBERON_TYPE_INTEGER)
916 {
917 result = b;
918 }
919 else if(a -> class != b -> class)
920 {
921 oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types");
922 }
923 else if(a -> size > b -> size)
924 {
925 result = a;
926 }
927 else
928 {
929 result = b;
930 }
931
932 return result;
933 }
934
935 static void
936 oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to)
937 {
938 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
939 {
940 from = from -> base;
941 to = to -> base;
942 }
943
944 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
945 {
946 oberon_error(ctx, "not a record");
947 }
948
949 oberon_type_t * t = from;
950 while(t != NULL && t != to)
951 {
952 t = t -> base;
953 }
954
955 if(t == NULL)
956 {
957 oberon_error(ctx, "incompatible record types");
958 }
959 }
960
961 static oberon_expr_t *
962 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
963 {
964 // Допускается:
965 // Если классы типов равны
966 // Если INTEGER переводится в REAL
967 // Есди STRING переводится в ARRAY OF CHAR
968
969 bool error = false;
970 if(pref -> class != expr -> result -> class)
971 {
972 printf("expr class %i\n", expr -> result -> class);
973 printf("pref class %i\n", pref -> class);
974
975 if(expr -> result -> class == OBERON_TYPE_STRING)
976 {
977 if(pref -> class == OBERON_TYPE_ARRAY)
978 {
979 if(pref -> base -> class != OBERON_TYPE_CHAR)
980 {
981 error = true;
982 }
983 }
984 else
985 {
986 error = true;
987 }
988 }
989 else if(expr -> result -> class == OBERON_TYPE_INTEGER)
990 {
991 if(pref -> class != OBERON_TYPE_REAL)
992 {
993 error = true;
994 }
995 }
996 else
997 {
998 error = true;
999 }
1000 }
1001
1002 if(error)
1003 {
1004 oberon_error(ctx, "oberon_autocast_to: incompatible types");
1005 }
1006
1007 if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL)
1008 {
1009 if(expr -> result -> size > pref -> size)
1010 {
1011 oberon_error(ctx, "incompatible size");
1012 }
1013 else
1014 {
1015 expr = oberon_cast_expr(ctx, expr, pref);
1016 }
1017 }
1018 else if(pref -> class == OBERON_TYPE_RECORD)
1019 {
1020 oberon_check_record_compatibility(ctx, expr -> result, pref);
1021 expr = oberno_make_record_cast(ctx, expr, pref);
1022 }
1023 else if(pref -> class == OBERON_TYPE_POINTER)
1024 {
1025 assert(pref -> base);
1026 if(expr -> result -> base -> class == OBERON_TYPE_RECORD)
1027 {
1028 oberon_check_record_compatibility(ctx, expr -> result, pref);
1029 expr = oberno_make_record_cast(ctx, expr, pref);
1030 }
1031 else if(expr -> result -> base != pref -> base)
1032 {
1033 if(expr -> result -> base -> class != OBERON_TYPE_VOID)
1034 {
1035 oberon_error(ctx, "incompatible pointer types");
1036 }
1037 }
1038 }
1039
1040 return expr;
1041 }
1042
1043 static void
1044 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb)
1045 {
1046 oberon_type_t * a = (*ea) -> result;
1047 oberon_type_t * b = (*eb) -> result;
1048 oberon_type_t * preq = oberon_get_equal_expr_type(ctx, a, b);
1049 *ea = oberon_autocast_to(ctx, *ea, preq);
1050 *eb = oberon_autocast_to(ctx, *eb, preq);
1051 }
1052
1053 static void
1054 oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig)
1055 {
1056 if(desig -> mode != MODE_CALL)
1057 {
1058 oberon_error(ctx, "expected mode CALL");
1059 }
1060
1061 oberon_type_t * fn = desig -> parent -> result;
1062 int num_args = desig -> num_args;
1063 int num_decl = fn -> num_decl;
1064
1065 if(num_args < num_decl)
1066 {
1067 oberon_error(ctx, "too few arguments");
1068 }
1069 else if(num_args > num_decl)
1070 {
1071 oberon_error(ctx, "too many arguments");
1072 }
1073
1074 /* Делаем проверку на запись и делаем автокаст */
1075 oberon_expr_t * casted[num_args];
1076 oberon_expr_t * arg = desig -> args;
1077 oberon_object_t * param = fn -> decl;
1078 for(int i = 0; i < num_args; i++)
1079 {
1080 if(param -> class == OBERON_CLASS_VAR_PARAM)
1081 {
1082 if(arg -> read_only)
1083 {
1084 oberon_error(ctx, "assign to read-only var");
1085 }
1086 }
1087
1088 casted[i] = oberon_autocast_to(ctx, arg, param -> type);
1089 arg = arg -> next;
1090 param = param -> next;
1091 }
1092
1093 /* Создаём новый список выражений */
1094 if(num_args > 0)
1095 {
1096 arg = casted[0];
1097 for(int i = 0; i < num_args - 1; i++)
1098 {
1099 casted[i] -> next = casted[i + 1];
1100 }
1101 desig -> args = arg;
1102 }
1103 }
1104
1105 static oberon_expr_t *
1106 oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1107 {
1108 oberon_type_t * signature = item -> result;
1109 if(signature -> class != OBERON_TYPE_PROCEDURE)
1110 {
1111 oberon_error(ctx, "not a procedure");
1112 }
1113
1114 oberon_expr_t * call;
1115
1116 if(signature -> sysproc)
1117 {
1118 if(signature -> genfunc == NULL)
1119 {
1120 oberon_error(ctx, "not a function-procedure");
1121 }
1122
1123 call = signature -> genfunc(ctx, num_args, list_args);
1124 }
1125 else
1126 {
1127 if(signature -> base -> class == OBERON_TYPE_VOID)
1128 {
1129 oberon_error(ctx, "attempt to call procedure in expression");
1130 }
1131
1132 call = oberon_new_item(MODE_CALL, signature -> base, true);
1133 call -> item.parent = item;
1134 call -> item.num_args = num_args;
1135 call -> item.args = list_args;
1136 oberon_autocast_call(ctx, (oberon_item_t *) call);
1137 }
1138
1139 return call;
1140 }
1141
1142 static void
1143 oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1144 {
1145 oberon_type_t * signature = item -> result;
1146 if(signature -> class != OBERON_TYPE_PROCEDURE)
1147 {
1148 oberon_error(ctx, "not a procedure");
1149 }
1150
1151 oberon_expr_t * call;
1152
1153 if(signature -> sysproc)
1154 {
1155 if(signature -> genproc == NULL)
1156 {
1157 oberon_error(ctx, "not a procedure");
1158 }
1159
1160 signature -> genproc(ctx, num_args, list_args);
1161 }
1162 else
1163 {
1164 if(signature -> base -> class != OBERON_TYPE_VOID)
1165 {
1166 oberon_error(ctx, "attempt to call function as non-typed procedure");
1167 }
1168
1169 call = oberon_new_item(MODE_CALL, signature -> base, true);
1170 call -> item.parent = item;
1171 call -> item.num_args = num_args;
1172 call -> item.args = list_args;
1173 oberon_autocast_call(ctx, (oberon_item_t *) call);
1174 oberon_generate_call_proc(ctx, call);
1175 }
1176 }
1177
1178 /*
1179 static void
1180 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
1181 {
1182 switch(proc -> class)
1183 {
1184 case OBERON_CLASS_PROC:
1185 if(proc -> class != OBERON_CLASS_PROC)
1186 {
1187 oberon_error(ctx, "not a procedure");
1188 }
1189 break;
1190 case OBERON_CLASS_VAR:
1191 case OBERON_CLASS_VAR_PARAM:
1192 case OBERON_CLASS_PARAM:
1193 if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
1194 {
1195 oberon_error(ctx, "not a procedure");
1196 }
1197 break;
1198 default:
1199 oberon_error(ctx, "not a procedure");
1200 break;
1201 }
1202
1203 if(proc -> sysproc)
1204 {
1205 if(proc -> genproc == NULL)
1206 {
1207 oberon_error(ctx, "requres non-typed procedure");
1208 }
1209
1210 proc -> genproc(ctx, num_args, list_args);
1211 }
1212 else
1213 {
1214 if(proc -> type -> base -> class != OBERON_TYPE_VOID)
1215 {
1216 oberon_error(ctx, "attempt to call function as non-typed procedure");
1217 }
1218
1219 oberon_expr_t * call;
1220 call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
1221 call -> item.var = proc;
1222 call -> item.num_args = num_args;
1223 call -> item.args = list_args;
1224 oberon_autocast_call(ctx, call);
1225 oberon_generate_call_proc(ctx, call);
1226 }
1227 }
1228 */
1229
1230 #define ISEXPR(x) \
1231 (((x) == PLUS) \
1232 || ((x) == MINUS) \
1233 || ((x) == IDENT) \
1234 || ((x) == INTEGER) \
1235 || ((x) == REAL) \
1236 || ((x) == CHAR) \
1237 || ((x) == STRING) \
1238 || ((x) == NIL) \
1239 || ((x) == LPAREN) \
1240 || ((x) == NOT) \
1241 || ((x) == TRUE) \
1242 || ((x) == FALSE))
1243
1244 static oberon_expr_t *
1245 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
1246 {
1247 printf("oberno_make_dereferencing\n");
1248 if(expr -> result -> class != OBERON_TYPE_POINTER)
1249 {
1250 oberon_error(ctx, "not a pointer");
1251 }
1252
1253 assert(expr -> is_item);
1254
1255 oberon_expr_t * selector;
1256 selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
1257 selector -> item.parent = (oberon_item_t *) expr;
1258
1259 return selector;
1260 }
1261
1262 static oberon_expr_t *
1263 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
1264 {
1265 if(desig -> result -> class == OBERON_TYPE_POINTER)
1266 {
1267 desig = oberno_make_dereferencing(ctx, desig);
1268 }
1269
1270 assert(desig -> is_item);
1271
1272 if(desig -> result -> class != OBERON_TYPE_ARRAY)
1273 {
1274 oberon_error(ctx, "not array");
1275 }
1276
1277 oberon_type_t * base;
1278 base = desig -> result -> base;
1279
1280 if(index -> result -> class != OBERON_TYPE_INTEGER)
1281 {
1282 oberon_error(ctx, "index must be integer");
1283 }
1284
1285 // Статическая проверка границ массива
1286 if(desig -> result -> size != 0)
1287 {
1288 if(index -> is_item)
1289 {
1290 if(index -> item.mode == MODE_INTEGER)
1291 {
1292 int arr_size = desig -> result -> size;
1293 int index_int = index -> item.integer;
1294 if(index_int < 0 || index_int > arr_size - 1)
1295 {
1296 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
1297 }
1298 }
1299 }
1300 }
1301
1302 oberon_expr_t * selector;
1303 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
1304 selector -> item.parent = (oberon_item_t *) desig;
1305 selector -> item.num_args = 1;
1306 selector -> item.args = index;
1307
1308 return selector;
1309 }
1310
1311 static oberon_expr_t *
1312 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
1313 {
1314 if(expr -> result -> class == OBERON_TYPE_POINTER)
1315 {
1316 expr = oberno_make_dereferencing(ctx, expr);
1317 }
1318
1319 assert(expr -> is_item);
1320
1321 if(expr -> result -> class != OBERON_TYPE_RECORD)
1322 {
1323 oberon_error(ctx, "not record");
1324 }
1325
1326 oberon_type_t * rec = expr -> result;
1327
1328 oberon_object_t * field;
1329 field = oberon_find_object(rec -> scope, name, true);
1330
1331 if(field -> export == 0)
1332 {
1333 if(field -> module != ctx -> mod)
1334 {
1335 oberon_error(ctx, "field not exported");
1336 }
1337 }
1338
1339 int read_only = 0;
1340 if(field -> read_only)
1341 {
1342 if(field -> module != ctx -> mod)
1343 {
1344 read_only = 1;
1345 }
1346 }
1347
1348 oberon_expr_t * selector;
1349 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
1350 selector -> item.var = field;
1351 selector -> item.parent = (oberon_item_t *) expr;
1352
1353 return selector;
1354 }
1355
1356 #define ISSELECTOR(x) \
1357 (((x) == LBRACE) \
1358 || ((x) == DOT) \
1359 || ((x) == UPARROW) \
1360 || ((x) == LPAREN))
1361
1362 static oberon_object_t *
1363 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1364 {
1365 char * name;
1366 oberon_object_t * x;
1367
1368 name = oberon_assert_ident(ctx);
1369 x = oberon_find_object(ctx -> decl, name, check);
1370
1371 if(x != NULL)
1372 {
1373 if(x -> class == OBERON_CLASS_MODULE)
1374 {
1375 oberon_assert_token(ctx, DOT);
1376 name = oberon_assert_ident(ctx);
1377 /* Наличие объектов в левых модулях всегда проверяется */
1378 x = oberon_find_object(x -> module -> decl, name, 1);
1379
1380 if(x -> export == 0)
1381 {
1382 oberon_error(ctx, "not exported");
1383 }
1384 }
1385 }
1386
1387 if(xname)
1388 {
1389 *xname = name;
1390 }
1391
1392 return x;
1393 }
1394
1395 static oberon_expr_t *
1396 oberon_designator(oberon_context_t * ctx)
1397 {
1398 char * name;
1399 oberon_object_t * var;
1400 oberon_expr_t * expr;
1401
1402 var = oberon_qualident(ctx, NULL, 1);
1403
1404 int read_only = 0;
1405 if(var -> read_only)
1406 {
1407 if(var -> module != ctx -> mod)
1408 {
1409 read_only = 1;
1410 }
1411 }
1412
1413 switch(var -> class)
1414 {
1415 case OBERON_CLASS_CONST:
1416 // TODO copy value
1417 expr = (oberon_expr_t *) var -> value;
1418 break;
1419 case OBERON_CLASS_VAR:
1420 case OBERON_CLASS_VAR_PARAM:
1421 case OBERON_CLASS_PARAM:
1422 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1423 break;
1424 case OBERON_CLASS_PROC:
1425 expr = oberon_new_item(MODE_VAR, var -> type, 1);
1426 break;
1427 default:
1428 oberon_error(ctx, "invalid designator");
1429 break;
1430 }
1431 expr -> item.var = var;
1432
1433 while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
1434 {
1435 switch(ctx -> token)
1436 {
1437 case DOT:
1438 oberon_assert_token(ctx, DOT);
1439 name = oberon_assert_ident(ctx);
1440 expr = oberon_make_record_selector(ctx, expr, name);
1441 break;
1442 case LBRACE:
1443 oberon_assert_token(ctx, LBRACE);
1444 int num_indexes = 0;
1445 oberon_expr_t * indexes = NULL;
1446 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1447 oberon_assert_token(ctx, RBRACE);
1448
1449 for(int i = 0; i < num_indexes; i++)
1450 {
1451 expr = oberon_make_array_selector(ctx, expr, indexes);
1452 indexes = indexes -> next;
1453 }
1454 break;
1455 case UPARROW:
1456 oberon_assert_token(ctx, UPARROW);
1457 expr = oberno_make_dereferencing(ctx, expr);
1458 break;
1459 case LPAREN:
1460 oberon_assert_token(ctx, LPAREN);
1461 oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1);
1462 if(objtype -> class != OBERON_CLASS_TYPE)
1463 {
1464 oberon_error(ctx, "must be type");
1465 }
1466 oberon_assert_token(ctx, RPAREN);
1467 expr = oberno_make_record_cast(ctx, expr, objtype -> type);
1468 break;
1469 default:
1470 oberon_error(ctx, "oberon_designator: wat");
1471 break;
1472 }
1473 }
1474
1475 return expr;
1476 }
1477
1478 static oberon_expr_t *
1479 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1480 {
1481 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1482 if(ctx -> token == LPAREN)
1483 {
1484 oberon_assert_token(ctx, LPAREN);
1485
1486 int num_args = 0;
1487 oberon_expr_t * arguments = NULL;
1488
1489 if(ISEXPR(ctx -> token))
1490 {
1491 oberon_expr_list(ctx, &num_args, &arguments, 0);
1492 }
1493
1494 assert(expr -> is_item == 1);
1495 expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
1496
1497 oberon_assert_token(ctx, RPAREN);
1498 }
1499
1500 return expr;
1501 }
1502
1503 static void
1504 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1505 {
1506 assert(expr -> is_item);
1507
1508 int num_args = 0;
1509 oberon_expr_t * arguments = NULL;
1510
1511 if(ctx -> token == LPAREN)
1512 {
1513 oberon_assert_token(ctx, LPAREN);
1514
1515 if(ISEXPR(ctx -> token))
1516 {
1517 oberon_expr_list(ctx, &num_args, &arguments, 0);
1518 }
1519
1520 oberon_assert_token(ctx, RPAREN);
1521 }
1522
1523 /* Вызов происходит даже без скобок */
1524 oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
1525 }
1526
1527 static oberon_type_t *
1528 oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i)
1529 {
1530 if(i >= -128 && i <= 127)
1531 {
1532 return ctx -> byte_type;
1533 }
1534 else if(i >= -32768 && i <= 32767)
1535 {
1536 return ctx -> shortint_type;
1537 }
1538 else if(i >= -2147483648 && i <= 2147483647)
1539 {
1540 return ctx -> int_type;
1541 }
1542 else
1543 {
1544 return ctx -> longint_type;
1545 }
1546 }
1547
1548 static oberon_expr_t *
1549 oberon_factor(oberon_context_t * ctx)
1550 {
1551 oberon_expr_t * expr;
1552 oberon_type_t * result;
1553
1554 switch(ctx -> token)
1555 {
1556 case IDENT:
1557 expr = oberon_designator(ctx);
1558 expr = oberon_opt_func_parens(ctx, expr);
1559 break;
1560 case INTEGER:
1561 result = oberon_get_type_of_int_value(ctx, ctx -> integer);
1562 expr = oberon_new_item(MODE_INTEGER, result, true);
1563 expr -> item.integer = ctx -> integer;
1564 oberon_assert_token(ctx, INTEGER);
1565 break;
1566 case CHAR:
1567 result = ctx -> char_type;
1568 expr = oberon_new_item(MODE_CHAR, result, true);
1569 expr -> item.integer = ctx -> integer;
1570 oberon_assert_token(ctx, CHAR);
1571 break;
1572 case STRING:
1573 result = ctx -> string_type;
1574 expr = oberon_new_item(MODE_STRING, result, true);
1575 expr -> item.string = ctx -> string;
1576 oberon_assert_token(ctx, STRING);
1577 break;
1578 case REAL:
1579 result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type);
1580 expr = oberon_new_item(MODE_REAL, result, 1);
1581 expr -> item.real = ctx -> real;
1582 oberon_assert_token(ctx, REAL);
1583 break;
1584 case TRUE:
1585 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1586 expr -> item.boolean = true;
1587 oberon_assert_token(ctx, TRUE);
1588 break;
1589 case FALSE:
1590 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1591 expr -> item.boolean = false;
1592 oberon_assert_token(ctx, FALSE);
1593 break;
1594 case LPAREN:
1595 oberon_assert_token(ctx, LPAREN);
1596 expr = oberon_expr(ctx);
1597 oberon_assert_token(ctx, RPAREN);
1598 break;
1599 case NOT:
1600 oberon_assert_token(ctx, NOT);
1601 expr = oberon_factor(ctx);
1602 expr = oberon_make_unary_op(ctx, NOT, expr);
1603 break;
1604 case NIL:
1605 oberon_assert_token(ctx, NIL);
1606 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, true);
1607 break;
1608 default:
1609 oberon_error(ctx, "invalid expression");
1610 }
1611
1612 return expr;
1613 }
1614
1615 #define ITMAKESBOOLEAN(x) \
1616 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1617
1618 #define ITUSEONLYINTEGER(x) \
1619 ((x) >= LESS && (x) <= GEQ)
1620
1621 #define ITUSEONLYBOOLEAN(x) \
1622 (((x) == OR) || ((x) == AND))
1623
1624 static void
1625 oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e)
1626 {
1627 oberon_expr_t * expr = *e;
1628 if(expr -> result -> class == OBERON_TYPE_INTEGER)
1629 {
1630 if(expr -> result -> size <= ctx -> real_type -> size)
1631 {
1632 *e = oberon_cast_expr(ctx, expr, ctx -> real_type);
1633 }
1634 else
1635 {
1636 *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type);
1637 }
1638 }
1639 else if(expr -> result -> class != OBERON_TYPE_REAL)
1640 {
1641 oberon_error(ctx, "required numeric type");
1642 }
1643 }
1644
1645 static oberon_expr_t *
1646 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1647 {
1648 oberon_expr_t * expr;
1649 oberon_type_t * result;
1650
1651 if(ITMAKESBOOLEAN(token))
1652 {
1653 if(ITUSEONLYINTEGER(token))
1654 {
1655 if(a -> result -> class == OBERON_TYPE_INTEGER
1656 || b -> result -> class == OBERON_TYPE_INTEGER
1657 || a -> result -> class == OBERON_TYPE_REAL
1658 || b -> result -> class == OBERON_TYPE_REAL)
1659 {
1660 // accept
1661 }
1662 else
1663 {
1664 oberon_error(ctx, "used only with numeric types");
1665 }
1666 }
1667 else if(ITUSEONLYBOOLEAN(token))
1668 {
1669 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1670 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1671 {
1672 oberon_error(ctx, "used only with boolean type");
1673 }
1674 }
1675
1676 oberon_autocast_binary_op(ctx, &a, &b);
1677 result = ctx -> bool_type;
1678
1679 if(token == EQUAL)
1680 {
1681 expr = oberon_new_operator(OP_EQ, result, a, b);
1682 }
1683 else if(token == NEQ)
1684 {
1685 expr = oberon_new_operator(OP_NEQ, result, a, b);
1686 }
1687 else if(token == LESS)
1688 {
1689 expr = oberon_new_operator(OP_LSS, result, a, b);
1690 }
1691 else if(token == LEQ)
1692 {
1693 expr = oberon_new_operator(OP_LEQ, result, a, b);
1694 }
1695 else if(token == GREAT)
1696 {
1697 expr = oberon_new_operator(OP_GRT, result, a, b);
1698 }
1699 else if(token == GEQ)
1700 {
1701 expr = oberon_new_operator(OP_GEQ, result, a, b);
1702 }
1703 else if(token == OR)
1704 {
1705 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1706 }
1707 else if(token == AND)
1708 {
1709 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1710 }
1711 else
1712 {
1713 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1714 }
1715 }
1716 else if(token == SLASH)
1717 {
1718 oberon_autocast_to_real(ctx, &a);
1719 oberon_autocast_to_real(ctx, &b);
1720 oberon_autocast_binary_op(ctx, &a, &b);
1721 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1722 }
1723 else if(token == DIV)
1724 {
1725 if(a -> result -> class != OBERON_TYPE_INTEGER
1726 || b -> result -> class != OBERON_TYPE_INTEGER)
1727 {
1728 oberon_error(ctx, "operator DIV requires integer type");
1729 }
1730
1731 oberon_autocast_binary_op(ctx, &a, &b);
1732 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1733 }
1734 else
1735 {
1736 oberon_autocast_binary_op(ctx, &a, &b);
1737
1738 if(token == PLUS)
1739 {
1740 expr = oberon_new_operator(OP_ADD, a -> result, a, b);
1741 }
1742 else if(token == MINUS)
1743 {
1744 expr = oberon_new_operator(OP_SUB, a -> result, a, b);
1745 }
1746 else if(token == STAR)
1747 {
1748 expr = oberon_new_operator(OP_MUL, a -> result, a, b);
1749 }
1750 else if(token == MOD)
1751 {
1752 expr = oberon_new_operator(OP_MOD, a -> result, a, b);
1753 }
1754 else
1755 {
1756 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1757 }
1758 }
1759
1760 return expr;
1761 }
1762
1763 #define ISMULOP(x) \
1764 ((x) >= STAR && (x) <= AND)
1765
1766 static oberon_expr_t *
1767 oberon_term_expr(oberon_context_t * ctx)
1768 {
1769 oberon_expr_t * expr;
1770
1771 expr = oberon_factor(ctx);
1772 while(ISMULOP(ctx -> token))
1773 {
1774 int token = ctx -> token;
1775 oberon_read_token(ctx);
1776
1777 oberon_expr_t * inter = oberon_factor(ctx);
1778 expr = oberon_make_bin_op(ctx, token, expr, inter);
1779 }
1780
1781 return expr;
1782 }
1783
1784 #define ISADDOP(x) \
1785 ((x) >= PLUS && (x) <= OR)
1786
1787 static oberon_expr_t *
1788 oberon_simple_expr(oberon_context_t * ctx)
1789 {
1790 oberon_expr_t * expr;
1791
1792 int minus = 0;
1793 if(ctx -> token == PLUS)
1794 {
1795 minus = 0;
1796 oberon_assert_token(ctx, PLUS);
1797 }
1798 else if(ctx -> token == MINUS)
1799 {
1800 minus = 1;
1801 oberon_assert_token(ctx, MINUS);
1802 }
1803
1804 expr = oberon_term_expr(ctx);
1805
1806 if(minus)
1807 {
1808 expr = oberon_make_unary_op(ctx, MINUS, expr);
1809 }
1810
1811 while(ISADDOP(ctx -> token))
1812 {
1813 int token = ctx -> token;
1814 oberon_read_token(ctx);
1815
1816 oberon_expr_t * inter = oberon_term_expr(ctx);
1817 expr = oberon_make_bin_op(ctx, token, expr, inter);
1818 }
1819
1820 return expr;
1821 }
1822
1823 #define ISRELATION(x) \
1824 ((x) >= EQUAL && (x) <= IS)
1825
1826 static oberon_expr_t *
1827 oberon_expr(oberon_context_t * ctx)
1828 {
1829 oberon_expr_t * expr;
1830
1831 expr = oberon_simple_expr(ctx);
1832 while(ISRELATION(ctx -> token))
1833 {
1834 int token = ctx -> token;
1835 oberon_read_token(ctx);
1836
1837 oberon_expr_t * inter = oberon_simple_expr(ctx);
1838 expr = oberon_make_bin_op(ctx, token, expr, inter);
1839 }
1840
1841 return expr;
1842 }
1843
1844 static oberon_item_t *
1845 oberon_const_expr(oberon_context_t * ctx)
1846 {
1847 oberon_expr_t * expr;
1848 expr = oberon_expr(ctx);
1849
1850 if(expr -> is_item == 0)
1851 {
1852 oberon_error(ctx, "const expression are required");
1853 }
1854
1855 return (oberon_item_t *) expr;
1856 }
1857
1858 // =======================================================================
1859 // PARSER
1860 // =======================================================================
1861
1862 static void oberon_decl_seq(oberon_context_t * ctx);
1863 static void oberon_statement_seq(oberon_context_t * ctx);
1864 static void oberon_initialize_decl(oberon_context_t * ctx);
1865
1866 static void
1867 oberon_expect_token(oberon_context_t * ctx, int token)
1868 {
1869 if(ctx -> token != token)
1870 {
1871 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1872 }
1873 }
1874
1875 static void
1876 oberon_assert_token(oberon_context_t * ctx, int token)
1877 {
1878 oberon_expect_token(ctx, token);
1879 oberon_read_token(ctx);
1880 }
1881
1882 static char *
1883 oberon_assert_ident(oberon_context_t * ctx)
1884 {
1885 oberon_expect_token(ctx, IDENT);
1886 char * ident = ctx -> string;
1887 oberon_read_token(ctx);
1888 return ident;
1889 }
1890
1891 static void
1892 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
1893 {
1894 switch(ctx -> token)
1895 {
1896 case STAR:
1897 oberon_assert_token(ctx, STAR);
1898 *export = 1;
1899 *read_only = 0;
1900 break;
1901 case MINUS:
1902 oberon_assert_token(ctx, MINUS);
1903 *export = 1;
1904 *read_only = 1;
1905 break;
1906 default:
1907 *export = 0;
1908 *read_only = 0;
1909 break;
1910 }
1911 }
1912
1913 static oberon_object_t *
1914 oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
1915 {
1916 char * name;
1917 int export;
1918 int read_only;
1919 oberon_object_t * x;
1920
1921 name = oberon_assert_ident(ctx);
1922 oberon_def(ctx, &export, &read_only);
1923
1924 x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
1925 return x;
1926 }
1927
1928 static void
1929 oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
1930 {
1931 *num = 1;
1932 *list = oberon_ident_def(ctx, class, check_upscope);
1933 while(ctx -> token == COMMA)
1934 {
1935 oberon_assert_token(ctx, COMMA);
1936 oberon_ident_def(ctx, class, check_upscope);
1937 *num += 1;
1938 }
1939 }
1940
1941 static void
1942 oberon_var_decl(oberon_context_t * ctx)
1943 {
1944 int num;
1945 oberon_object_t * list;
1946 oberon_type_t * type;
1947 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1948
1949 oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
1950 oberon_assert_token(ctx, COLON);
1951 oberon_type(ctx, &type);
1952
1953 oberon_object_t * var = list;
1954 for(int i = 0; i < num; i++)
1955 {
1956 var -> type = type;
1957 var = var -> next;
1958 }
1959 }
1960
1961 static oberon_object_t *
1962 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1963 {
1964 int class = OBERON_CLASS_PARAM;
1965 if(ctx -> token == VAR)
1966 {
1967 oberon_read_token(ctx);
1968 class = OBERON_CLASS_VAR_PARAM;
1969 }
1970
1971 int num;
1972 oberon_object_t * list;
1973 oberon_ident_list(ctx, class, false, &num, &list);
1974
1975 oberon_assert_token(ctx, COLON);
1976
1977 oberon_type_t * type;
1978 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1979 oberon_type(ctx, &type);
1980
1981 oberon_object_t * param = list;
1982 for(int i = 0; i < num; i++)
1983 {
1984 param -> type = type;
1985 param = param -> next;
1986 }
1987
1988 *num_decl += num;
1989 return list;
1990 }
1991
1992 #define ISFPSECTION \
1993 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1994
1995 static void
1996 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1997 {
1998 oberon_assert_token(ctx, LPAREN);
1999
2000 if(ISFPSECTION)
2001 {
2002 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
2003 while(ctx -> token == SEMICOLON)
2004 {
2005 oberon_assert_token(ctx, SEMICOLON);
2006 oberon_fp_section(ctx, &signature -> num_decl);
2007 }
2008 }
2009
2010 oberon_assert_token(ctx, RPAREN);
2011
2012 if(ctx -> token == COLON)
2013 {
2014 oberon_assert_token(ctx, COLON);
2015
2016 oberon_object_t * typeobj;
2017 typeobj = oberon_qualident(ctx, NULL, 1);
2018 if(typeobj -> class != OBERON_CLASS_TYPE)
2019 {
2020 oberon_error(ctx, "function result is not type");
2021 }
2022 signature -> base = typeobj -> type;
2023 }
2024 }
2025
2026 static void
2027 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
2028 {
2029 oberon_type_t * signature;
2030 signature = *type;
2031 signature -> class = OBERON_TYPE_PROCEDURE;
2032 signature -> num_decl = 0;
2033 signature -> base = ctx -> void_type;
2034 signature -> decl = NULL;
2035
2036 if(ctx -> token == LPAREN)
2037 {
2038 oberon_formal_pars(ctx, signature);
2039 }
2040 }
2041
2042 static void
2043 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
2044 {
2045 if(a -> num_decl != b -> num_decl)
2046 {
2047 oberon_error(ctx, "number parameters not matched");
2048 }
2049
2050 int num_param = a -> num_decl;
2051 oberon_object_t * param_a = a -> decl;
2052 oberon_object_t * param_b = b -> decl;
2053 for(int i = 0; i < num_param; i++)
2054 {
2055 if(strcmp(param_a -> name, param_b -> name) != 0)
2056 {
2057 oberon_error(ctx, "param %i name not matched", i + 1);
2058 }
2059
2060 if(param_a -> type != param_b -> type)
2061 {
2062 oberon_error(ctx, "param %i type not matched", i + 1);
2063 }
2064
2065 param_a = param_a -> next;
2066 param_b = param_b -> next;
2067 }
2068 }
2069
2070 static void
2071 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
2072 {
2073 oberon_object_t * proc = ctx -> decl -> parent;
2074 oberon_type_t * result_type = proc -> type -> base;
2075
2076 if(result_type -> class == OBERON_TYPE_VOID)
2077 {
2078 if(expr != NULL)
2079 {
2080 oberon_error(ctx, "procedure has no result type");
2081 }
2082 }
2083 else
2084 {
2085 if(expr == NULL)
2086 {
2087 oberon_error(ctx, "procedure requires expression on result");
2088 }
2089
2090 expr = oberon_autocast_to(ctx, expr, result_type);
2091 }
2092
2093 proc -> has_return = 1;
2094
2095 oberon_generate_return(ctx, expr);
2096 }
2097
2098 static void
2099 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
2100 {
2101 oberon_assert_token(ctx, SEMICOLON);
2102
2103 ctx -> decl = proc -> scope;
2104
2105 oberon_decl_seq(ctx);
2106
2107 oberon_generate_begin_proc(ctx, proc);
2108
2109 if(ctx -> token == BEGIN)
2110 {
2111 oberon_assert_token(ctx, BEGIN);
2112 oberon_statement_seq(ctx);
2113 }
2114
2115 oberon_assert_token(ctx, END);
2116 char * name = oberon_assert_ident(ctx);
2117 if(strcmp(name, proc -> name) != 0)
2118 {
2119 oberon_error(ctx, "procedure name not matched");
2120 }
2121
2122 if(proc -> type -> base -> class == OBERON_TYPE_VOID
2123 && proc -> has_return == 0)
2124 {
2125 oberon_make_return(ctx, NULL);
2126 }
2127
2128 if(proc -> has_return == 0)
2129 {
2130 oberon_error(ctx, "procedure requires return");
2131 }
2132
2133 oberon_generate_end_proc(ctx);
2134 oberon_close_scope(ctx -> decl);
2135 }
2136
2137 static void
2138 oberon_proc_decl(oberon_context_t * ctx)
2139 {
2140 oberon_assert_token(ctx, PROCEDURE);
2141
2142 int forward = 0;
2143 if(ctx -> token == UPARROW)
2144 {
2145 oberon_assert_token(ctx, UPARROW);
2146 forward = 1;
2147 }
2148
2149 char * name;
2150 int export;
2151 int read_only;
2152 name = oberon_assert_ident(ctx);
2153 oberon_def(ctx, &export, &read_only);
2154
2155 oberon_scope_t * proc_scope;
2156 proc_scope = oberon_open_scope(ctx);
2157 ctx -> decl -> local = 1;
2158
2159 oberon_type_t * signature;
2160 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
2161 oberon_opt_formal_pars(ctx, &signature);
2162
2163 oberon_initialize_decl(ctx);
2164 oberon_generator_init_type(ctx, signature);
2165 oberon_close_scope(ctx -> decl);
2166
2167 oberon_object_t * proc;
2168 proc = oberon_find_object(ctx -> decl, name, 0);
2169 if(proc != NULL)
2170 {
2171 if(proc -> class != OBERON_CLASS_PROC)
2172 {
2173 oberon_error(ctx, "mult definition");
2174 }
2175
2176 if(forward == 0)
2177 {
2178 if(proc -> linked)
2179 {
2180 oberon_error(ctx, "mult procedure definition");
2181 }
2182 }
2183
2184 if(proc -> export != export || proc -> read_only != read_only)
2185 {
2186 oberon_error(ctx, "export type not matched");
2187 }
2188
2189 oberon_compare_signatures(ctx, proc -> type, signature);
2190 }
2191 else
2192 {
2193 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
2194 proc -> type = signature;
2195 proc -> scope = proc_scope;
2196 oberon_generator_init_proc(ctx, proc);
2197 }
2198
2199 proc -> scope -> parent = proc;
2200
2201 if(forward == 0)
2202 {
2203 proc -> linked = 1;
2204 oberon_proc_decl_body(ctx, proc);
2205 }
2206 }
2207
2208 static void
2209 oberon_const_decl(oberon_context_t * ctx)
2210 {
2211 oberon_item_t * value;
2212 oberon_object_t * constant;
2213
2214 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
2215 oberon_assert_token(ctx, EQUAL);
2216 value = oberon_const_expr(ctx);
2217 constant -> value = value;
2218 }
2219
2220 static void
2221 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
2222 {
2223 if(size -> is_item == 0)
2224 {
2225 oberon_error(ctx, "requires constant");
2226 }
2227
2228 if(size -> item.mode != MODE_INTEGER)
2229 {
2230 oberon_error(ctx, "requires integer constant");
2231 }
2232
2233 oberon_type_t * arr;
2234 arr = *type;
2235 arr -> class = OBERON_TYPE_ARRAY;
2236 arr -> size = size -> item.integer;
2237 arr -> base = base;
2238 }
2239
2240 static void
2241 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2242 {
2243 char * name;
2244 oberon_object_t * to;
2245
2246 to = oberon_qualident(ctx, &name, 0);
2247
2248 //name = oberon_assert_ident(ctx);
2249 //to = oberon_find_object(ctx -> decl, name, 0);
2250
2251 if(to != NULL)
2252 {
2253 if(to -> class != OBERON_CLASS_TYPE)
2254 {
2255 oberon_error(ctx, "not a type");
2256 }
2257 }
2258 else
2259 {
2260 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2261 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2262 }
2263
2264 *type = to -> type;
2265 }
2266
2267 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2268
2269 /*
2270 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2271 */
2272
2273 static void
2274 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2275 {
2276 if(sizes == NULL)
2277 {
2278 *type = base;
2279 return;
2280 }
2281
2282 oberon_type_t * dim;
2283 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2284
2285 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2286
2287 oberon_make_array_type(ctx, sizes, dim, type);
2288 }
2289
2290 static void
2291 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2292 {
2293 type -> class = OBERON_TYPE_ARRAY;
2294 type -> size = 0;
2295 type -> base = base;
2296 }
2297
2298 static void
2299 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2300 {
2301 if(ctx -> token == IDENT)
2302 {
2303 int num;
2304 oberon_object_t * list;
2305 oberon_type_t * type;
2306 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2307
2308 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2309 oberon_assert_token(ctx, COLON);
2310
2311 oberon_scope_t * current = ctx -> decl;
2312 ctx -> decl = modscope;
2313 oberon_type(ctx, &type);
2314 ctx -> decl = current;
2315
2316 oberon_object_t * field = list;
2317 for(int i = 0; i < num; i++)
2318 {
2319 field -> type = type;
2320 field = field -> next;
2321 }
2322
2323 rec -> num_decl += num;
2324 }
2325 }
2326
2327 static void
2328 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2329 {
2330 oberon_scope_t * modscope = ctx -> mod -> decl;
2331 oberon_scope_t * oldscope = ctx -> decl;
2332 ctx -> decl = modscope;
2333
2334 if(ctx -> token == LPAREN)
2335 {
2336 oberon_assert_token(ctx, LPAREN);
2337
2338 oberon_object_t * typeobj;
2339 typeobj = oberon_qualident(ctx, NULL, true);
2340
2341 if(typeobj -> class != OBERON_CLASS_TYPE)
2342 {
2343 oberon_error(ctx, "base must be type");
2344 }
2345
2346 oberon_type_t * base = typeobj -> type;
2347 if(base -> class == OBERON_TYPE_POINTER)
2348 {
2349 base = base -> base;
2350 }
2351
2352 if(base -> class != OBERON_TYPE_RECORD)
2353 {
2354 oberon_error(ctx, "base must be record type");
2355 }
2356
2357 rec -> base = base;
2358 ctx -> decl = base -> scope;
2359
2360 oberon_assert_token(ctx, RPAREN);
2361 }
2362 else
2363 {
2364 ctx -> decl = NULL;
2365 }
2366
2367 oberon_scope_t * this_scope;
2368 this_scope = oberon_open_scope(ctx);
2369 this_scope -> local = true;
2370 this_scope -> parent = NULL;
2371 this_scope -> parent_type = rec;
2372
2373 oberon_field_list(ctx, rec, modscope);
2374 while(ctx -> token == SEMICOLON)
2375 {
2376 oberon_assert_token(ctx, SEMICOLON);
2377 oberon_field_list(ctx, rec, modscope);
2378 }
2379
2380 rec -> scope = this_scope;
2381 rec -> decl = this_scope -> list -> next;
2382 ctx -> decl = oldscope;
2383 }
2384
2385 static void
2386 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2387 {
2388 if(ctx -> token == IDENT)
2389 {
2390 oberon_qualident_type(ctx, type);
2391 }
2392 else if(ctx -> token == ARRAY)
2393 {
2394 oberon_assert_token(ctx, ARRAY);
2395
2396 int num_sizes = 0;
2397 oberon_expr_t * sizes;
2398
2399 if(ISEXPR(ctx -> token))
2400 {
2401 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2402 }
2403
2404 oberon_assert_token(ctx, OF);
2405
2406 oberon_type_t * base;
2407 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2408 oberon_type(ctx, &base);
2409
2410 if(num_sizes == 0)
2411 {
2412 oberon_make_open_array(ctx, base, *type);
2413 }
2414 else
2415 {
2416 oberon_make_multiarray(ctx, sizes, base, type);
2417 }
2418 }
2419 else if(ctx -> token == RECORD)
2420 {
2421 oberon_type_t * rec;
2422 rec = *type;
2423 rec -> class = OBERON_TYPE_RECORD;
2424 rec -> module = ctx -> mod;
2425
2426 oberon_assert_token(ctx, RECORD);
2427 oberon_type_record_body(ctx, rec);
2428 oberon_assert_token(ctx, END);
2429
2430 *type = rec;
2431 }
2432 else if(ctx -> token == POINTER)
2433 {
2434 oberon_assert_token(ctx, POINTER);
2435 oberon_assert_token(ctx, TO);
2436
2437 oberon_type_t * base;
2438 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2439 oberon_type(ctx, &base);
2440
2441 oberon_type_t * ptr;
2442 ptr = *type;
2443 ptr -> class = OBERON_TYPE_POINTER;
2444 ptr -> base = base;
2445 }
2446 else if(ctx -> token == PROCEDURE)
2447 {
2448 oberon_open_scope(ctx);
2449 oberon_assert_token(ctx, PROCEDURE);
2450 oberon_opt_formal_pars(ctx, type);
2451 oberon_close_scope(ctx -> decl);
2452 }
2453 else
2454 {
2455 oberon_error(ctx, "invalid type declaration");
2456 }
2457 }
2458
2459 static void
2460 oberon_type_decl(oberon_context_t * ctx)
2461 {
2462 char * name;
2463 oberon_object_t * newtype;
2464 oberon_type_t * type;
2465 int export;
2466 int read_only;
2467
2468 name = oberon_assert_ident(ctx);
2469 oberon_def(ctx, &export, &read_only);
2470
2471 newtype = oberon_find_object(ctx -> decl, name, 0);
2472 if(newtype == NULL)
2473 {
2474 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2475 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2476 assert(newtype -> type);
2477 }
2478 else
2479 {
2480 if(newtype -> class != OBERON_CLASS_TYPE)
2481 {
2482 oberon_error(ctx, "mult definition");
2483 }
2484
2485 if(newtype -> linked)
2486 {
2487 oberon_error(ctx, "mult definition - already linked");
2488 }
2489
2490 newtype -> export = export;
2491 newtype -> read_only = read_only;
2492 }
2493
2494 oberon_assert_token(ctx, EQUAL);
2495
2496 type = newtype -> type;
2497 oberon_type(ctx, &type);
2498
2499 if(type -> class == OBERON_TYPE_VOID)
2500 {
2501 oberon_error(ctx, "recursive alias declaration");
2502 }
2503
2504 newtype -> type = type;
2505 newtype -> linked = 1;
2506 }
2507
2508 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2509 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2510
2511 static void
2512 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2513 {
2514 if(type -> class != OBERON_TYPE_POINTER
2515 && type -> class != OBERON_TYPE_ARRAY)
2516 {
2517 return;
2518 }
2519
2520 if(type -> recursive)
2521 {
2522 oberon_error(ctx, "recursive pointer declaration");
2523 }
2524
2525 if(type -> class == OBERON_TYPE_POINTER
2526 && type -> base -> class == OBERON_TYPE_POINTER)
2527 {
2528 oberon_error(ctx, "attempt to make pointer to pointer");
2529 }
2530
2531 type -> recursive = 1;
2532
2533 oberon_prevent_recursive_pointer(ctx, type -> base);
2534
2535 type -> recursive = 0;
2536 }
2537
2538 static void
2539 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2540 {
2541 if(type -> class != OBERON_TYPE_RECORD)
2542 {
2543 return;
2544 }
2545
2546 if(type -> recursive)
2547 {
2548 oberon_error(ctx, "recursive record declaration");
2549 }
2550
2551 type -> recursive = 1;
2552
2553 int num_fields = type -> num_decl;
2554 oberon_object_t * field = type -> decl;
2555 for(int i = 0; i < num_fields; i++)
2556 {
2557 oberon_prevent_recursive_object(ctx, field);
2558 field = field -> next;
2559 }
2560
2561 type -> recursive = 0;
2562 }
2563 static void
2564 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2565 {
2566 if(type -> class != OBERON_TYPE_PROCEDURE)
2567 {
2568 return;
2569 }
2570
2571 if(type -> recursive)
2572 {
2573 oberon_error(ctx, "recursive procedure declaration");
2574 }
2575
2576 type -> recursive = 1;
2577
2578 int num_fields = type -> num_decl;
2579 oberon_object_t * field = type -> decl;
2580 for(int i = 0; i < num_fields; i++)
2581 {
2582 oberon_prevent_recursive_object(ctx, field);
2583 field = field -> next;
2584 }
2585
2586 type -> recursive = 0;
2587 }
2588
2589 static void
2590 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2591 {
2592 if(type -> class != OBERON_TYPE_ARRAY)
2593 {
2594 return;
2595 }
2596
2597 if(type -> recursive)
2598 {
2599 oberon_error(ctx, "recursive array declaration");
2600 }
2601
2602 type -> recursive = 1;
2603
2604 oberon_prevent_recursive_type(ctx, type -> base);
2605
2606 type -> recursive = 0;
2607 }
2608
2609 static void
2610 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2611 {
2612 if(type -> class == OBERON_TYPE_POINTER)
2613 {
2614 oberon_prevent_recursive_pointer(ctx, type);
2615 }
2616 else if(type -> class == OBERON_TYPE_RECORD)
2617 {
2618 oberon_prevent_recursive_record(ctx, type);
2619 }
2620 else if(type -> class == OBERON_TYPE_ARRAY)
2621 {
2622 oberon_prevent_recursive_array(ctx, type);
2623 }
2624 else if(type -> class == OBERON_TYPE_PROCEDURE)
2625 {
2626 oberon_prevent_recursive_procedure(ctx, type);
2627 }
2628 }
2629
2630 static void
2631 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2632 {
2633 switch(x -> class)
2634 {
2635 case OBERON_CLASS_VAR:
2636 case OBERON_CLASS_TYPE:
2637 case OBERON_CLASS_PARAM:
2638 case OBERON_CLASS_VAR_PARAM:
2639 case OBERON_CLASS_FIELD:
2640 oberon_prevent_recursive_type(ctx, x -> type);
2641 break;
2642 case OBERON_CLASS_CONST:
2643 case OBERON_CLASS_PROC:
2644 case OBERON_CLASS_MODULE:
2645 break;
2646 default:
2647 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2648 break;
2649 }
2650 }
2651
2652 static void
2653 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2654 {
2655 oberon_object_t * x = ctx -> decl -> list -> next;
2656
2657 while(x)
2658 {
2659 oberon_prevent_recursive_object(ctx, x);
2660 x = x -> next;
2661 }
2662 }
2663
2664 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2665 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2666
2667 static void
2668 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2669 {
2670 if(type -> class != OBERON_TYPE_RECORD)
2671 {
2672 return;
2673 }
2674
2675 int num_fields = type -> num_decl;
2676 oberon_object_t * field = type -> decl;
2677 for(int i = 0; i < num_fields; i++)
2678 {
2679 if(field -> type -> class == OBERON_TYPE_POINTER)
2680 {
2681 oberon_initialize_type(ctx, field -> type);
2682 }
2683
2684 oberon_initialize_object(ctx, field);
2685 field = field -> next;
2686 }
2687
2688 oberon_generator_init_record(ctx, type);
2689 }
2690
2691 static void
2692 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2693 {
2694 if(type -> class == OBERON_TYPE_VOID)
2695 {
2696 oberon_error(ctx, "undeclarated type");
2697 }
2698
2699 if(type -> initialized)
2700 {
2701 return;
2702 }
2703
2704 type -> initialized = 1;
2705
2706 if(type -> class == OBERON_TYPE_POINTER)
2707 {
2708 oberon_initialize_type(ctx, type -> base);
2709 oberon_generator_init_type(ctx, type);
2710 }
2711 else if(type -> class == OBERON_TYPE_ARRAY)
2712 {
2713 if(type -> size != 0)
2714 {
2715 if(type -> base -> class == OBERON_TYPE_ARRAY)
2716 {
2717 if(type -> base -> size == 0)
2718 {
2719 oberon_error(ctx, "open array not allowed as array element");
2720 }
2721 }
2722 }
2723
2724 oberon_initialize_type(ctx, type -> base);
2725 oberon_generator_init_type(ctx, type);
2726 }
2727 else if(type -> class == OBERON_TYPE_RECORD)
2728 {
2729 oberon_generator_init_type(ctx, type);
2730 oberon_initialize_record_fields(ctx, type);
2731 }
2732 else if(type -> class == OBERON_TYPE_PROCEDURE)
2733 {
2734 int num_fields = type -> num_decl;
2735 oberon_object_t * field = type -> decl;
2736 for(int i = 0; i < num_fields; i++)
2737 {
2738 oberon_initialize_object(ctx, field);
2739 field = field -> next;
2740 }
2741
2742 oberon_generator_init_type(ctx, type);
2743 }
2744 else
2745 {
2746 oberon_generator_init_type(ctx, type);
2747 }
2748 }
2749
2750 static void
2751 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2752 {
2753 if(x -> initialized)
2754 {
2755 return;
2756 }
2757
2758 x -> initialized = 1;
2759
2760 switch(x -> class)
2761 {
2762 case OBERON_CLASS_TYPE:
2763 oberon_initialize_type(ctx, x -> type);
2764 break;
2765 case OBERON_CLASS_VAR:
2766 case OBERON_CLASS_FIELD:
2767 if(x -> type -> class == OBERON_TYPE_ARRAY)
2768 {
2769 if(x -> type -> size == 0)
2770 {
2771 oberon_error(ctx, "open array not allowed as variable or field");
2772 }
2773 }
2774 oberon_initialize_type(ctx, x -> type);
2775 oberon_generator_init_var(ctx, x);
2776 break;
2777 case OBERON_CLASS_PARAM:
2778 case OBERON_CLASS_VAR_PARAM:
2779 oberon_initialize_type(ctx, x -> type);
2780 oberon_generator_init_var(ctx, x);
2781 break;
2782 case OBERON_CLASS_CONST:
2783 case OBERON_CLASS_PROC:
2784 case OBERON_CLASS_MODULE:
2785 break;
2786 default:
2787 oberon_error(ctx, "oberon_initialize_object: wat");
2788 break;
2789 }
2790 }
2791
2792 static void
2793 oberon_initialize_decl(oberon_context_t * ctx)
2794 {
2795 oberon_object_t * x = ctx -> decl -> list;
2796
2797 while(x -> next)
2798 {
2799 oberon_initialize_object(ctx, x -> next);
2800 x = x -> next;
2801 }
2802 }
2803
2804 static void
2805 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2806 {
2807 oberon_object_t * x = ctx -> decl -> list;
2808
2809 while(x -> next)
2810 {
2811 if(x -> next -> class == OBERON_CLASS_PROC)
2812 {
2813 if(x -> next -> linked == 0)
2814 {
2815 oberon_error(ctx, "unresolved forward declaration");
2816 }
2817 }
2818 x = x -> next;
2819 }
2820 }
2821
2822 static void
2823 oberon_decl_seq(oberon_context_t * ctx)
2824 {
2825 if(ctx -> token == CONST)
2826 {
2827 oberon_assert_token(ctx, CONST);
2828 while(ctx -> token == IDENT)
2829 {
2830 oberon_const_decl(ctx);
2831 oberon_assert_token(ctx, SEMICOLON);
2832 }
2833 }
2834
2835 if(ctx -> token == TYPE)
2836 {
2837 oberon_assert_token(ctx, TYPE);
2838 while(ctx -> token == IDENT)
2839 {
2840 oberon_type_decl(ctx);
2841 oberon_assert_token(ctx, SEMICOLON);
2842 }
2843 }
2844
2845 if(ctx -> token == VAR)
2846 {
2847 oberon_assert_token(ctx, VAR);
2848 while(ctx -> token == IDENT)
2849 {
2850 oberon_var_decl(ctx);
2851 oberon_assert_token(ctx, SEMICOLON);
2852 }
2853 }
2854
2855 oberon_prevent_recursive_decl(ctx);
2856 oberon_initialize_decl(ctx);
2857
2858 while(ctx -> token == PROCEDURE)
2859 {
2860 oberon_proc_decl(ctx);
2861 oberon_assert_token(ctx, SEMICOLON);
2862 }
2863
2864 oberon_prevent_undeclarated_procedures(ctx);
2865 }
2866
2867 static void
2868 oberon_statement_seq(oberon_context_t * ctx);
2869
2870 static void
2871 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2872 {
2873 if(dst -> read_only)
2874 {
2875 oberon_error(ctx, "read-only destination");
2876 }
2877
2878 src = oberon_autocast_to(ctx, src, dst -> result);
2879 oberon_generate_assign(ctx, src, dst);
2880 }
2881
2882 static void
2883 oberon_statement(oberon_context_t * ctx)
2884 {
2885 oberon_expr_t * item1;
2886 oberon_expr_t * item2;
2887
2888 if(ctx -> token == IDENT)
2889 {
2890 item1 = oberon_designator(ctx);
2891 if(ctx -> token == ASSIGN)
2892 {
2893 oberon_assert_token(ctx, ASSIGN);
2894 item2 = oberon_expr(ctx);
2895 oberon_assign(ctx, item2, item1);
2896 }
2897 else
2898 {
2899 oberon_opt_proc_parens(ctx, item1);
2900 }
2901 }
2902 else if(ctx -> token == IF)
2903 {
2904 gen_label_t * end;
2905 gen_label_t * els;
2906 oberon_expr_t * cond;
2907
2908 els = oberon_generator_reserve_label(ctx);
2909 end = oberon_generator_reserve_label(ctx);
2910
2911 oberon_assert_token(ctx, IF);
2912 cond = oberon_expr(ctx);
2913 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
2914 {
2915 oberon_error(ctx, "condition must be boolean");
2916 }
2917 oberon_assert_token(ctx, THEN);
2918 oberon_generate_branch(ctx, cond, false, els);
2919 oberon_statement_seq(ctx);
2920 oberon_generate_goto(ctx, end);
2921
2922 oberon_generate_label(ctx, els);
2923 if(ctx -> token == ELSE)
2924 {
2925 oberon_assert_token(ctx, ELSE);
2926 oberon_statement_seq(ctx);
2927 }
2928
2929 oberon_generate_label(ctx, end);
2930 oberon_assert_token(ctx, END);
2931 }
2932 else if(ctx -> token == RETURN)
2933 {
2934 oberon_assert_token(ctx, RETURN);
2935 if(ISEXPR(ctx -> token))
2936 {
2937 oberon_expr_t * expr;
2938 expr = oberon_expr(ctx);
2939 oberon_make_return(ctx, expr);
2940 }
2941 else
2942 {
2943 oberon_make_return(ctx, NULL);
2944 }
2945 }
2946 }
2947
2948 static void
2949 oberon_statement_seq(oberon_context_t * ctx)
2950 {
2951 oberon_statement(ctx);
2952 while(ctx -> token == SEMICOLON)
2953 {
2954 oberon_assert_token(ctx, SEMICOLON);
2955 oberon_statement(ctx);
2956 }
2957 }
2958
2959 static void
2960 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
2961 {
2962 oberon_module_t * m = ctx -> module_list;
2963 while(m && strcmp(m -> name, name) != 0)
2964 {
2965 m = m -> next;
2966 }
2967
2968 if(m == NULL)
2969 {
2970 const char * code;
2971 code = ctx -> import_module(name);
2972 if(code == NULL)
2973 {
2974 oberon_error(ctx, "no such module");
2975 }
2976
2977 m = oberon_compile_module(ctx, code);
2978 assert(m);
2979 }
2980
2981 if(m -> ready == 0)
2982 {
2983 oberon_error(ctx, "cyclic module import");
2984 }
2985
2986 oberon_object_t * ident;
2987 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
2988 ident -> module = m;
2989 }
2990
2991 static void
2992 oberon_import_decl(oberon_context_t * ctx)
2993 {
2994 char * alias;
2995 char * name;
2996
2997 alias = name = oberon_assert_ident(ctx);
2998 if(ctx -> token == ASSIGN)
2999 {
3000 oberon_assert_token(ctx, ASSIGN);
3001 name = oberon_assert_ident(ctx);
3002 }
3003
3004 oberon_import_module(ctx, alias, name);
3005 }
3006
3007 static void
3008 oberon_import_list(oberon_context_t * ctx)
3009 {
3010 oberon_assert_token(ctx, IMPORT);
3011
3012 oberon_import_decl(ctx);
3013 while(ctx -> token == COMMA)
3014 {
3015 oberon_assert_token(ctx, COMMA);
3016 oberon_import_decl(ctx);
3017 }
3018
3019 oberon_assert_token(ctx, SEMICOLON);
3020 }
3021
3022 static void
3023 oberon_parse_module(oberon_context_t * ctx)
3024 {
3025 char * name1;
3026 char * name2;
3027 oberon_read_token(ctx);
3028
3029 oberon_assert_token(ctx, MODULE);
3030 name1 = oberon_assert_ident(ctx);
3031 oberon_assert_token(ctx, SEMICOLON);
3032 ctx -> mod -> name = name1;
3033
3034 oberon_generator_init_module(ctx, ctx -> mod);
3035
3036 if(ctx -> token == IMPORT)
3037 {
3038 oberon_import_list(ctx);
3039 }
3040
3041 oberon_decl_seq(ctx);
3042
3043 oberon_generate_begin_module(ctx);
3044 if(ctx -> token == BEGIN)
3045 {
3046 oberon_assert_token(ctx, BEGIN);
3047 oberon_statement_seq(ctx);
3048 }
3049 oberon_generate_end_module(ctx);
3050
3051 oberon_assert_token(ctx, END);
3052 name2 = oberon_assert_ident(ctx);
3053 oberon_assert_token(ctx, DOT);
3054
3055 if(strcmp(name1, name2) != 0)
3056 {
3057 oberon_error(ctx, "module name not matched");
3058 }
3059
3060 oberon_generator_fini_module(ctx -> mod);
3061 }
3062
3063 // =======================================================================
3064 // LIBRARY
3065 // =======================================================================
3066
3067 static void
3068 register_default_types(oberon_context_t * ctx)
3069 {
3070 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
3071 oberon_generator_init_type(ctx, ctx -> void_type);
3072
3073 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
3074 ctx -> void_ptr_type -> base = ctx -> void_type;
3075 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
3076
3077 ctx -> string_type = oberon_new_type_string(1);
3078 oberon_generator_init_type(ctx, ctx -> string_type);
3079
3080 ctx -> bool_type = oberon_new_type_boolean();
3081 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
3082
3083 ctx -> byte_type = oberon_new_type_integer(1);
3084 oberon_define_type(ctx -> world_scope, "BYTE", ctx -> byte_type, 1);
3085
3086 ctx -> shortint_type = oberon_new_type_integer(2);
3087 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> shortint_type, 1);
3088
3089 ctx -> int_type = oberon_new_type_integer(4);
3090 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
3091
3092 ctx -> longint_type = oberon_new_type_integer(8);
3093 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> longint_type, 1);
3094
3095 ctx -> real_type = oberon_new_type_real(4);
3096 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
3097
3098 ctx -> longreal_type = oberon_new_type_real(8);
3099 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
3100
3101 ctx -> char_type = oberon_new_type_char(1);
3102 oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1);
3103 }
3104
3105 static void
3106 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
3107 {
3108 oberon_object_t * proc;
3109 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
3110 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
3111 proc -> type -> sysproc = true;
3112 proc -> type -> genfunc = f;
3113 proc -> type -> genproc = p;
3114 }
3115
3116 static oberon_expr_t *
3117 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3118 {
3119 if(num_args < 1)
3120 {
3121 oberon_error(ctx, "too few arguments");
3122 }
3123
3124 if(num_args > 1)
3125 {
3126 oberon_error(ctx, "too mach arguments");
3127 }
3128
3129 oberon_expr_t * arg;
3130 arg = list_args;
3131
3132 oberon_type_t * result_type;
3133 result_type = arg -> result;
3134
3135 if(result_type -> class != OBERON_TYPE_INTEGER)
3136 {
3137 oberon_error(ctx, "ABS accepts only integers");
3138 }
3139
3140
3141 oberon_expr_t * expr;
3142 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
3143 return expr;
3144 }
3145
3146 static void
3147 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3148 {
3149 if(num_args < 1)
3150 {
3151 oberon_error(ctx, "too few arguments");
3152 }
3153
3154 oberon_expr_t * dst;
3155 dst = list_args;
3156
3157 oberon_type_t * type;
3158 type = dst -> result;
3159
3160 if(type -> class != OBERON_TYPE_POINTER)
3161 {
3162 oberon_error(ctx, "not a pointer");
3163 }
3164
3165 type = type -> base;
3166
3167 oberon_expr_t * src;
3168 src = oberon_new_item(MODE_NEW, dst -> result, 0);
3169 src -> item.num_args = 0;
3170 src -> item.args = NULL;
3171
3172 int max_args = 1;
3173 if(type -> class == OBERON_TYPE_ARRAY)
3174 {
3175 if(type -> size == 0)
3176 {
3177 oberon_type_t * x = type;
3178 while(x -> class == OBERON_TYPE_ARRAY)
3179 {
3180 if(x -> size == 0)
3181 {
3182 max_args += 1;
3183 }
3184 x = x -> base;
3185 }
3186 }
3187
3188 if(num_args < max_args)
3189 {
3190 oberon_error(ctx, "too few arguments");
3191 }
3192
3193 if(num_args > max_args)
3194 {
3195 oberon_error(ctx, "too mach arguments");
3196 }
3197
3198 int num_sizes = max_args - 1;
3199 oberon_expr_t * size_list = list_args -> next;
3200
3201 oberon_expr_t * arg = size_list;
3202 for(int i = 0; i < max_args - 1; i++)
3203 {
3204 if(arg -> result -> class != OBERON_TYPE_INTEGER)
3205 {
3206 oberon_error(ctx, "size must be integer");
3207 }
3208 arg = arg -> next;
3209 }
3210
3211 src -> item.num_args = num_sizes;
3212 src -> item.args = size_list;
3213 }
3214 else if(type -> class != OBERON_TYPE_RECORD)
3215 {
3216 oberon_error(ctx, "oberon_make_new_call: wat");
3217 }
3218
3219 if(num_args > max_args)
3220 {
3221 oberon_error(ctx, "too mach arguments");
3222 }
3223
3224 oberon_assign(ctx, src, dst);
3225 }
3226
3227 oberon_context_t *
3228 oberon_create_context(ModuleImportCallback import_module)
3229 {
3230 oberon_context_t * ctx = calloc(1, sizeof *ctx);
3231
3232 oberon_scope_t * world_scope;
3233 world_scope = oberon_open_scope(ctx);
3234 ctx -> world_scope = world_scope;
3235
3236 ctx -> import_module = import_module;
3237
3238 oberon_generator_init_context(ctx);
3239
3240 register_default_types(ctx);
3241 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
3242 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
3243
3244 return ctx;
3245 }
3246
3247 void
3248 oberon_destroy_context(oberon_context_t * ctx)
3249 {
3250 oberon_generator_destroy_context(ctx);
3251 free(ctx);
3252 }
3253
3254 oberon_module_t *
3255 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
3256 {
3257 const char * code = ctx -> code;
3258 int code_index = ctx -> code_index;
3259 char c = ctx -> c;
3260 int token = ctx -> token;
3261 char * string = ctx -> string;
3262 int integer = ctx -> integer;
3263 int real = ctx -> real;
3264 bool longmode = ctx -> longmode;
3265 oberon_scope_t * decl = ctx -> decl;
3266 oberon_module_t * mod = ctx -> mod;
3267
3268 oberon_scope_t * module_scope;
3269 module_scope = oberon_open_scope(ctx);
3270
3271 oberon_module_t * module;
3272 module = calloc(1, sizeof *module);
3273 module -> decl = module_scope;
3274 module -> next = ctx -> module_list;
3275
3276 ctx -> mod = module;
3277 ctx -> module_list = module;
3278
3279 oberon_init_scaner(ctx, newcode);
3280 oberon_parse_module(ctx);
3281
3282 module -> ready = 1;
3283
3284 ctx -> code = code;
3285 ctx -> code_index = code_index;
3286 ctx -> c = c;
3287 ctx -> token = token;
3288 ctx -> string = string;
3289 ctx -> integer = integer;
3290 ctx -> real = real;
3291 ctx -> longmode = longmode;
3292 ctx -> decl = decl;
3293 ctx -> mod = mod;
3294
3295 return module;
3296 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024