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