DEADSOFTWARE

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


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