DEADSOFTWARE

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


50429645b22a713480253b1fb262128dc1b97af6
[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 == IS)
1818 {
1819 oberon_type_t * v = a -> result;
1820 if(v -> class == OBERON_TYPE_POINTER)
1821 {
1822 v = v -> base;
1823 if(v -> class != OBERON_TYPE_RECORD)
1824 {
1825 oberon_error(ctx, "must be record");
1826 }
1827 }
1828 else if(v -> class != OBERON_TYPE_RECORD)
1829 {
1830 oberon_error(ctx, "must be record");
1831 }
1832
1833 if(b -> is_item == false || b -> item.mode != MODE_TYPE)
1834 {
1835 oberon_error(ctx, "requires type");
1836 }
1837
1838 oberon_type_t * t = b -> result;
1839 if(t -> class == OBERON_TYPE_POINTER)
1840 {
1841 t = t -> base;
1842 if(t -> class != OBERON_TYPE_RECORD)
1843 {
1844 oberon_error(ctx, "must be record");
1845 }
1846 }
1847 else if(t -> class != OBERON_TYPE_RECORD)
1848 {
1849 oberon_error(ctx, "must be record");
1850 }
1851
1852 result = ctx -> bool_type;
1853 expr = oberon_new_operator(OP_IS, result, a, b);
1854 }
1855 else if(ITMAKESBOOLEAN(token))
1856 {
1857 if(ITUSEONLYINTEGER(token))
1858 {
1859 if(a -> result -> class == OBERON_TYPE_INTEGER
1860 || b -> result -> class == OBERON_TYPE_INTEGER
1861 || a -> result -> class == OBERON_TYPE_REAL
1862 || b -> result -> class == OBERON_TYPE_REAL)
1863 {
1864 // accept
1865 }
1866 else
1867 {
1868 oberon_error(ctx, "used only with numeric types");
1869 }
1870 }
1871 else if(ITUSEONLYBOOLEAN(token))
1872 {
1873 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1874 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1875 {
1876 oberon_error(ctx, "used only with boolean type");
1877 }
1878 }
1879
1880 oberon_autocast_binary_op(ctx, &a, &b);
1881 result = ctx -> bool_type;
1882
1883 if(token == EQUAL)
1884 {
1885 expr = oberon_new_operator(OP_EQ, result, a, b);
1886 }
1887 else if(token == NEQ)
1888 {
1889 expr = oberon_new_operator(OP_NEQ, result, a, b);
1890 }
1891 else if(token == LESS)
1892 {
1893 expr = oberon_new_operator(OP_LSS, result, a, b);
1894 }
1895 else if(token == LEQ)
1896 {
1897 expr = oberon_new_operator(OP_LEQ, result, a, b);
1898 }
1899 else if(token == GREAT)
1900 {
1901 expr = oberon_new_operator(OP_GRT, result, a, b);
1902 }
1903 else if(token == GEQ)
1904 {
1905 expr = oberon_new_operator(OP_GEQ, result, a, b);
1906 }
1907 else if(token == OR)
1908 {
1909 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1910 }
1911 else if(token == AND)
1912 {
1913 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1914 }
1915 else
1916 {
1917 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1918 }
1919 }
1920 else if(token == SLASH)
1921 {
1922 if(a -> result -> class == OBERON_TYPE_SET
1923 || b -> result -> class == OBERON_TYPE_SET)
1924 {
1925 oberon_autocast_binary_op(ctx, &a, &b);
1926 result = a -> result;
1927 expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b);
1928 }
1929 else
1930 {
1931 oberon_autocast_to_real(ctx, &a);
1932 oberon_autocast_to_real(ctx, &b);
1933 oberon_autocast_binary_op(ctx, &a, &b);
1934 result = a -> result;
1935 expr = oberon_new_operator(OP_DIV, result, a, b);
1936 }
1937 }
1938 else if(token == DIV)
1939 {
1940 if(a -> result -> class != OBERON_TYPE_INTEGER
1941 || b -> result -> class != OBERON_TYPE_INTEGER)
1942 {
1943 oberon_error(ctx, "operator DIV requires integer type");
1944 }
1945
1946 oberon_autocast_binary_op(ctx, &a, &b);
1947 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1948 }
1949 else
1950 {
1951 oberon_autocast_binary_op(ctx, &a, &b);
1952 result = a -> result;
1953 if(result -> class == OBERON_TYPE_SET)
1954 {
1955 switch(token)
1956 {
1957 case PLUS:
1958 expr = oberon_new_operator(OP_UNION, result, a, b);
1959 break;
1960 case MINUS:
1961 expr = oberon_new_operator(OP_DIFFERENCE, result, a, b);
1962 break;
1963 case STAR:
1964 expr = oberon_new_operator(OP_INTERSECTION, result, a, b);
1965 break;
1966 default:
1967 error = true;
1968 break;
1969 }
1970 }
1971 else if(result -> class == OBERON_TYPE_INTEGER
1972 || result -> class == OBERON_TYPE_REAL)
1973 {
1974 switch(token)
1975 {
1976 case PLUS:
1977 expr = oberon_new_operator(OP_ADD, result, a, b);
1978 break;
1979 case MINUS:
1980 expr = oberon_new_operator(OP_SUB, result, a, b);
1981 break;
1982 case STAR:
1983 expr = oberon_new_operator(OP_MUL, result, a, b);
1984 break;
1985 case MOD:
1986 expr = oberon_new_operator(OP_MOD, result, a, b);
1987 break;
1988 default:
1989 error = true;
1990 break;
1991 }
1992 }
1993 else
1994 {
1995 error = true;
1996 }
1997 }
1998
1999 if(error)
2000 {
2001 oberon_error(ctx, "invalid operation");
2002 }
2003
2004 return expr;
2005 }
2006
2007 #define ISMULOP(x) \
2008 ((x) >= STAR && (x) <= AND)
2009
2010 static oberon_expr_t *
2011 oberon_term_expr(oberon_context_t * ctx)
2012 {
2013 oberon_expr_t * expr;
2014
2015 expr = oberon_factor(ctx);
2016 while(ISMULOP(ctx -> token))
2017 {
2018 int token = ctx -> token;
2019 oberon_read_token(ctx);
2020
2021 oberon_expr_t * inter = oberon_factor(ctx);
2022 expr = oberon_make_bin_op(ctx, token, expr, inter);
2023 }
2024
2025 return expr;
2026 }
2027
2028 #define ISADDOP(x) \
2029 ((x) >= PLUS && (x) <= OR)
2030
2031 static oberon_expr_t *
2032 oberon_simple_expr(oberon_context_t * ctx)
2033 {
2034 oberon_expr_t * expr;
2035
2036 int minus = 0;
2037 if(ctx -> token == PLUS)
2038 {
2039 minus = 0;
2040 oberon_assert_token(ctx, PLUS);
2041 }
2042 else if(ctx -> token == MINUS)
2043 {
2044 minus = 1;
2045 oberon_assert_token(ctx, MINUS);
2046 }
2047
2048 expr = oberon_term_expr(ctx);
2049
2050 if(minus)
2051 {
2052 expr = oberon_make_unary_op(ctx, MINUS, expr);
2053 }
2054
2055 while(ISADDOP(ctx -> token))
2056 {
2057 int token = ctx -> token;
2058 oberon_read_token(ctx);
2059
2060 oberon_expr_t * inter = oberon_term_expr(ctx);
2061 expr = oberon_make_bin_op(ctx, token, expr, inter);
2062 }
2063
2064 return expr;
2065 }
2066
2067 #define ISRELATION(x) \
2068 ((x) >= EQUAL && (x) <= IS)
2069
2070 static oberon_expr_t *
2071 oberon_expr(oberon_context_t * ctx)
2072 {
2073 oberon_expr_t * expr;
2074
2075 expr = oberon_simple_expr(ctx);
2076 while(ISRELATION(ctx -> token))
2077 {
2078 int token = ctx -> token;
2079 oberon_read_token(ctx);
2080
2081 oberon_expr_t * inter = oberon_simple_expr(ctx);
2082 expr = oberon_make_bin_op(ctx, token, expr, inter);
2083 }
2084
2085 return expr;
2086 }
2087
2088 static oberon_item_t *
2089 oberon_const_expr(oberon_context_t * ctx)
2090 {
2091 oberon_expr_t * expr;
2092 expr = oberon_expr(ctx);
2093
2094 if(expr -> is_item == 0)
2095 {
2096 oberon_error(ctx, "const expression are required");
2097 }
2098
2099 switch(expr -> item.mode)
2100 {
2101 case MODE_INTEGER:
2102 case MODE_BOOLEAN:
2103 case MODE_NIL:
2104 case MODE_REAL:
2105 case MODE_CHAR:
2106 case MODE_STRING:
2107 case MODE_TYPE:
2108 /* accept */
2109 break;
2110 default:
2111 oberon_error(ctx, "const expression are required");
2112 break;
2113 }
2114
2115 return (oberon_item_t *) expr;
2116 }
2117
2118 // =======================================================================
2119 // PARSER
2120 // =======================================================================
2121
2122 static void oberon_decl_seq(oberon_context_t * ctx);
2123 static void oberon_statement_seq(oberon_context_t * ctx);
2124 static void oberon_initialize_decl(oberon_context_t * ctx);
2125
2126 static void
2127 oberon_expect_token(oberon_context_t * ctx, int token)
2128 {
2129 if(ctx -> token != token)
2130 {
2131 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
2132 }
2133 }
2134
2135 static void
2136 oberon_assert_token(oberon_context_t * ctx, int token)
2137 {
2138 oberon_expect_token(ctx, token);
2139 oberon_read_token(ctx);
2140 }
2141
2142 static char *
2143 oberon_assert_ident(oberon_context_t * ctx)
2144 {
2145 oberon_expect_token(ctx, IDENT);
2146 char * ident = ctx -> string;
2147 oberon_read_token(ctx);
2148 return ident;
2149 }
2150
2151 static void
2152 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
2153 {
2154 switch(ctx -> token)
2155 {
2156 case STAR:
2157 oberon_assert_token(ctx, STAR);
2158 *export = 1;
2159 *read_only = 0;
2160 break;
2161 case MINUS:
2162 oberon_assert_token(ctx, MINUS);
2163 *export = 1;
2164 *read_only = 1;
2165 break;
2166 default:
2167 *export = 0;
2168 *read_only = 0;
2169 break;
2170 }
2171 }
2172
2173 static oberon_object_t *
2174 oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
2175 {
2176 char * name;
2177 int export;
2178 int read_only;
2179 oberon_object_t * x;
2180
2181 name = oberon_assert_ident(ctx);
2182 oberon_def(ctx, &export, &read_only);
2183
2184 x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
2185 return x;
2186 }
2187
2188 static void
2189 oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
2190 {
2191 *num = 1;
2192 *list = oberon_ident_def(ctx, class, check_upscope);
2193 while(ctx -> token == COMMA)
2194 {
2195 oberon_assert_token(ctx, COMMA);
2196 oberon_ident_def(ctx, class, check_upscope);
2197 *num += 1;
2198 }
2199 }
2200
2201 static void
2202 oberon_var_decl(oberon_context_t * ctx)
2203 {
2204 int num;
2205 oberon_object_t * list;
2206 oberon_type_t * type;
2207 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2208
2209 oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
2210 oberon_assert_token(ctx, COLON);
2211 oberon_type(ctx, &type);
2212
2213 oberon_object_t * var = list;
2214 for(int i = 0; i < num; i++)
2215 {
2216 var -> type = type;
2217 var = var -> next;
2218 }
2219 }
2220
2221 static oberon_object_t *
2222 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
2223 {
2224 int class = OBERON_CLASS_PARAM;
2225 if(ctx -> token == VAR)
2226 {
2227 oberon_read_token(ctx);
2228 class = OBERON_CLASS_VAR_PARAM;
2229 }
2230
2231 int num;
2232 oberon_object_t * list;
2233 oberon_ident_list(ctx, class, false, &num, &list);
2234
2235 oberon_assert_token(ctx, COLON);
2236
2237 oberon_type_t * type;
2238 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2239 oberon_type(ctx, &type);
2240
2241 oberon_object_t * param = list;
2242 for(int i = 0; i < num; i++)
2243 {
2244 param -> type = type;
2245 param = param -> next;
2246 }
2247
2248 *num_decl += num;
2249 return list;
2250 }
2251
2252 #define ISFPSECTION \
2253 ((ctx -> token == VAR) || (ctx -> token == IDENT))
2254
2255 static void
2256 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
2257 {
2258 oberon_assert_token(ctx, LPAREN);
2259
2260 if(ISFPSECTION)
2261 {
2262 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
2263 while(ctx -> token == SEMICOLON)
2264 {
2265 oberon_assert_token(ctx, SEMICOLON);
2266 oberon_fp_section(ctx, &signature -> num_decl);
2267 }
2268 }
2269
2270 oberon_assert_token(ctx, RPAREN);
2271
2272 if(ctx -> token == COLON)
2273 {
2274 oberon_assert_token(ctx, COLON);
2275
2276 oberon_object_t * typeobj;
2277 typeobj = oberon_qualident(ctx, NULL, 1);
2278 if(typeobj -> class != OBERON_CLASS_TYPE)
2279 {
2280 oberon_error(ctx, "function result is not type");
2281 }
2282 signature -> base = typeobj -> type;
2283 }
2284 }
2285
2286 static void
2287 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
2288 {
2289 oberon_type_t * signature;
2290 signature = *type;
2291 signature -> class = OBERON_TYPE_PROCEDURE;
2292 signature -> num_decl = 0;
2293 signature -> base = ctx -> void_type;
2294 signature -> decl = NULL;
2295
2296 if(ctx -> token == LPAREN)
2297 {
2298 oberon_formal_pars(ctx, signature);
2299 }
2300 }
2301
2302 static void
2303 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
2304 {
2305 if(a -> num_decl != b -> num_decl)
2306 {
2307 oberon_error(ctx, "number parameters not matched");
2308 }
2309
2310 int num_param = a -> num_decl;
2311 oberon_object_t * param_a = a -> decl;
2312 oberon_object_t * param_b = b -> decl;
2313 for(int i = 0; i < num_param; i++)
2314 {
2315 if(strcmp(param_a -> name, param_b -> name) != 0)
2316 {
2317 oberon_error(ctx, "param %i name not matched", i + 1);
2318 }
2319
2320 if(param_a -> type != param_b -> type)
2321 {
2322 oberon_error(ctx, "param %i type not matched", i + 1);
2323 }
2324
2325 param_a = param_a -> next;
2326 param_b = param_b -> next;
2327 }
2328 }
2329
2330 static void
2331 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
2332 {
2333 oberon_object_t * proc = ctx -> decl -> parent;
2334 oberon_type_t * result_type = proc -> type -> base;
2335
2336 if(result_type -> class == OBERON_TYPE_VOID)
2337 {
2338 if(expr != NULL)
2339 {
2340 oberon_error(ctx, "procedure has no result type");
2341 }
2342 }
2343 else
2344 {
2345 if(expr == NULL)
2346 {
2347 oberon_error(ctx, "procedure requires expression on result");
2348 }
2349
2350 expr = oberon_autocast_to(ctx, expr, result_type);
2351 }
2352
2353 proc -> has_return = 1;
2354
2355 oberon_generate_return(ctx, expr);
2356 }
2357
2358 static void
2359 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
2360 {
2361 oberon_assert_token(ctx, SEMICOLON);
2362
2363 ctx -> decl = proc -> scope;
2364
2365 oberon_decl_seq(ctx);
2366
2367 oberon_generate_begin_proc(ctx, proc);
2368
2369 if(ctx -> token == BEGIN)
2370 {
2371 oberon_assert_token(ctx, BEGIN);
2372 oberon_statement_seq(ctx);
2373 }
2374
2375 oberon_assert_token(ctx, END);
2376 char * name = oberon_assert_ident(ctx);
2377 if(strcmp(name, proc -> name) != 0)
2378 {
2379 oberon_error(ctx, "procedure name not matched");
2380 }
2381
2382 if(proc -> type -> base -> class == OBERON_TYPE_VOID
2383 && proc -> has_return == 0)
2384 {
2385 oberon_make_return(ctx, NULL);
2386 }
2387
2388 if(proc -> has_return == 0)
2389 {
2390 oberon_error(ctx, "procedure requires return");
2391 }
2392
2393 oberon_generate_end_proc(ctx);
2394 oberon_close_scope(ctx -> decl);
2395 }
2396
2397 static void
2398 oberon_proc_decl(oberon_context_t * ctx)
2399 {
2400 oberon_assert_token(ctx, PROCEDURE);
2401
2402 int forward = 0;
2403 if(ctx -> token == UPARROW)
2404 {
2405 oberon_assert_token(ctx, UPARROW);
2406 forward = 1;
2407 }
2408
2409 char * name;
2410 int export;
2411 int read_only;
2412 name = oberon_assert_ident(ctx);
2413 oberon_def(ctx, &export, &read_only);
2414
2415 oberon_scope_t * proc_scope;
2416 proc_scope = oberon_open_scope(ctx);
2417 ctx -> decl -> local = 1;
2418
2419 oberon_type_t * signature;
2420 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
2421 oberon_opt_formal_pars(ctx, &signature);
2422
2423 oberon_initialize_decl(ctx);
2424 oberon_generator_init_type(ctx, signature);
2425 oberon_close_scope(ctx -> decl);
2426
2427 oberon_object_t * proc;
2428 proc = oberon_find_object(ctx -> decl, name, 0);
2429 if(proc != NULL)
2430 {
2431 if(proc -> class != OBERON_CLASS_PROC)
2432 {
2433 oberon_error(ctx, "mult definition");
2434 }
2435
2436 if(forward == 0)
2437 {
2438 if(proc -> linked)
2439 {
2440 oberon_error(ctx, "mult procedure definition");
2441 }
2442 }
2443
2444 if(proc -> export != export || proc -> read_only != read_only)
2445 {
2446 oberon_error(ctx, "export type not matched");
2447 }
2448
2449 oberon_compare_signatures(ctx, proc -> type, signature);
2450 }
2451 else
2452 {
2453 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
2454 proc -> type = signature;
2455 proc -> scope = proc_scope;
2456 oberon_generator_init_proc(ctx, proc);
2457 }
2458
2459 proc -> scope -> parent = proc;
2460
2461 if(forward == 0)
2462 {
2463 proc -> linked = 1;
2464 oberon_proc_decl_body(ctx, proc);
2465 }
2466 }
2467
2468 static void
2469 oberon_const_decl(oberon_context_t * ctx)
2470 {
2471 oberon_item_t * value;
2472 oberon_object_t * constant;
2473
2474 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
2475 oberon_assert_token(ctx, EQUAL);
2476 value = oberon_const_expr(ctx);
2477 constant -> value = value;
2478 }
2479
2480 static void
2481 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
2482 {
2483 if(size -> is_item == 0)
2484 {
2485 oberon_error(ctx, "requires constant");
2486 }
2487
2488 if(size -> item.mode != MODE_INTEGER)
2489 {
2490 oberon_error(ctx, "requires integer constant");
2491 }
2492
2493 oberon_type_t * arr;
2494 arr = *type;
2495 arr -> class = OBERON_TYPE_ARRAY;
2496 arr -> size = size -> item.integer;
2497 arr -> base = base;
2498 }
2499
2500 static void
2501 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2502 {
2503 char * name;
2504 oberon_object_t * to;
2505
2506 to = oberon_qualident(ctx, &name, 0);
2507
2508 //name = oberon_assert_ident(ctx);
2509 //to = oberon_find_object(ctx -> decl, name, 0);
2510
2511 if(to != NULL)
2512 {
2513 if(to -> class != OBERON_CLASS_TYPE)
2514 {
2515 oberon_error(ctx, "not a type");
2516 }
2517 }
2518 else
2519 {
2520 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2521 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2522 }
2523
2524 *type = to -> type;
2525 }
2526
2527 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2528
2529 /*
2530 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2531 */
2532
2533 static void
2534 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2535 {
2536 if(sizes == NULL)
2537 {
2538 *type = base;
2539 return;
2540 }
2541
2542 oberon_type_t * dim;
2543 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2544
2545 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2546
2547 oberon_make_array_type(ctx, sizes, dim, type);
2548 }
2549
2550 static void
2551 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2552 {
2553 type -> class = OBERON_TYPE_ARRAY;
2554 type -> size = 0;
2555 type -> base = base;
2556 }
2557
2558 static void
2559 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2560 {
2561 if(ctx -> token == IDENT)
2562 {
2563 int num;
2564 oberon_object_t * list;
2565 oberon_type_t * type;
2566 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2567
2568 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2569 oberon_assert_token(ctx, COLON);
2570
2571 oberon_scope_t * current = ctx -> decl;
2572 ctx -> decl = modscope;
2573 oberon_type(ctx, &type);
2574 ctx -> decl = current;
2575
2576 oberon_object_t * field = list;
2577 for(int i = 0; i < num; i++)
2578 {
2579 field -> type = type;
2580 field = field -> next;
2581 }
2582
2583 rec -> num_decl += num;
2584 }
2585 }
2586
2587 static void
2588 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2589 {
2590 oberon_scope_t * modscope = ctx -> mod -> decl;
2591 oberon_scope_t * oldscope = ctx -> decl;
2592 ctx -> decl = modscope;
2593
2594 if(ctx -> token == LPAREN)
2595 {
2596 oberon_assert_token(ctx, LPAREN);
2597
2598 oberon_object_t * typeobj;
2599 typeobj = oberon_qualident(ctx, NULL, true);
2600
2601 if(typeobj -> class != OBERON_CLASS_TYPE)
2602 {
2603 oberon_error(ctx, "base must be type");
2604 }
2605
2606 oberon_type_t * base = typeobj -> type;
2607 if(base -> class == OBERON_TYPE_POINTER)
2608 {
2609 base = base -> base;
2610 }
2611
2612 if(base -> class != OBERON_TYPE_RECORD)
2613 {
2614 oberon_error(ctx, "base must be record type");
2615 }
2616
2617 rec -> base = base;
2618 ctx -> decl = base -> scope;
2619
2620 oberon_assert_token(ctx, RPAREN);
2621 }
2622 else
2623 {
2624 ctx -> decl = NULL;
2625 }
2626
2627 oberon_scope_t * this_scope;
2628 this_scope = oberon_open_scope(ctx);
2629 this_scope -> local = true;
2630 this_scope -> parent = NULL;
2631 this_scope -> parent_type = rec;
2632
2633 oberon_field_list(ctx, rec, modscope);
2634 while(ctx -> token == SEMICOLON)
2635 {
2636 oberon_assert_token(ctx, SEMICOLON);
2637 oberon_field_list(ctx, rec, modscope);
2638 }
2639
2640 rec -> scope = this_scope;
2641 rec -> decl = this_scope -> list -> next;
2642 ctx -> decl = oldscope;
2643 }
2644
2645 static void
2646 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2647 {
2648 if(ctx -> token == IDENT)
2649 {
2650 oberon_qualident_type(ctx, type);
2651 }
2652 else if(ctx -> token == ARRAY)
2653 {
2654 oberon_assert_token(ctx, ARRAY);
2655
2656 int num_sizes = 0;
2657 oberon_expr_t * sizes;
2658
2659 if(ISEXPR(ctx -> token))
2660 {
2661 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2662 }
2663
2664 oberon_assert_token(ctx, OF);
2665
2666 oberon_type_t * base;
2667 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2668 oberon_type(ctx, &base);
2669
2670 if(num_sizes == 0)
2671 {
2672 oberon_make_open_array(ctx, base, *type);
2673 }
2674 else
2675 {
2676 oberon_make_multiarray(ctx, sizes, base, type);
2677 }
2678 }
2679 else if(ctx -> token == RECORD)
2680 {
2681 oberon_type_t * rec;
2682 rec = *type;
2683 rec -> class = OBERON_TYPE_RECORD;
2684 rec -> module = ctx -> mod;
2685
2686 oberon_assert_token(ctx, RECORD);
2687 oberon_type_record_body(ctx, rec);
2688 oberon_assert_token(ctx, END);
2689
2690 *type = rec;
2691 }
2692 else if(ctx -> token == POINTER)
2693 {
2694 oberon_assert_token(ctx, POINTER);
2695 oberon_assert_token(ctx, TO);
2696
2697 oberon_type_t * base;
2698 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2699 oberon_type(ctx, &base);
2700
2701 oberon_type_t * ptr;
2702 ptr = *type;
2703 ptr -> class = OBERON_TYPE_POINTER;
2704 ptr -> base = base;
2705 }
2706 else if(ctx -> token == PROCEDURE)
2707 {
2708 oberon_open_scope(ctx);
2709 oberon_assert_token(ctx, PROCEDURE);
2710 oberon_opt_formal_pars(ctx, type);
2711 oberon_close_scope(ctx -> decl);
2712 }
2713 else
2714 {
2715 oberon_error(ctx, "invalid type declaration");
2716 }
2717 }
2718
2719 static void
2720 oberon_type_decl(oberon_context_t * ctx)
2721 {
2722 char * name;
2723 oberon_object_t * newtype;
2724 oberon_type_t * type;
2725 int export;
2726 int read_only;
2727
2728 name = oberon_assert_ident(ctx);
2729 oberon_def(ctx, &export, &read_only);
2730
2731 newtype = oberon_find_object(ctx -> decl, name, 0);
2732 if(newtype == NULL)
2733 {
2734 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2735 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2736 assert(newtype -> type);
2737 }
2738 else
2739 {
2740 if(newtype -> class != OBERON_CLASS_TYPE)
2741 {
2742 oberon_error(ctx, "mult definition");
2743 }
2744
2745 if(newtype -> linked)
2746 {
2747 oberon_error(ctx, "mult definition - already linked");
2748 }
2749
2750 newtype -> export = export;
2751 newtype -> read_only = read_only;
2752 }
2753
2754 oberon_assert_token(ctx, EQUAL);
2755
2756 type = newtype -> type;
2757 oberon_type(ctx, &type);
2758
2759 if(type -> class == OBERON_TYPE_VOID)
2760 {
2761 oberon_error(ctx, "recursive alias declaration");
2762 }
2763
2764 newtype -> type = type;
2765 newtype -> linked = 1;
2766 }
2767
2768 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2769 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2770
2771 static void
2772 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2773 {
2774 if(type -> class != OBERON_TYPE_POINTER
2775 && type -> class != OBERON_TYPE_ARRAY)
2776 {
2777 return;
2778 }
2779
2780 if(type -> recursive)
2781 {
2782 oberon_error(ctx, "recursive pointer declaration");
2783 }
2784
2785 if(type -> class == OBERON_TYPE_POINTER
2786 && type -> base -> class == OBERON_TYPE_POINTER)
2787 {
2788 oberon_error(ctx, "attempt to make pointer to pointer");
2789 }
2790
2791 type -> recursive = 1;
2792
2793 oberon_prevent_recursive_pointer(ctx, type -> base);
2794
2795 type -> recursive = 0;
2796 }
2797
2798 static void
2799 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2800 {
2801 if(type -> class != OBERON_TYPE_RECORD)
2802 {
2803 return;
2804 }
2805
2806 if(type -> recursive)
2807 {
2808 oberon_error(ctx, "recursive record declaration");
2809 }
2810
2811 type -> recursive = 1;
2812
2813 int num_fields = type -> num_decl;
2814 oberon_object_t * field = type -> decl;
2815 for(int i = 0; i < num_fields; i++)
2816 {
2817 oberon_prevent_recursive_object(ctx, field);
2818 field = field -> next;
2819 }
2820
2821 type -> recursive = 0;
2822 }
2823 static void
2824 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2825 {
2826 if(type -> class != OBERON_TYPE_PROCEDURE)
2827 {
2828 return;
2829 }
2830
2831 if(type -> recursive)
2832 {
2833 oberon_error(ctx, "recursive procedure declaration");
2834 }
2835
2836 type -> recursive = 1;
2837
2838 int num_fields = type -> num_decl;
2839 oberon_object_t * field = type -> decl;
2840 for(int i = 0; i < num_fields; i++)
2841 {
2842 oberon_prevent_recursive_object(ctx, field);
2843 field = field -> next;
2844 }
2845
2846 type -> recursive = 0;
2847 }
2848
2849 static void
2850 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2851 {
2852 if(type -> class != OBERON_TYPE_ARRAY)
2853 {
2854 return;
2855 }
2856
2857 if(type -> recursive)
2858 {
2859 oberon_error(ctx, "recursive array declaration");
2860 }
2861
2862 type -> recursive = 1;
2863
2864 oberon_prevent_recursive_type(ctx, type -> base);
2865
2866 type -> recursive = 0;
2867 }
2868
2869 static void
2870 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2871 {
2872 if(type -> class == OBERON_TYPE_POINTER)
2873 {
2874 oberon_prevent_recursive_pointer(ctx, type);
2875 }
2876 else if(type -> class == OBERON_TYPE_RECORD)
2877 {
2878 oberon_prevent_recursive_record(ctx, type);
2879 }
2880 else if(type -> class == OBERON_TYPE_ARRAY)
2881 {
2882 oberon_prevent_recursive_array(ctx, type);
2883 }
2884 else if(type -> class == OBERON_TYPE_PROCEDURE)
2885 {
2886 oberon_prevent_recursive_procedure(ctx, type);
2887 }
2888 }
2889
2890 static void
2891 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2892 {
2893 switch(x -> class)
2894 {
2895 case OBERON_CLASS_VAR:
2896 case OBERON_CLASS_TYPE:
2897 case OBERON_CLASS_PARAM:
2898 case OBERON_CLASS_VAR_PARAM:
2899 case OBERON_CLASS_FIELD:
2900 oberon_prevent_recursive_type(ctx, x -> type);
2901 break;
2902 case OBERON_CLASS_CONST:
2903 case OBERON_CLASS_PROC:
2904 case OBERON_CLASS_MODULE:
2905 break;
2906 default:
2907 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2908 break;
2909 }
2910 }
2911
2912 static void
2913 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2914 {
2915 oberon_object_t * x = ctx -> decl -> list -> next;
2916
2917 while(x)
2918 {
2919 oberon_prevent_recursive_object(ctx, x);
2920 x = x -> next;
2921 }
2922 }
2923
2924 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2925 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2926
2927 static void
2928 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2929 {
2930 if(type -> class != OBERON_TYPE_RECORD)
2931 {
2932 return;
2933 }
2934
2935 int num_fields = type -> num_decl;
2936 oberon_object_t * field = type -> decl;
2937 for(int i = 0; i < num_fields; i++)
2938 {
2939 if(field -> type -> class == OBERON_TYPE_POINTER)
2940 {
2941 oberon_initialize_type(ctx, field -> type);
2942 }
2943
2944 oberon_initialize_object(ctx, field);
2945 field = field -> next;
2946 }
2947
2948 oberon_generator_init_record(ctx, type);
2949 }
2950
2951 static void
2952 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2953 {
2954 if(type -> class == OBERON_TYPE_VOID)
2955 {
2956 oberon_error(ctx, "undeclarated type");
2957 }
2958
2959 if(type -> initialized)
2960 {
2961 return;
2962 }
2963
2964 type -> initialized = 1;
2965
2966 if(type -> class == OBERON_TYPE_POINTER)
2967 {
2968 oberon_initialize_type(ctx, type -> base);
2969 oberon_generator_init_type(ctx, type);
2970 }
2971 else if(type -> class == OBERON_TYPE_ARRAY)
2972 {
2973 if(type -> size != 0)
2974 {
2975 if(type -> base -> class == OBERON_TYPE_ARRAY)
2976 {
2977 if(type -> base -> size == 0)
2978 {
2979 oberon_error(ctx, "open array not allowed as array element");
2980 }
2981 }
2982 }
2983
2984 oberon_initialize_type(ctx, type -> base);
2985 oberon_generator_init_type(ctx, type);
2986 }
2987 else if(type -> class == OBERON_TYPE_RECORD)
2988 {
2989 oberon_generator_init_type(ctx, type);
2990 oberon_initialize_record_fields(ctx, type);
2991 }
2992 else if(type -> class == OBERON_TYPE_PROCEDURE)
2993 {
2994 int num_fields = type -> num_decl;
2995 oberon_object_t * field = type -> decl;
2996 for(int i = 0; i < num_fields; i++)
2997 {
2998 oberon_initialize_object(ctx, field);
2999 field = field -> next;
3000 }
3001
3002 oberon_generator_init_type(ctx, type);
3003 }
3004 else
3005 {
3006 oberon_generator_init_type(ctx, type);
3007 }
3008 }
3009
3010 static void
3011 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
3012 {
3013 if(x -> initialized)
3014 {
3015 return;
3016 }
3017
3018 x -> initialized = 1;
3019
3020 switch(x -> class)
3021 {
3022 case OBERON_CLASS_TYPE:
3023 oberon_initialize_type(ctx, x -> type);
3024 break;
3025 case OBERON_CLASS_VAR:
3026 case OBERON_CLASS_FIELD:
3027 if(x -> type -> class == OBERON_TYPE_ARRAY)
3028 {
3029 if(x -> type -> size == 0)
3030 {
3031 oberon_error(ctx, "open array not allowed as variable or field");
3032 }
3033 }
3034 oberon_initialize_type(ctx, x -> type);
3035 oberon_generator_init_var(ctx, x);
3036 break;
3037 case OBERON_CLASS_PARAM:
3038 case OBERON_CLASS_VAR_PARAM:
3039 oberon_initialize_type(ctx, x -> type);
3040 oberon_generator_init_var(ctx, x);
3041 break;
3042 case OBERON_CLASS_CONST:
3043 case OBERON_CLASS_PROC:
3044 case OBERON_CLASS_MODULE:
3045 break;
3046 default:
3047 oberon_error(ctx, "oberon_initialize_object: wat");
3048 break;
3049 }
3050 }
3051
3052 static void
3053 oberon_initialize_decl(oberon_context_t * ctx)
3054 {
3055 oberon_object_t * x = ctx -> decl -> list;
3056
3057 while(x -> next)
3058 {
3059 oberon_initialize_object(ctx, x -> next);
3060 x = x -> next;
3061 }
3062 }
3063
3064 static void
3065 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
3066 {
3067 oberon_object_t * x = ctx -> decl -> list;
3068
3069 while(x -> next)
3070 {
3071 if(x -> next -> class == OBERON_CLASS_PROC)
3072 {
3073 if(x -> next -> linked == 0)
3074 {
3075 oberon_error(ctx, "unresolved forward declaration");
3076 }
3077 }
3078 x = x -> next;
3079 }
3080 }
3081
3082 static void
3083 oberon_decl_seq(oberon_context_t * ctx)
3084 {
3085 if(ctx -> token == CONST)
3086 {
3087 oberon_assert_token(ctx, CONST);
3088 while(ctx -> token == IDENT)
3089 {
3090 oberon_const_decl(ctx);
3091 oberon_assert_token(ctx, SEMICOLON);
3092 }
3093 }
3094
3095 if(ctx -> token == TYPE)
3096 {
3097 oberon_assert_token(ctx, TYPE);
3098 while(ctx -> token == IDENT)
3099 {
3100 oberon_type_decl(ctx);
3101 oberon_assert_token(ctx, SEMICOLON);
3102 }
3103 }
3104
3105 if(ctx -> token == VAR)
3106 {
3107 oberon_assert_token(ctx, VAR);
3108 while(ctx -> token == IDENT)
3109 {
3110 oberon_var_decl(ctx);
3111 oberon_assert_token(ctx, SEMICOLON);
3112 }
3113 }
3114
3115 oberon_prevent_recursive_decl(ctx);
3116 oberon_initialize_decl(ctx);
3117
3118 while(ctx -> token == PROCEDURE)
3119 {
3120 oberon_proc_decl(ctx);
3121 oberon_assert_token(ctx, SEMICOLON);
3122 }
3123
3124 oberon_prevent_undeclarated_procedures(ctx);
3125 }
3126
3127 static oberon_expr_t *
3128 oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type)
3129 {
3130 oberon_object_t * x;
3131 oberon_expr_t * expr;
3132
3133 x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false);
3134 x -> local = true;
3135 x -> type = type;
3136 oberon_generator_init_temp_var(ctx, x);
3137
3138 expr = oberon_new_item(MODE_VAR, type, false);
3139 expr -> item.var = x;
3140 return expr;
3141 }
3142
3143 static void
3144 oberon_statement_seq(oberon_context_t * ctx);
3145
3146 static void
3147 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
3148 {
3149 if(dst -> read_only)
3150 {
3151 oberon_error(ctx, "read-only destination");
3152 }
3153
3154 oberon_check_dst(ctx, dst);
3155 src = oberon_autocast_to(ctx, src, dst -> result);
3156 oberon_generate_assign(ctx, src, dst);
3157 }
3158
3159 static void
3160 oberon_statement(oberon_context_t * ctx)
3161 {
3162 oberon_expr_t * item1;
3163 oberon_expr_t * item2;
3164
3165 if(ctx -> token == IDENT)
3166 {
3167 item1 = oberon_designator(ctx);
3168 if(ctx -> token == ASSIGN)
3169 {
3170 oberon_assert_token(ctx, ASSIGN);
3171 item2 = oberon_expr(ctx);
3172 oberon_assign(ctx, item2, item1);
3173 }
3174 else
3175 {
3176 oberon_opt_proc_parens(ctx, item1);
3177 }
3178 }
3179 else if(ctx -> token == IF)
3180 {
3181 gen_label_t * end;
3182 gen_label_t * els;
3183 oberon_expr_t * cond;
3184
3185 els = oberon_generator_reserve_label(ctx);
3186 end = oberon_generator_reserve_label(ctx);
3187
3188 oberon_assert_token(ctx, IF);
3189 cond = oberon_expr(ctx);
3190 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3191 {
3192 oberon_error(ctx, "condition must be boolean");
3193 }
3194 oberon_assert_token(ctx, THEN);
3195 oberon_generate_branch(ctx, cond, false, els);
3196 oberon_statement_seq(ctx);
3197 oberon_generate_goto(ctx, end);
3198 oberon_generate_label(ctx, els);
3199
3200 while(ctx -> token == ELSIF)
3201 {
3202 els = oberon_generator_reserve_label(ctx);
3203
3204 oberon_assert_token(ctx, ELSIF);
3205 cond = oberon_expr(ctx);
3206 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3207 {
3208 oberon_error(ctx, "condition must be boolean");
3209 }
3210 oberon_assert_token(ctx, THEN);
3211 oberon_generate_branch(ctx, cond, false, els);
3212 oberon_statement_seq(ctx);
3213 oberon_generate_goto(ctx, end);
3214 oberon_generate_label(ctx, els);
3215 }
3216
3217 if(ctx -> token == ELSE)
3218 {
3219 oberon_assert_token(ctx, ELSE);
3220 oberon_statement_seq(ctx);
3221 }
3222
3223 oberon_generate_label(ctx, end);
3224 oberon_assert_token(ctx, END);
3225 }
3226 else if(ctx -> token == WHILE)
3227 {
3228 gen_label_t * begin;
3229 gen_label_t * end;
3230 oberon_expr_t * cond;
3231
3232 begin = oberon_generator_reserve_label(ctx);
3233 end = oberon_generator_reserve_label(ctx);
3234
3235 oberon_assert_token(ctx, WHILE);
3236 oberon_generate_label(ctx, begin);
3237 cond = oberon_expr(ctx);
3238 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3239 {
3240 oberon_error(ctx, "condition must be boolean");
3241 }
3242 oberon_generate_branch(ctx, cond, false, end);
3243
3244 oberon_assert_token(ctx, DO);
3245 oberon_statement_seq(ctx);
3246 oberon_generate_goto(ctx, begin);
3247
3248 oberon_assert_token(ctx, END);
3249 oberon_generate_label(ctx, end);
3250 }
3251 else if(ctx -> token == REPEAT)
3252 {
3253 gen_label_t * begin;
3254 oberon_expr_t * cond;
3255
3256 begin = oberon_generator_reserve_label(ctx);
3257 oberon_generate_label(ctx, begin);
3258 oberon_assert_token(ctx, REPEAT);
3259
3260 oberon_statement_seq(ctx);
3261
3262 oberon_assert_token(ctx, UNTIL);
3263
3264 cond = oberon_expr(ctx);
3265 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3266 {
3267 oberon_error(ctx, "condition must be boolean");
3268 }
3269
3270 oberon_generate_branch(ctx, cond, true, begin);
3271 }
3272 else if(ctx -> token == FOR)
3273 {
3274 oberon_expr_t * from;
3275 oberon_expr_t * index;
3276 oberon_expr_t * to;
3277 oberon_expr_t * bound;
3278 oberon_expr_t * by;
3279 oberon_expr_t * cond;
3280 oberon_expr_t * count;
3281 gen_label_t * begin;
3282 gen_label_t * end;
3283 char * iname;
3284 int op;
3285
3286 begin = oberon_generator_reserve_label(ctx);
3287 end = oberon_generator_reserve_label(ctx);
3288
3289 oberon_assert_token(ctx, FOR);
3290 iname = oberon_assert_ident(ctx);
3291 index = oberon_ident_item(ctx, iname);
3292 oberon_assert_token(ctx, ASSIGN);
3293 from = oberon_expr(ctx);
3294 oberon_assign(ctx, from, index);
3295 oberon_assert_token(ctx, TO);
3296 bound = oberon_make_temp_var_item(ctx, index -> result);
3297 to = oberon_expr(ctx);
3298 oberon_assign(ctx, to, bound);
3299 if(ctx -> token == BY)
3300 {
3301 oberon_assert_token(ctx, BY);
3302 by = (oberon_expr_t *) oberon_const_expr(ctx);
3303 }
3304 else
3305 {
3306 by = oberon_integer_item(ctx, 1);
3307 }
3308
3309 if(by -> result -> class != OBERON_TYPE_INTEGER)
3310 {
3311 oberon_error(ctx, "must be integer");
3312 }
3313
3314 if(by -> item.integer > 0)
3315 {
3316 op = LEQ;
3317 }
3318 else if(by -> item.integer < 0)
3319 {
3320 op = GEQ;
3321 }
3322 else
3323 {
3324 oberon_error(ctx, "zero step not allowed");
3325 }
3326
3327 oberon_assert_token(ctx, DO);
3328 oberon_generate_label(ctx, begin);
3329 cond = oberon_make_bin_op(ctx, op, index, bound);
3330 oberon_generate_branch(ctx, cond, false, end);
3331 oberon_statement_seq(ctx);
3332 count = oberon_make_bin_op(ctx, PLUS, index, by);
3333 oberon_assign(ctx, count, index);
3334 oberon_generate_goto(ctx, begin);
3335 oberon_generate_label(ctx, end);
3336 oberon_assert_token(ctx, END);
3337 }
3338 else if(ctx -> token == LOOP)
3339 {
3340 gen_label_t * begin;
3341 gen_label_t * end;
3342
3343 begin = oberon_generator_reserve_label(ctx);
3344 end = oberon_generator_reserve_label(ctx);
3345
3346 oberon_open_scope(ctx);
3347 oberon_assert_token(ctx, LOOP);
3348 oberon_generate_label(ctx, begin);
3349 ctx -> decl -> exit_label = end;
3350 oberon_statement_seq(ctx);
3351 oberon_generate_goto(ctx, begin);
3352 oberon_generate_label(ctx, end);
3353 oberon_assert_token(ctx, END);
3354 oberon_close_scope(ctx -> decl);
3355 }
3356 else if(ctx -> token == EXIT)
3357 {
3358 oberon_assert_token(ctx, EXIT);
3359 if(ctx -> decl -> exit_label == NULL)
3360 {
3361 oberon_error(ctx, "not in LOOP-END");
3362 }
3363 oberon_generate_goto(ctx, ctx -> decl -> exit_label);
3364 }
3365 else if(ctx -> token == RETURN)
3366 {
3367 oberon_assert_token(ctx, RETURN);
3368 if(ISEXPR(ctx -> token))
3369 {
3370 oberon_expr_t * expr;
3371 expr = oberon_expr(ctx);
3372 oberon_make_return(ctx, expr);
3373 }
3374 else
3375 {
3376 oberon_make_return(ctx, NULL);
3377 }
3378 }
3379 }
3380
3381 static void
3382 oberon_statement_seq(oberon_context_t * ctx)
3383 {
3384 oberon_statement(ctx);
3385 while(ctx -> token == SEMICOLON)
3386 {
3387 oberon_assert_token(ctx, SEMICOLON);
3388 oberon_statement(ctx);
3389 }
3390 }
3391
3392 static void
3393 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
3394 {
3395 oberon_module_t * m = ctx -> module_list;
3396 while(m && strcmp(m -> name, name) != 0)
3397 {
3398 m = m -> next;
3399 }
3400
3401 if(m == NULL)
3402 {
3403 const char * code;
3404 code = ctx -> import_module(name);
3405 if(code == NULL)
3406 {
3407 oberon_error(ctx, "no such module");
3408 }
3409
3410 m = oberon_compile_module(ctx, code);
3411 assert(m);
3412 }
3413
3414 if(m -> ready == 0)
3415 {
3416 oberon_error(ctx, "cyclic module import");
3417 }
3418
3419 oberon_object_t * ident;
3420 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
3421 ident -> module = m;
3422 }
3423
3424 static void
3425 oberon_import_decl(oberon_context_t * ctx)
3426 {
3427 char * alias;
3428 char * name;
3429
3430 alias = name = oberon_assert_ident(ctx);
3431 if(ctx -> token == ASSIGN)
3432 {
3433 oberon_assert_token(ctx, ASSIGN);
3434 name = oberon_assert_ident(ctx);
3435 }
3436
3437 oberon_import_module(ctx, alias, name);
3438 }
3439
3440 static void
3441 oberon_import_list(oberon_context_t * ctx)
3442 {
3443 oberon_assert_token(ctx, IMPORT);
3444
3445 oberon_import_decl(ctx);
3446 while(ctx -> token == COMMA)
3447 {
3448 oberon_assert_token(ctx, COMMA);
3449 oberon_import_decl(ctx);
3450 }
3451
3452 oberon_assert_token(ctx, SEMICOLON);
3453 }
3454
3455 static void
3456 oberon_parse_module(oberon_context_t * ctx)
3457 {
3458 char * name1;
3459 char * name2;
3460 oberon_read_token(ctx);
3461
3462 oberon_assert_token(ctx, MODULE);
3463 name1 = oberon_assert_ident(ctx);
3464 oberon_assert_token(ctx, SEMICOLON);
3465 ctx -> mod -> name = name1;
3466
3467 oberon_generator_init_module(ctx, ctx -> mod);
3468
3469 if(ctx -> token == IMPORT)
3470 {
3471 oberon_import_list(ctx);
3472 }
3473
3474 oberon_decl_seq(ctx);
3475
3476 oberon_generate_begin_module(ctx);
3477 if(ctx -> token == BEGIN)
3478 {
3479 oberon_assert_token(ctx, BEGIN);
3480 oberon_statement_seq(ctx);
3481 }
3482 oberon_generate_end_module(ctx);
3483
3484 oberon_assert_token(ctx, END);
3485 name2 = oberon_assert_ident(ctx);
3486 oberon_assert_token(ctx, DOT);
3487
3488 if(strcmp(name1, name2) != 0)
3489 {
3490 oberon_error(ctx, "module name not matched");
3491 }
3492
3493 oberon_generator_fini_module(ctx -> mod);
3494 }
3495
3496 // =======================================================================
3497 // LIBRARY
3498 // =======================================================================
3499
3500 static void
3501 register_default_types(oberon_context_t * ctx)
3502 {
3503 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
3504 oberon_generator_init_type(ctx, ctx -> void_type);
3505
3506 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
3507 ctx -> void_ptr_type -> base = ctx -> void_type;
3508 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
3509
3510 ctx -> string_type = oberon_new_type_string(1);
3511 oberon_generator_init_type(ctx, ctx -> string_type);
3512
3513 ctx -> bool_type = oberon_new_type_boolean();
3514 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
3515
3516 ctx -> byte_type = oberon_new_type_integer(1);
3517 oberon_define_type(ctx -> world_scope, "BYTE", ctx -> byte_type, 1);
3518
3519 ctx -> shortint_type = oberon_new_type_integer(2);
3520 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> shortint_type, 1);
3521
3522 ctx -> int_type = oberon_new_type_integer(4);
3523 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
3524
3525 ctx -> longint_type = oberon_new_type_integer(8);
3526 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> longint_type, 1);
3527
3528 ctx -> real_type = oberon_new_type_real(4);
3529 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
3530
3531 ctx -> longreal_type = oberon_new_type_real(8);
3532 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
3533
3534 ctx -> char_type = oberon_new_type_char(1);
3535 oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1);
3536
3537 ctx -> set_type = oberon_new_type_set(4);
3538 oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1);
3539 }
3540
3541 static void
3542 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
3543 {
3544 oberon_object_t * proc;
3545 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
3546 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
3547 proc -> type -> sysproc = true;
3548 proc -> type -> genfunc = f;
3549 proc -> type -> genproc = p;
3550 }
3551
3552 static oberon_expr_t *
3553 oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3554 {
3555 if(num_args < 1)
3556 {
3557 oberon_error(ctx, "too few arguments");
3558 }
3559
3560 if(num_args > 1)
3561 {
3562 oberon_error(ctx, "too mach arguments");
3563 }
3564
3565 oberon_expr_t * arg;
3566 arg = list_args;
3567
3568 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3569 {
3570 oberon_error(ctx, "MIN accept only type");
3571 }
3572
3573 oberon_expr_t * expr;
3574 int bits = arg -> result -> size * 8;
3575 switch(arg -> result -> class)
3576 {
3577 case OBERON_TYPE_INTEGER:
3578 expr = oberon_integer_item(ctx, -powl(2, bits - 1));
3579 break;
3580 case OBERON_TYPE_SET:
3581 expr = oberon_integer_item(ctx, 0);
3582 break;
3583 default:
3584 oberon_error(ctx, "allowed only basic types");
3585 break;
3586 }
3587
3588 return expr;
3589 }
3590
3591 static oberon_expr_t *
3592 oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3593 {
3594 if(num_args < 1)
3595 {
3596 oberon_error(ctx, "too few arguments");
3597 }
3598
3599 if(num_args > 1)
3600 {
3601 oberon_error(ctx, "too mach arguments");
3602 }
3603
3604 oberon_expr_t * arg;
3605 arg = list_args;
3606
3607 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3608 {
3609 oberon_error(ctx, "MAX accept only type");
3610 }
3611
3612 oberon_expr_t * expr;
3613 int bits = arg -> result -> size * 8;
3614 switch(arg -> result -> class)
3615 {
3616 case OBERON_TYPE_INTEGER:
3617 expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1);
3618 break;
3619 case OBERON_TYPE_SET:
3620 expr = oberon_integer_item(ctx, bits);
3621 break;
3622 default:
3623 oberon_error(ctx, "allowed only basic types");
3624 break;
3625 }
3626
3627 return expr;
3628 }
3629
3630 static oberon_expr_t *
3631 oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3632 {
3633 if(num_args < 1)
3634 {
3635 oberon_error(ctx, "too few arguments");
3636 }
3637
3638 if(num_args > 1)
3639 {
3640 oberon_error(ctx, "too mach arguments");
3641 }
3642
3643 oberon_expr_t * arg;
3644 arg = list_args;
3645
3646 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3647 {
3648 oberon_error(ctx, "SIZE accept only type");
3649 }
3650
3651 int size;
3652 oberon_expr_t * expr;
3653 oberon_type_t * type = arg -> result;
3654 switch(type -> class)
3655 {
3656 case OBERON_TYPE_INTEGER:
3657 case OBERON_TYPE_BOOLEAN:
3658 case OBERON_TYPE_REAL:
3659 case OBERON_TYPE_CHAR:
3660 case OBERON_TYPE_SET:
3661 size = type -> size;
3662 break;
3663 default:
3664 oberon_error(ctx, "TODO SIZE");
3665 break;
3666 }
3667
3668 expr = oberon_integer_item(ctx, size);
3669 return expr;
3670 }
3671
3672 static oberon_expr_t *
3673 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3674 {
3675 if(num_args < 1)
3676 {
3677 oberon_error(ctx, "too few arguments");
3678 }
3679
3680 if(num_args > 1)
3681 {
3682 oberon_error(ctx, "too mach arguments");
3683 }
3684
3685 oberon_expr_t * arg;
3686 arg = list_args;
3687 oberon_check_src(ctx, arg);
3688
3689 oberon_type_t * result_type;
3690 result_type = arg -> result;
3691
3692 if(result_type -> class != OBERON_TYPE_INTEGER)
3693 {
3694 oberon_error(ctx, "ABS accepts only integers");
3695 }
3696
3697 oberon_expr_t * expr;
3698 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
3699 return expr;
3700 }
3701
3702 static void
3703 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3704 {
3705 if(num_args < 1)
3706 {
3707 oberon_error(ctx, "too few arguments");
3708 }
3709
3710
3711 oberon_expr_t * dst;
3712 dst = list_args;
3713 oberon_check_dst(ctx, dst);
3714
3715 oberon_type_t * type;
3716 type = dst -> result;
3717
3718 if(type -> class != OBERON_TYPE_POINTER)
3719 {
3720 oberon_error(ctx, "not a pointer");
3721 }
3722
3723 type = type -> base;
3724
3725 oberon_expr_t * src;
3726 src = oberon_new_item(MODE_NEW, dst -> result, 0);
3727 src -> item.num_args = 0;
3728 src -> item.args = NULL;
3729
3730 int max_args = 1;
3731 if(type -> class == OBERON_TYPE_ARRAY)
3732 {
3733 if(type -> size == 0)
3734 {
3735 oberon_type_t * x = type;
3736 while(x -> class == OBERON_TYPE_ARRAY)
3737 {
3738 if(x -> size == 0)
3739 {
3740 max_args += 1;
3741 }
3742 x = x -> base;
3743 }
3744 }
3745
3746 if(num_args < max_args)
3747 {
3748 oberon_error(ctx, "too few arguments");
3749 }
3750
3751 if(num_args > max_args)
3752 {
3753 oberon_error(ctx, "too mach arguments");
3754 }
3755
3756 int num_sizes = max_args - 1;
3757 oberon_expr_t * size_list = list_args -> next;
3758
3759 oberon_expr_t * arg = size_list;
3760 for(int i = 0; i < max_args - 1; i++)
3761 {
3762 oberon_check_src(ctx, arg);
3763 if(arg -> result -> class != OBERON_TYPE_INTEGER)
3764 {
3765 oberon_error(ctx, "size must be integer");
3766 }
3767 arg = arg -> next;
3768 }
3769
3770 src -> item.num_args = num_sizes;
3771 src -> item.args = size_list;
3772 }
3773 else if(type -> class != OBERON_TYPE_RECORD)
3774 {
3775 oberon_error(ctx, "oberon_make_new_call: wat");
3776 }
3777
3778 if(num_args > max_args)
3779 {
3780 oberon_error(ctx, "too mach arguments");
3781 }
3782
3783 oberon_assign(ctx, src, dst);
3784 }
3785
3786 oberon_context_t *
3787 oberon_create_context(ModuleImportCallback import_module)
3788 {
3789 oberon_context_t * ctx = calloc(1, sizeof *ctx);
3790
3791 oberon_scope_t * world_scope;
3792 world_scope = oberon_open_scope(ctx);
3793 ctx -> world_scope = world_scope;
3794
3795 ctx -> import_module = import_module;
3796
3797 oberon_generator_init_context(ctx);
3798
3799 register_default_types(ctx);
3800
3801 /* Functions */
3802 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
3803 oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL);
3804 oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
3805 oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
3806
3807 /* Procedures */
3808 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
3809
3810 return ctx;
3811 }
3812
3813 void
3814 oberon_destroy_context(oberon_context_t * ctx)
3815 {
3816 oberon_generator_destroy_context(ctx);
3817 free(ctx);
3818 }
3819
3820 oberon_module_t *
3821 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
3822 {
3823 const char * code = ctx -> code;
3824 int code_index = ctx -> code_index;
3825 char c = ctx -> c;
3826 int token = ctx -> token;
3827 char * string = ctx -> string;
3828 int integer = ctx -> integer;
3829 int real = ctx -> real;
3830 bool longmode = ctx -> longmode;
3831 oberon_scope_t * decl = ctx -> decl;
3832 oberon_module_t * mod = ctx -> mod;
3833
3834 oberon_scope_t * module_scope;
3835 module_scope = oberon_open_scope(ctx);
3836
3837 oberon_module_t * module;
3838 module = calloc(1, sizeof *module);
3839 module -> decl = module_scope;
3840 module -> next = ctx -> module_list;
3841
3842 ctx -> mod = module;
3843 ctx -> module_list = module;
3844
3845 oberon_init_scaner(ctx, newcode);
3846 oberon_parse_module(ctx);
3847
3848 module -> ready = 1;
3849
3850 ctx -> code = code;
3851 ctx -> code_index = code_index;
3852 ctx -> c = c;
3853 ctx -> token = token;
3854 ctx -> string = string;
3855 ctx -> integer = integer;
3856 ctx -> real = real;
3857 ctx -> longmode = longmode;
3858 ctx -> decl = decl;
3859 ctx -> mod = mod;
3860
3861 return module;
3862 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024