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