DEADSOFTWARE

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