DEADSOFTWARE

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