DEADSOFTWARE

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


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