DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / dsw-obn.git / blob


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