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
1164 static oberon_object_t *
1165 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1166 {
1167 char * name;
1168 oberon_object_t * x;
1169
1170 name = oberon_assert_ident(ctx);
1171 x = oberon_find_object(ctx -> decl, name, check);
1172
1173 if(x != NULL)
1174 {
1175 if(x -> class == OBERON_CLASS_MODULE)
1176 {
1177 oberon_assert_token(ctx, DOT);
1178 name = oberon_assert_ident(ctx);
1179 /* Наличие объектов в левых модулях всегда проверяется */
1180 x = oberon_find_object(x -> module -> decl, name, 1);
1181
1182 if(x -> export == 0)
1183 {
1184 oberon_error(ctx, "not exported");
1185 }
1186 }
1187 }
1188
1189 if(xname)
1190 {
1191 *xname = name;
1192 }
1193
1194 return x;
1195 }
1196
1197 static oberon_expr_t *
1198 oberon_designator(oberon_context_t * ctx)
1199 {
1200 char * name;
1201 oberon_object_t * var;
1202 oberon_expr_t * expr;
1203
1204 var = oberon_qualident(ctx, NULL, 1);
1205
1206 int read_only = 0;
1207 if(var -> read_only)
1208 {
1209 if(var -> module != ctx -> mod)
1210 {
1211 read_only = 1;
1212 }
1213 }
1214
1215 switch(var -> class)
1216 {
1217 case OBERON_CLASS_CONST:
1218 // TODO copy value
1219 expr = (oberon_expr_t *) var -> value;
1220 break;
1221 case OBERON_CLASS_VAR:
1222 case OBERON_CLASS_VAR_PARAM:
1223 case OBERON_CLASS_PARAM:
1224 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1225 break;
1226 case OBERON_CLASS_PROC:
1227 expr = oberon_new_item(MODE_VAR, var -> type, 1);
1228 break;
1229 default:
1230 oberon_error(ctx, "invalid designator");
1231 break;
1232 }
1233 expr -> item.var = var;
1234
1235 while(ISSELECTOR(ctx -> token))
1236 {
1237 switch(ctx -> token)
1238 {
1239 case DOT:
1240 oberon_assert_token(ctx, DOT);
1241 name = oberon_assert_ident(ctx);
1242 expr = oberon_make_record_selector(ctx, expr, name);
1243 break;
1244 case LBRACE:
1245 oberon_assert_token(ctx, LBRACE);
1246 int num_indexes = 0;
1247 oberon_expr_t * indexes = NULL;
1248 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1249 oberon_assert_token(ctx, RBRACE);
1250
1251 for(int i = 0; i < num_indexes; i++)
1252 {
1253 expr = oberon_make_array_selector(ctx, expr, indexes);
1254 indexes = indexes -> next;
1255 }
1256 break;
1257 case UPARROW:
1258 oberon_assert_token(ctx, UPARROW);
1259 expr = oberno_make_dereferencing(ctx, expr);
1260 break;
1261 default:
1262 oberon_error(ctx, "oberon_designator: wat");
1263 break;
1264 }
1265 }
1266 return expr;
1267 }
1268
1269 static oberon_expr_t *
1270 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1271 {
1272 assert(expr -> is_item == 1);
1273
1274 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1275 if(ctx -> token == LPAREN)
1276 {
1277 oberon_assert_token(ctx, LPAREN);
1278
1279 int num_args = 0;
1280 oberon_expr_t * arguments = NULL;
1281
1282 if(ISEXPR(ctx -> token))
1283 {
1284 oberon_expr_list(ctx, &num_args, &arguments, 0);
1285 }
1286
1287 expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
1288
1289 oberon_assert_token(ctx, RPAREN);
1290 }
1291
1292 return expr;
1293 }
1294
1295 static void
1296 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1297 {
1298 assert(expr -> is_item == 1);
1299
1300 int num_args = 0;
1301 oberon_expr_t * arguments = NULL;
1302
1303 if(ctx -> token == LPAREN)
1304 {
1305 oberon_assert_token(ctx, LPAREN);
1306
1307 if(ISEXPR(ctx -> token))
1308 {
1309 oberon_expr_list(ctx, &num_args, &arguments, 0);
1310 }
1311
1312 oberon_assert_token(ctx, RPAREN);
1313 }
1314
1315 /* Вызов происходит даже без скобок */
1316 oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
1317 }
1318
1319 static oberon_type_t *
1320 oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i)
1321 {
1322 if(i >= -128 && i <= 127)
1323 {
1324 return ctx -> byte_type;
1325 }
1326 else if(i >= -32768 && i <= 32767)
1327 {
1328 return ctx -> shortint_type;
1329 }
1330 else if(i >= -2147483648 && i <= 2147483647)
1331 {
1332 return ctx -> int_type;
1333 }
1334 else
1335 {
1336 return ctx -> longint_type;
1337 }
1338 }
1339
1340 static oberon_expr_t *
1341 oberon_factor(oberon_context_t * ctx)
1342 {
1343 oberon_expr_t * expr;
1344 oberon_type_t * result;
1345
1346 switch(ctx -> token)
1347 {
1348 case IDENT:
1349 expr = oberon_designator(ctx);
1350 expr = oberon_opt_func_parens(ctx, expr);
1351 break;
1352 case INTEGER:
1353 result = oberon_get_type_of_int_value(ctx, ctx -> integer);
1354 expr = oberon_new_item(MODE_INTEGER, result, 1);
1355 expr -> item.integer = ctx -> integer;
1356 oberon_assert_token(ctx, INTEGER);
1357 break;
1358 case REAL:
1359 result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type);
1360 expr = oberon_new_item(MODE_REAL, result, 1);
1361 expr -> item.real = ctx -> real;
1362 oberon_assert_token(ctx, REAL);
1363 break;
1364 case TRUE:
1365 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1366 expr -> item.boolean = true;
1367 oberon_assert_token(ctx, TRUE);
1368 break;
1369 case FALSE:
1370 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1371 expr -> item.boolean = false;
1372 oberon_assert_token(ctx, FALSE);
1373 break;
1374 case LPAREN:
1375 oberon_assert_token(ctx, LPAREN);
1376 expr = oberon_expr(ctx);
1377 oberon_assert_token(ctx, RPAREN);
1378 break;
1379 case NOT:
1380 oberon_assert_token(ctx, NOT);
1381 expr = oberon_factor(ctx);
1382 expr = oberon_make_unary_op(ctx, NOT, expr);
1383 break;
1384 case NIL:
1385 oberon_assert_token(ctx, NIL);
1386 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, 1);
1387 break;
1388 default:
1389 oberon_error(ctx, "invalid expression");
1390 }
1391
1392 return expr;
1393 }
1394
1395 #define ITMAKESBOOLEAN(x) \
1396 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1397
1398 #define ITUSEONLYINTEGER(x) \
1399 ((x) >= LESS && (x) <= GEQ)
1400
1401 #define ITUSEONLYBOOLEAN(x) \
1402 (((x) == OR) || ((x) == AND))
1403
1404 static void
1405 oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e)
1406 {
1407 oberon_expr_t * expr = *e;
1408 if(expr -> result -> class == OBERON_TYPE_INTEGER)
1409 {
1410 if(expr -> result -> size <= ctx -> real_type -> size)
1411 {
1412 *e = oberon_cast_expr(ctx, expr, ctx -> real_type);
1413 }
1414 else
1415 {
1416 *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type);
1417 }
1418 }
1419 else if(expr -> result -> class != OBERON_TYPE_REAL)
1420 {
1421 oberon_error(ctx, "required numeric type");
1422 }
1423 }
1424
1425 static oberon_expr_t *
1426 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1427 {
1428 oberon_expr_t * expr;
1429 oberon_type_t * result;
1430
1431 if(ITMAKESBOOLEAN(token))
1432 {
1433 if(ITUSEONLYINTEGER(token))
1434 {
1435 if(a -> result -> class == OBERON_TYPE_INTEGER
1436 || b -> result -> class == OBERON_TYPE_INTEGER
1437 || a -> result -> class == OBERON_TYPE_REAL
1438 || b -> result -> class == OBERON_TYPE_REAL)
1439 {
1440 oberon_error(ctx, "used only with numeric types");
1441 }
1442 }
1443 else if(ITUSEONLYBOOLEAN(token))
1444 {
1445 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1446 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1447 {
1448 oberon_error(ctx, "used only with boolean type");
1449 }
1450 }
1451
1452 oberon_autocast_binary_op(ctx, &a, &b);
1453 result = ctx -> bool_type;
1454
1455 if(token == EQUAL)
1456 {
1457 expr = oberon_new_operator(OP_EQ, result, a, b);
1458 }
1459 else if(token == NEQ)
1460 {
1461 expr = oberon_new_operator(OP_NEQ, result, a, b);
1462 }
1463 else if(token == LESS)
1464 {
1465 expr = oberon_new_operator(OP_LSS, result, a, b);
1466 }
1467 else if(token == LEQ)
1468 {
1469 expr = oberon_new_operator(OP_LEQ, result, a, b);
1470 }
1471 else if(token == GREAT)
1472 {
1473 expr = oberon_new_operator(OP_GRT, result, a, b);
1474 }
1475 else if(token == GEQ)
1476 {
1477 expr = oberon_new_operator(OP_GEQ, result, a, b);
1478 }
1479 else if(token == OR)
1480 {
1481 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1482 }
1483 else if(token == AND)
1484 {
1485 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1486 }
1487 else
1488 {
1489 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1490 }
1491 }
1492 else if(token == SLASH)
1493 {
1494 oberon_autocast_to_real(ctx, &a);
1495 oberon_autocast_to_real(ctx, &b);
1496 oberon_autocast_binary_op(ctx, &a, &b);
1497 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1498 }
1499 else if(token == DIV)
1500 {
1501 if(a -> result -> class != OBERON_TYPE_INTEGER
1502 || b -> result -> class != OBERON_TYPE_INTEGER)
1503 {
1504 oberon_error(ctx, "operator DIV requires integer type");
1505 }
1506
1507 oberon_autocast_binary_op(ctx, &a, &b);
1508 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1509 }
1510 else
1511 {
1512 oberon_autocast_binary_op(ctx, &a, &b);
1513
1514 if(token == PLUS)
1515 {
1516 expr = oberon_new_operator(OP_ADD, a -> result, a, b);
1517 }
1518 else if(token == MINUS)
1519 {
1520 expr = oberon_new_operator(OP_SUB, a -> result, a, b);
1521 }
1522 else if(token == STAR)
1523 {
1524 expr = oberon_new_operator(OP_MUL, a -> result, a, b);
1525 }
1526 else if(token == MOD)
1527 {
1528 expr = oberon_new_operator(OP_MOD, a -> result, a, b);
1529 }
1530 else
1531 {
1532 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1533 }
1534 }
1535
1536 return expr;
1537 }
1538
1539 #define ISMULOP(x) \
1540 ((x) >= STAR && (x) <= AND)
1541
1542 static oberon_expr_t *
1543 oberon_term_expr(oberon_context_t * ctx)
1544 {
1545 oberon_expr_t * expr;
1546
1547 expr = oberon_factor(ctx);
1548 while(ISMULOP(ctx -> token))
1549 {
1550 int token = ctx -> token;
1551 oberon_read_token(ctx);
1552
1553 oberon_expr_t * inter = oberon_factor(ctx);
1554 expr = oberon_make_bin_op(ctx, token, expr, inter);
1555 }
1556
1557 return expr;
1558 }
1559
1560 #define ISADDOP(x) \
1561 ((x) >= PLUS && (x) <= OR)
1562
1563 static oberon_expr_t *
1564 oberon_simple_expr(oberon_context_t * ctx)
1565 {
1566 oberon_expr_t * expr;
1567
1568 int minus = 0;
1569 if(ctx -> token == PLUS)
1570 {
1571 minus = 0;
1572 oberon_assert_token(ctx, PLUS);
1573 }
1574 else if(ctx -> token == MINUS)
1575 {
1576 minus = 1;
1577 oberon_assert_token(ctx, MINUS);
1578 }
1579
1580 expr = oberon_term_expr(ctx);
1581
1582 if(minus)
1583 {
1584 expr = oberon_make_unary_op(ctx, MINUS, expr);
1585 }
1586
1587 while(ISADDOP(ctx -> token))
1588 {
1589 int token = ctx -> token;
1590 oberon_read_token(ctx);
1591
1592 oberon_expr_t * inter = oberon_term_expr(ctx);
1593 expr = oberon_make_bin_op(ctx, token, expr, inter);
1594 }
1595
1596 return expr;
1597 }
1598
1599 #define ISRELATION(x) \
1600 ((x) >= EQUAL && (x) <= GEQ)
1601
1602 static oberon_expr_t *
1603 oberon_expr(oberon_context_t * ctx)
1604 {
1605 oberon_expr_t * expr;
1606
1607 expr = oberon_simple_expr(ctx);
1608 while(ISRELATION(ctx -> token))
1609 {
1610 int token = ctx -> token;
1611 oberon_read_token(ctx);
1612
1613 oberon_expr_t * inter = oberon_simple_expr(ctx);
1614 expr = oberon_make_bin_op(ctx, token, expr, inter);
1615 }
1616
1617 return expr;
1618 }
1619
1620 static oberon_item_t *
1621 oberon_const_expr(oberon_context_t * ctx)
1622 {
1623 oberon_expr_t * expr;
1624 expr = oberon_expr(ctx);
1625
1626 if(expr -> is_item == 0)
1627 {
1628 oberon_error(ctx, "const expression are required");
1629 }
1630
1631 return (oberon_item_t *) expr;
1632 }
1633
1634 // =======================================================================
1635 // PARSER
1636 // =======================================================================
1637
1638 static void oberon_decl_seq(oberon_context_t * ctx);
1639 static void oberon_statement_seq(oberon_context_t * ctx);
1640 static void oberon_initialize_decl(oberon_context_t * ctx);
1641
1642 static void
1643 oberon_expect_token(oberon_context_t * ctx, int token)
1644 {
1645 if(ctx -> token != token)
1646 {
1647 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1648 }
1649 }
1650
1651 static void
1652 oberon_assert_token(oberon_context_t * ctx, int token)
1653 {
1654 oberon_expect_token(ctx, token);
1655 oberon_read_token(ctx);
1656 }
1657
1658 static char *
1659 oberon_assert_ident(oberon_context_t * ctx)
1660 {
1661 oberon_expect_token(ctx, IDENT);
1662 char * ident = ctx -> string;
1663 oberon_read_token(ctx);
1664 return ident;
1665 }
1666
1667 static void
1668 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
1669 {
1670 switch(ctx -> token)
1671 {
1672 case STAR:
1673 oberon_assert_token(ctx, STAR);
1674 *export = 1;
1675 *read_only = 0;
1676 break;
1677 case MINUS:
1678 oberon_assert_token(ctx, MINUS);
1679 *export = 1;
1680 *read_only = 1;
1681 break;
1682 default:
1683 *export = 0;
1684 *read_only = 0;
1685 break;
1686 }
1687 }
1688
1689 static oberon_object_t *
1690 oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
1691 {
1692 char * name;
1693 int export;
1694 int read_only;
1695 oberon_object_t * x;
1696
1697 name = oberon_assert_ident(ctx);
1698 oberon_def(ctx, &export, &read_only);
1699
1700 x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
1701 return x;
1702 }
1703
1704 static void
1705 oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
1706 {
1707 *num = 1;
1708 *list = oberon_ident_def(ctx, class, check_upscope);
1709 while(ctx -> token == COMMA)
1710 {
1711 oberon_assert_token(ctx, COMMA);
1712 oberon_ident_def(ctx, class, check_upscope);
1713 *num += 1;
1714 }
1715 }
1716
1717 static void
1718 oberon_var_decl(oberon_context_t * ctx)
1719 {
1720 int num;
1721 oberon_object_t * list;
1722 oberon_type_t * type;
1723 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1724
1725 oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
1726 oberon_assert_token(ctx, COLON);
1727 oberon_type(ctx, &type);
1728
1729 oberon_object_t * var = list;
1730 for(int i = 0; i < num; i++)
1731 {
1732 var -> type = type;
1733 var = var -> next;
1734 }
1735 }
1736
1737 static oberon_object_t *
1738 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1739 {
1740 int class = OBERON_CLASS_PARAM;
1741 if(ctx -> token == VAR)
1742 {
1743 oberon_read_token(ctx);
1744 class = OBERON_CLASS_VAR_PARAM;
1745 }
1746
1747 int num;
1748 oberon_object_t * list;
1749 oberon_ident_list(ctx, class, false, &num, &list);
1750
1751 oberon_assert_token(ctx, COLON);
1752
1753 oberon_type_t * type;
1754 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1755 oberon_type(ctx, &type);
1756
1757 oberon_object_t * param = list;
1758 for(int i = 0; i < num; i++)
1759 {
1760 param -> type = type;
1761 param = param -> next;
1762 }
1763
1764 *num_decl += num;
1765 return list;
1766 }
1767
1768 #define ISFPSECTION \
1769 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1770
1771 static void
1772 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1773 {
1774 oberon_assert_token(ctx, LPAREN);
1775
1776 if(ISFPSECTION)
1777 {
1778 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
1779 while(ctx -> token == SEMICOLON)
1780 {
1781 oberon_assert_token(ctx, SEMICOLON);
1782 oberon_fp_section(ctx, &signature -> num_decl);
1783 }
1784 }
1785
1786 oberon_assert_token(ctx, RPAREN);
1787
1788 if(ctx -> token == COLON)
1789 {
1790 oberon_assert_token(ctx, COLON);
1791
1792 oberon_object_t * typeobj;
1793 typeobj = oberon_qualident(ctx, NULL, 1);
1794 if(typeobj -> class != OBERON_CLASS_TYPE)
1795 {
1796 oberon_error(ctx, "function result is not type");
1797 }
1798 signature -> base = typeobj -> type;
1799 }
1800 }
1801
1802 static void
1803 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
1804 {
1805 oberon_type_t * signature;
1806 signature = *type;
1807 signature -> class = OBERON_TYPE_PROCEDURE;
1808 signature -> num_decl = 0;
1809 signature -> base = ctx -> void_type;
1810 signature -> decl = NULL;
1811
1812 if(ctx -> token == LPAREN)
1813 {
1814 oberon_formal_pars(ctx, signature);
1815 }
1816 }
1817
1818 static void
1819 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1820 {
1821 if(a -> num_decl != b -> num_decl)
1822 {
1823 oberon_error(ctx, "number parameters not matched");
1824 }
1825
1826 int num_param = a -> num_decl;
1827 oberon_object_t * param_a = a -> decl;
1828 oberon_object_t * param_b = b -> decl;
1829 for(int i = 0; i < num_param; i++)
1830 {
1831 if(strcmp(param_a -> name, param_b -> name) != 0)
1832 {
1833 oberon_error(ctx, "param %i name not matched", i + 1);
1834 }
1835
1836 if(param_a -> type != param_b -> type)
1837 {
1838 oberon_error(ctx, "param %i type not matched", i + 1);
1839 }
1840
1841 param_a = param_a -> next;
1842 param_b = param_b -> next;
1843 }
1844 }
1845
1846 static void
1847 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1848 {
1849 oberon_object_t * proc = ctx -> decl -> parent;
1850 oberon_type_t * result_type = proc -> type -> base;
1851
1852 if(result_type -> class == OBERON_TYPE_VOID)
1853 {
1854 if(expr != NULL)
1855 {
1856 oberon_error(ctx, "procedure has no result type");
1857 }
1858 }
1859 else
1860 {
1861 if(expr == NULL)
1862 {
1863 oberon_error(ctx, "procedure requires expression on result");
1864 }
1865
1866 expr = oberon_autocast_to(ctx, expr, result_type);
1867 }
1868
1869 proc -> has_return = 1;
1870
1871 oberon_generate_return(ctx, expr);
1872 }
1873
1874 static void
1875 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
1876 {
1877 oberon_assert_token(ctx, SEMICOLON);
1878
1879 ctx -> decl = proc -> scope;
1880
1881 oberon_decl_seq(ctx);
1882
1883 oberon_generate_begin_proc(ctx, proc);
1884
1885 if(ctx -> token == BEGIN)
1886 {
1887 oberon_assert_token(ctx, BEGIN);
1888 oberon_statement_seq(ctx);
1889 }
1890
1891 oberon_assert_token(ctx, END);
1892 char * name = oberon_assert_ident(ctx);
1893 if(strcmp(name, proc -> name) != 0)
1894 {
1895 oberon_error(ctx, "procedure name not matched");
1896 }
1897
1898 if(proc -> type -> base -> class == OBERON_TYPE_VOID
1899 && proc -> has_return == 0)
1900 {
1901 oberon_make_return(ctx, NULL);
1902 }
1903
1904 if(proc -> has_return == 0)
1905 {
1906 oberon_error(ctx, "procedure requires return");
1907 }
1908
1909 oberon_generate_end_proc(ctx);
1910 oberon_close_scope(ctx -> decl);
1911 }
1912
1913 static void
1914 oberon_proc_decl(oberon_context_t * ctx)
1915 {
1916 oberon_assert_token(ctx, PROCEDURE);
1917
1918 int forward = 0;
1919 if(ctx -> token == UPARROW)
1920 {
1921 oberon_assert_token(ctx, UPARROW);
1922 forward = 1;
1923 }
1924
1925 char * name;
1926 int export;
1927 int read_only;
1928 name = oberon_assert_ident(ctx);
1929 oberon_def(ctx, &export, &read_only);
1930
1931 oberon_scope_t * proc_scope;
1932 proc_scope = oberon_open_scope(ctx);
1933 ctx -> decl -> local = 1;
1934
1935 oberon_type_t * signature;
1936 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
1937 oberon_opt_formal_pars(ctx, &signature);
1938
1939 oberon_initialize_decl(ctx);
1940 oberon_generator_init_type(ctx, signature);
1941 oberon_close_scope(ctx -> decl);
1942
1943 oberon_object_t * proc;
1944 proc = oberon_find_object(ctx -> decl, name, 0);
1945 if(proc != NULL)
1946 {
1947 if(proc -> class != OBERON_CLASS_PROC)
1948 {
1949 oberon_error(ctx, "mult definition");
1950 }
1951
1952 if(forward == 0)
1953 {
1954 if(proc -> linked)
1955 {
1956 oberon_error(ctx, "mult procedure definition");
1957 }
1958 }
1959
1960 if(proc -> export != export || proc -> read_only != read_only)
1961 {
1962 oberon_error(ctx, "export type not matched");
1963 }
1964
1965 oberon_compare_signatures(ctx, proc -> type, signature);
1966 }
1967 else
1968 {
1969 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
1970 proc -> type = signature;
1971 proc -> scope = proc_scope;
1972 oberon_generator_init_proc(ctx, proc);
1973 }
1974
1975 proc -> scope -> parent = proc;
1976
1977 if(forward == 0)
1978 {
1979 proc -> linked = 1;
1980 oberon_proc_decl_body(ctx, proc);
1981 }
1982 }
1983
1984 static void
1985 oberon_const_decl(oberon_context_t * ctx)
1986 {
1987 oberon_item_t * value;
1988 oberon_object_t * constant;
1989
1990 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
1991 oberon_assert_token(ctx, EQUAL);
1992 value = oberon_const_expr(ctx);
1993 constant -> value = value;
1994 }
1995
1996 static void
1997 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
1998 {
1999 if(size -> is_item == 0)
2000 {
2001 oberon_error(ctx, "requires constant");
2002 }
2003
2004 if(size -> item.mode != MODE_INTEGER)
2005 {
2006 oberon_error(ctx, "requires integer constant");
2007 }
2008
2009 oberon_type_t * arr;
2010 arr = *type;
2011 arr -> class = OBERON_TYPE_ARRAY;
2012 arr -> size = size -> item.integer;
2013 arr -> base = base;
2014 }
2015
2016 static void
2017 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2018 {
2019 char * name;
2020 oberon_object_t * to;
2021
2022 to = oberon_qualident(ctx, &name, 0);
2023
2024 //name = oberon_assert_ident(ctx);
2025 //to = oberon_find_object(ctx -> decl, name, 0);
2026
2027 if(to != NULL)
2028 {
2029 if(to -> class != OBERON_CLASS_TYPE)
2030 {
2031 oberon_error(ctx, "not a type");
2032 }
2033 }
2034 else
2035 {
2036 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2037 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2038 }
2039
2040 *type = to -> type;
2041 }
2042
2043 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2044
2045 /*
2046 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2047 */
2048
2049 static void
2050 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2051 {
2052 if(sizes == NULL)
2053 {
2054 *type = base;
2055 return;
2056 }
2057
2058 oberon_type_t * dim;
2059 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2060
2061 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2062
2063 oberon_make_array_type(ctx, sizes, dim, type);
2064 }
2065
2066 static void
2067 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2068 {
2069 type -> class = OBERON_TYPE_ARRAY;
2070 type -> size = 0;
2071 type -> base = base;
2072 }
2073
2074 static void
2075 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2076 {
2077 if(ctx -> token == IDENT)
2078 {
2079 int num;
2080 oberon_object_t * list;
2081 oberon_type_t * type;
2082 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2083
2084 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2085 oberon_assert_token(ctx, COLON);
2086
2087 oberon_scope_t * current = ctx -> decl;
2088 ctx -> decl = modscope;
2089 oberon_type(ctx, &type);
2090 ctx -> decl = current;
2091
2092 oberon_object_t * field = list;
2093 for(int i = 0; i < num; i++)
2094 {
2095 field -> type = type;
2096 field = field -> next;
2097 }
2098
2099 rec -> num_decl += num;
2100 }
2101 }
2102
2103 static void
2104 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2105 {
2106 oberon_scope_t * modscope = ctx -> mod -> decl;
2107 oberon_scope_t * oldscope = ctx -> decl;
2108 ctx -> decl = modscope;
2109
2110 if(ctx -> token == LPAREN)
2111 {
2112 oberon_assert_token(ctx, LPAREN);
2113
2114 oberon_object_t * typeobj;
2115 typeobj = oberon_qualident(ctx, NULL, true);
2116
2117 if(typeobj -> class != OBERON_CLASS_TYPE)
2118 {
2119 oberon_error(ctx, "base must be type");
2120 }
2121
2122 if(typeobj -> type -> class != OBERON_TYPE_RECORD)
2123 {
2124 oberon_error(ctx, "base must be record type");
2125 }
2126
2127 rec -> base = typeobj -> type;
2128 ctx -> decl = rec -> base -> scope;
2129
2130 oberon_assert_token(ctx, RPAREN);
2131 }
2132 else
2133 {
2134 ctx -> decl = NULL;
2135 }
2136
2137 oberon_scope_t * this_scope;
2138 this_scope = oberon_open_scope(ctx);
2139 this_scope -> local = true;
2140 this_scope -> parent = NULL;
2141 this_scope -> parent_type = rec;
2142
2143 oberon_field_list(ctx, rec, modscope);
2144 while(ctx -> token == SEMICOLON)
2145 {
2146 oberon_assert_token(ctx, SEMICOLON);
2147 oberon_field_list(ctx, rec, modscope);
2148 }
2149
2150 rec -> scope = this_scope;
2151 rec -> decl = this_scope -> list -> next;
2152 ctx -> decl = oldscope;
2153 }
2154
2155 static void
2156 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2157 {
2158 if(ctx -> token == IDENT)
2159 {
2160 oberon_qualident_type(ctx, type);
2161 }
2162 else if(ctx -> token == ARRAY)
2163 {
2164 oberon_assert_token(ctx, ARRAY);
2165
2166 int num_sizes = 0;
2167 oberon_expr_t * sizes;
2168
2169 if(ISEXPR(ctx -> token))
2170 {
2171 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2172 }
2173
2174 oberon_assert_token(ctx, OF);
2175
2176 oberon_type_t * base;
2177 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2178 oberon_type(ctx, &base);
2179
2180 if(num_sizes == 0)
2181 {
2182 oberon_make_open_array(ctx, base, *type);
2183 }
2184 else
2185 {
2186 oberon_make_multiarray(ctx, sizes, base, type);
2187 }
2188 }
2189 else if(ctx -> token == RECORD)
2190 {
2191 oberon_type_t * rec;
2192 rec = *type;
2193 rec -> class = OBERON_TYPE_RECORD;
2194 rec -> module = ctx -> mod;
2195
2196 oberon_assert_token(ctx, RECORD);
2197 oberon_type_record_body(ctx, rec);
2198 oberon_assert_token(ctx, END);
2199
2200 *type = rec;
2201 }
2202 else if(ctx -> token == POINTER)
2203 {
2204 oberon_assert_token(ctx, POINTER);
2205 oberon_assert_token(ctx, TO);
2206
2207 oberon_type_t * base;
2208 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2209 oberon_type(ctx, &base);
2210
2211 oberon_type_t * ptr;
2212 ptr = *type;
2213 ptr -> class = OBERON_TYPE_POINTER;
2214 ptr -> base = base;
2215 }
2216 else if(ctx -> token == PROCEDURE)
2217 {
2218 oberon_open_scope(ctx);
2219 oberon_assert_token(ctx, PROCEDURE);
2220 oberon_opt_formal_pars(ctx, type);
2221 oberon_close_scope(ctx -> decl);
2222 }
2223 else
2224 {
2225 oberon_error(ctx, "invalid type declaration");
2226 }
2227 }
2228
2229 static void
2230 oberon_type_decl(oberon_context_t * ctx)
2231 {
2232 char * name;
2233 oberon_object_t * newtype;
2234 oberon_type_t * type;
2235 int export;
2236 int read_only;
2237
2238 name = oberon_assert_ident(ctx);
2239 oberon_def(ctx, &export, &read_only);
2240
2241 newtype = oberon_find_object(ctx -> decl, name, 0);
2242 if(newtype == NULL)
2243 {
2244 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2245 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2246 assert(newtype -> type);
2247 }
2248 else
2249 {
2250 if(newtype -> class != OBERON_CLASS_TYPE)
2251 {
2252 oberon_error(ctx, "mult definition");
2253 }
2254
2255 if(newtype -> linked)
2256 {
2257 oberon_error(ctx, "mult definition - already linked");
2258 }
2259
2260 newtype -> export = export;
2261 newtype -> read_only = read_only;
2262 }
2263
2264 oberon_assert_token(ctx, EQUAL);
2265
2266 type = newtype -> type;
2267 oberon_type(ctx, &type);
2268
2269 if(type -> class == OBERON_TYPE_VOID)
2270 {
2271 oberon_error(ctx, "recursive alias declaration");
2272 }
2273
2274 newtype -> type = type;
2275 newtype -> linked = 1;
2276 }
2277
2278 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2279 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2280
2281 static void
2282 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2283 {
2284 if(type -> class != OBERON_TYPE_POINTER
2285 && type -> class != OBERON_TYPE_ARRAY)
2286 {
2287 return;
2288 }
2289
2290 if(type -> recursive)
2291 {
2292 oberon_error(ctx, "recursive pointer declaration");
2293 }
2294
2295 if(type -> class == OBERON_TYPE_POINTER
2296 && type -> base -> class == OBERON_TYPE_POINTER)
2297 {
2298 oberon_error(ctx, "attempt to make pointer to pointer");
2299 }
2300
2301 type -> recursive = 1;
2302
2303 oberon_prevent_recursive_pointer(ctx, type -> base);
2304
2305 type -> recursive = 0;
2306 }
2307
2308 static void
2309 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2310 {
2311 if(type -> class != OBERON_TYPE_RECORD)
2312 {
2313 return;
2314 }
2315
2316 if(type -> recursive)
2317 {
2318 oberon_error(ctx, "recursive record declaration");
2319 }
2320
2321 type -> recursive = 1;
2322
2323 int num_fields = type -> num_decl;
2324 oberon_object_t * field = type -> decl;
2325 for(int i = 0; i < num_fields; i++)
2326 {
2327 oberon_prevent_recursive_object(ctx, field);
2328 field = field -> next;
2329 }
2330
2331 type -> recursive = 0;
2332 }
2333 static void
2334 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2335 {
2336 if(type -> class != OBERON_TYPE_PROCEDURE)
2337 {
2338 return;
2339 }
2340
2341 if(type -> recursive)
2342 {
2343 oberon_error(ctx, "recursive procedure declaration");
2344 }
2345
2346 type -> recursive = 1;
2347
2348 int num_fields = type -> num_decl;
2349 oberon_object_t * field = type -> decl;
2350 for(int i = 0; i < num_fields; i++)
2351 {
2352 oberon_prevent_recursive_object(ctx, field);
2353 field = field -> next;
2354 }
2355
2356 type -> recursive = 0;
2357 }
2358
2359 static void
2360 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2361 {
2362 if(type -> class != OBERON_TYPE_ARRAY)
2363 {
2364 return;
2365 }
2366
2367 if(type -> recursive)
2368 {
2369 oberon_error(ctx, "recursive array declaration");
2370 }
2371
2372 type -> recursive = 1;
2373
2374 oberon_prevent_recursive_type(ctx, type -> base);
2375
2376 type -> recursive = 0;
2377 }
2378
2379 static void
2380 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2381 {
2382 if(type -> class == OBERON_TYPE_POINTER)
2383 {
2384 oberon_prevent_recursive_pointer(ctx, type);
2385 }
2386 else if(type -> class == OBERON_TYPE_RECORD)
2387 {
2388 oberon_prevent_recursive_record(ctx, type);
2389 }
2390 else if(type -> class == OBERON_TYPE_ARRAY)
2391 {
2392 oberon_prevent_recursive_array(ctx, type);
2393 }
2394 else if(type -> class == OBERON_TYPE_PROCEDURE)
2395 {
2396 oberon_prevent_recursive_procedure(ctx, type);
2397 }
2398 }
2399
2400 static void
2401 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2402 {
2403 switch(x -> class)
2404 {
2405 case OBERON_CLASS_VAR:
2406 case OBERON_CLASS_TYPE:
2407 case OBERON_CLASS_PARAM:
2408 case OBERON_CLASS_VAR_PARAM:
2409 case OBERON_CLASS_FIELD:
2410 oberon_prevent_recursive_type(ctx, x -> type);
2411 break;
2412 case OBERON_CLASS_CONST:
2413 case OBERON_CLASS_PROC:
2414 case OBERON_CLASS_MODULE:
2415 break;
2416 default:
2417 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2418 break;
2419 }
2420 }
2421
2422 static void
2423 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2424 {
2425 oberon_object_t * x = ctx -> decl -> list -> next;
2426
2427 while(x)
2428 {
2429 oberon_prevent_recursive_object(ctx, x);
2430 x = x -> next;
2431 }
2432 }
2433
2434 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2435 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2436
2437 static void
2438 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2439 {
2440 if(type -> class != OBERON_TYPE_RECORD)
2441 {
2442 return;
2443 }
2444
2445 int num_fields = type -> num_decl;
2446 oberon_object_t * field = type -> decl;
2447 for(int i = 0; i < num_fields; i++)
2448 {
2449 if(field -> type -> class == OBERON_TYPE_POINTER)
2450 {
2451 oberon_initialize_type(ctx, field -> type);
2452 }
2453
2454 oberon_initialize_object(ctx, field);
2455 field = field -> next;
2456 }
2457
2458 oberon_generator_init_record(ctx, type);
2459 }
2460
2461 static void
2462 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2463 {
2464 if(type -> class == OBERON_TYPE_VOID)
2465 {
2466 oberon_error(ctx, "undeclarated type");
2467 }
2468
2469 if(type -> initialized)
2470 {
2471 return;
2472 }
2473
2474 type -> initialized = 1;
2475
2476 if(type -> class == OBERON_TYPE_POINTER)
2477 {
2478 oberon_initialize_type(ctx, type -> base);
2479 oberon_generator_init_type(ctx, type);
2480 }
2481 else if(type -> class == OBERON_TYPE_ARRAY)
2482 {
2483 if(type -> size != 0)
2484 {
2485 if(type -> base -> class == OBERON_TYPE_ARRAY)
2486 {
2487 if(type -> base -> size == 0)
2488 {
2489 oberon_error(ctx, "open array not allowed as array element");
2490 }
2491 }
2492 }
2493
2494 oberon_initialize_type(ctx, type -> base);
2495 oberon_generator_init_type(ctx, type);
2496 }
2497 else if(type -> class == OBERON_TYPE_RECORD)
2498 {
2499 oberon_generator_init_type(ctx, type);
2500 oberon_initialize_record_fields(ctx, type);
2501 }
2502 else if(type -> class == OBERON_TYPE_PROCEDURE)
2503 {
2504 int num_fields = type -> num_decl;
2505 oberon_object_t * field = type -> decl;
2506 for(int i = 0; i < num_fields; i++)
2507 {
2508 oberon_initialize_object(ctx, field);
2509 field = field -> next;
2510 }
2511
2512 oberon_generator_init_type(ctx, type);
2513 }
2514 else
2515 {
2516 oberon_generator_init_type(ctx, type);
2517 }
2518 }
2519
2520 static void
2521 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2522 {
2523 if(x -> initialized)
2524 {
2525 return;
2526 }
2527
2528 x -> initialized = 1;
2529
2530 switch(x -> class)
2531 {
2532 case OBERON_CLASS_TYPE:
2533 oberon_initialize_type(ctx, x -> type);
2534 break;
2535 case OBERON_CLASS_VAR:
2536 case OBERON_CLASS_FIELD:
2537 if(x -> type -> class == OBERON_TYPE_ARRAY)
2538 {
2539 if(x -> type -> size == 0)
2540 {
2541 oberon_error(ctx, "open array not allowed as variable or field");
2542 }
2543 }
2544 oberon_initialize_type(ctx, x -> type);
2545 oberon_generator_init_var(ctx, x);
2546 break;
2547 case OBERON_CLASS_PARAM:
2548 case OBERON_CLASS_VAR_PARAM:
2549 oberon_initialize_type(ctx, x -> type);
2550 oberon_generator_init_var(ctx, x);
2551 break;
2552 case OBERON_CLASS_CONST:
2553 case OBERON_CLASS_PROC:
2554 case OBERON_CLASS_MODULE:
2555 break;
2556 default:
2557 oberon_error(ctx, "oberon_initialize_object: wat");
2558 break;
2559 }
2560 }
2561
2562 static void
2563 oberon_initialize_decl(oberon_context_t * ctx)
2564 {
2565 oberon_object_t * x = ctx -> decl -> list;
2566
2567 while(x -> next)
2568 {
2569 oberon_initialize_object(ctx, x -> next);
2570 x = x -> next;
2571 }
2572 }
2573
2574 static void
2575 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2576 {
2577 oberon_object_t * x = ctx -> decl -> list;
2578
2579 while(x -> next)
2580 {
2581 if(x -> next -> class == OBERON_CLASS_PROC)
2582 {
2583 if(x -> next -> linked == 0)
2584 {
2585 oberon_error(ctx, "unresolved forward declaration");
2586 }
2587 }
2588 x = x -> next;
2589 }
2590 }
2591
2592 static void
2593 oberon_decl_seq(oberon_context_t * ctx)
2594 {
2595 if(ctx -> token == CONST)
2596 {
2597 oberon_assert_token(ctx, CONST);
2598 while(ctx -> token == IDENT)
2599 {
2600 oberon_const_decl(ctx);
2601 oberon_assert_token(ctx, SEMICOLON);
2602 }
2603 }
2604
2605 if(ctx -> token == TYPE)
2606 {
2607 oberon_assert_token(ctx, TYPE);
2608 while(ctx -> token == IDENT)
2609 {
2610 oberon_type_decl(ctx);
2611 oberon_assert_token(ctx, SEMICOLON);
2612 }
2613 }
2614
2615 if(ctx -> token == VAR)
2616 {
2617 oberon_assert_token(ctx, VAR);
2618 while(ctx -> token == IDENT)
2619 {
2620 oberon_var_decl(ctx);
2621 oberon_assert_token(ctx, SEMICOLON);
2622 }
2623 }
2624
2625 oberon_prevent_recursive_decl(ctx);
2626 oberon_initialize_decl(ctx);
2627
2628 while(ctx -> token == PROCEDURE)
2629 {
2630 oberon_proc_decl(ctx);
2631 oberon_assert_token(ctx, SEMICOLON);
2632 }
2633
2634 oberon_prevent_undeclarated_procedures(ctx);
2635 }
2636
2637 static void
2638 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2639 {
2640 if(dst -> read_only)
2641 {
2642 oberon_error(ctx, "read-only destination");
2643 }
2644
2645 src = oberon_autocast_to(ctx, src, dst -> result);
2646 oberon_generate_assign(ctx, src, dst);
2647 }
2648
2649 static void
2650 oberon_statement(oberon_context_t * ctx)
2651 {
2652 oberon_expr_t * item1;
2653 oberon_expr_t * item2;
2654
2655 if(ctx -> token == IDENT)
2656 {
2657 item1 = oberon_designator(ctx);
2658 if(ctx -> token == ASSIGN)
2659 {
2660 oberon_assert_token(ctx, ASSIGN);
2661 item2 = oberon_expr(ctx);
2662 oberon_assign(ctx, item2, item1);
2663 }
2664 else
2665 {
2666 oberon_opt_proc_parens(ctx, item1);
2667 }
2668 }
2669 else if(ctx -> token == RETURN)
2670 {
2671 oberon_assert_token(ctx, RETURN);
2672 if(ISEXPR(ctx -> token))
2673 {
2674 oberon_expr_t * expr;
2675 expr = oberon_expr(ctx);
2676 oberon_make_return(ctx, expr);
2677 }
2678 else
2679 {
2680 oberon_make_return(ctx, NULL);
2681 }
2682 }
2683 }
2684
2685 static void
2686 oberon_statement_seq(oberon_context_t * ctx)
2687 {
2688 oberon_statement(ctx);
2689 while(ctx -> token == SEMICOLON)
2690 {
2691 oberon_assert_token(ctx, SEMICOLON);
2692 oberon_statement(ctx);
2693 }
2694 }
2695
2696 static void
2697 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
2698 {
2699 oberon_module_t * m = ctx -> module_list;
2700 while(m && strcmp(m -> name, name) != 0)
2701 {
2702 m = m -> next;
2703 }
2704
2705 if(m == NULL)
2706 {
2707 const char * code;
2708 code = ctx -> import_module(name);
2709 if(code == NULL)
2710 {
2711 oberon_error(ctx, "no such module");
2712 }
2713
2714 m = oberon_compile_module(ctx, code);
2715 assert(m);
2716 }
2717
2718 if(m -> ready == 0)
2719 {
2720 oberon_error(ctx, "cyclic module import");
2721 }
2722
2723 oberon_object_t * ident;
2724 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
2725 ident -> module = m;
2726 }
2727
2728 static void
2729 oberon_import_decl(oberon_context_t * ctx)
2730 {
2731 char * alias;
2732 char * name;
2733
2734 alias = name = oberon_assert_ident(ctx);
2735 if(ctx -> token == ASSIGN)
2736 {
2737 oberon_assert_token(ctx, ASSIGN);
2738 name = oberon_assert_ident(ctx);
2739 }
2740
2741 oberon_import_module(ctx, alias, name);
2742 }
2743
2744 static void
2745 oberon_import_list(oberon_context_t * ctx)
2746 {
2747 oberon_assert_token(ctx, IMPORT);
2748
2749 oberon_import_decl(ctx);
2750 while(ctx -> token == COMMA)
2751 {
2752 oberon_assert_token(ctx, COMMA);
2753 oberon_import_decl(ctx);
2754 }
2755
2756 oberon_assert_token(ctx, SEMICOLON);
2757 }
2758
2759 static void
2760 oberon_parse_module(oberon_context_t * ctx)
2761 {
2762 char * name1;
2763 char * name2;
2764 oberon_read_token(ctx);
2765
2766 oberon_assert_token(ctx, MODULE);
2767 name1 = oberon_assert_ident(ctx);
2768 oberon_assert_token(ctx, SEMICOLON);
2769 ctx -> mod -> name = name1;
2770
2771 oberon_generator_init_module(ctx, ctx -> mod);
2772
2773 if(ctx -> token == IMPORT)
2774 {
2775 oberon_import_list(ctx);
2776 }
2777
2778 oberon_decl_seq(ctx);
2779
2780 oberon_generate_begin_module(ctx);
2781 if(ctx -> token == BEGIN)
2782 {
2783 oberon_assert_token(ctx, BEGIN);
2784 oberon_statement_seq(ctx);
2785 }
2786 oberon_generate_end_module(ctx);
2787
2788 oberon_assert_token(ctx, END);
2789 name2 = oberon_assert_ident(ctx);
2790 oberon_assert_token(ctx, DOT);
2791
2792 if(strcmp(name1, name2) != 0)
2793 {
2794 oberon_error(ctx, "module name not matched");
2795 }
2796
2797 oberon_generator_fini_module(ctx -> mod);
2798 }
2799
2800 // =======================================================================
2801 // LIBRARY
2802 // =======================================================================
2803
2804 static void
2805 register_default_types(oberon_context_t * ctx)
2806 {
2807 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2808 oberon_generator_init_type(ctx, ctx -> void_type);
2809
2810 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
2811 ctx -> void_ptr_type -> base = ctx -> void_type;
2812 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
2813
2814 ctx -> bool_type = oberon_new_type_boolean();
2815 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
2816
2817 ctx -> byte_type = oberon_new_type_integer(1);
2818 oberon_define_type(ctx -> world_scope, "BYTE", ctx -> byte_type, 1);
2819
2820 ctx -> shortint_type = oberon_new_type_integer(2);
2821 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> shortint_type, 1);
2822
2823 ctx -> int_type = oberon_new_type_integer(4);
2824 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
2825
2826 ctx -> longint_type = oberon_new_type_integer(8);
2827 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> longint_type, 1);
2828
2829 ctx -> real_type = oberon_new_type_real(4);
2830 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
2831
2832 ctx -> longreal_type = oberon_new_type_real(8);
2833 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
2834 }
2835
2836 static void
2837 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
2838 {
2839 oberon_object_t * proc;
2840 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
2841 proc -> sysproc = 1;
2842 proc -> genfunc = f;
2843 proc -> genproc = p;
2844 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
2845 }
2846
2847 static oberon_expr_t *
2848 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2849 {
2850 if(num_args < 1)
2851 {
2852 oberon_error(ctx, "too few arguments");
2853 }
2854
2855 if(num_args > 1)
2856 {
2857 oberon_error(ctx, "too mach arguments");
2858 }
2859
2860 oberon_expr_t * arg;
2861 arg = list_args;
2862
2863 oberon_type_t * result_type;
2864 result_type = arg -> result;
2865
2866 if(result_type -> class != OBERON_TYPE_INTEGER)
2867 {
2868 oberon_error(ctx, "ABS accepts only integers");
2869 }
2870
2871
2872 oberon_expr_t * expr;
2873 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
2874 return expr;
2875 }
2876
2877 static void
2878 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2879 {
2880 if(num_args < 1)
2881 {
2882 oberon_error(ctx, "too few arguments");
2883 }
2884
2885 oberon_expr_t * dst;
2886 dst = list_args;
2887
2888 oberon_type_t * type;
2889 type = dst -> result;
2890
2891 if(type -> class != OBERON_TYPE_POINTER)
2892 {
2893 oberon_error(ctx, "not a pointer");
2894 }
2895
2896 type = type -> base;
2897
2898 oberon_expr_t * src;
2899 src = oberon_new_item(MODE_NEW, dst -> result, 0);
2900 src -> item.num_args = 0;
2901 src -> item.args = NULL;
2902
2903 int max_args = 1;
2904 if(type -> class == OBERON_TYPE_ARRAY)
2905 {
2906 if(type -> size == 0)
2907 {
2908 oberon_type_t * x = type;
2909 while(x -> class == OBERON_TYPE_ARRAY)
2910 {
2911 if(x -> size == 0)
2912 {
2913 max_args += 1;
2914 }
2915 x = x -> base;
2916 }
2917 }
2918
2919 if(num_args < max_args)
2920 {
2921 oberon_error(ctx, "too few arguments");
2922 }
2923
2924 if(num_args > max_args)
2925 {
2926 oberon_error(ctx, "too mach arguments");
2927 }
2928
2929 int num_sizes = max_args - 1;
2930 oberon_expr_t * size_list = list_args -> next;
2931
2932 oberon_expr_t * arg = size_list;
2933 for(int i = 0; i < max_args - 1; i++)
2934 {
2935 if(arg -> result -> class != OBERON_TYPE_INTEGER)
2936 {
2937 oberon_error(ctx, "size must be integer");
2938 }
2939 arg = arg -> next;
2940 }
2941
2942 src -> item.num_args = num_sizes;
2943 src -> item.args = size_list;
2944 }
2945 else if(type -> class != OBERON_TYPE_RECORD)
2946 {
2947 oberon_error(ctx, "oberon_make_new_call: wat");
2948 }
2949
2950 if(num_args > max_args)
2951 {
2952 oberon_error(ctx, "too mach arguments");
2953 }
2954
2955 oberon_assign(ctx, src, dst);
2956 }
2957
2958 oberon_context_t *
2959 oberon_create_context(ModuleImportCallback import_module)
2960 {
2961 oberon_context_t * ctx = calloc(1, sizeof *ctx);
2962
2963 oberon_scope_t * world_scope;
2964 world_scope = oberon_open_scope(ctx);
2965 ctx -> world_scope = world_scope;
2966
2967 ctx -> import_module = import_module;
2968
2969 oberon_generator_init_context(ctx);
2970
2971 register_default_types(ctx);
2972 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
2973 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
2974
2975 return ctx;
2976 }
2977
2978 void
2979 oberon_destroy_context(oberon_context_t * ctx)
2980 {
2981 oberon_generator_destroy_context(ctx);
2982 free(ctx);
2983 }
2984
2985 oberon_module_t *
2986 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
2987 {
2988 const char * code = ctx -> code;
2989 int code_index = ctx -> code_index;
2990 char c = ctx -> c;
2991 int token = ctx -> token;
2992 char * string = ctx -> string;
2993 int integer = ctx -> integer;
2994 int real = ctx -> real;
2995 bool longmode = ctx -> longmode;
2996 oberon_scope_t * decl = ctx -> decl;
2997 oberon_module_t * mod = ctx -> mod;
2998
2999 oberon_scope_t * module_scope;
3000 module_scope = oberon_open_scope(ctx);
3001
3002 oberon_module_t * module;
3003 module = calloc(1, sizeof *module);
3004 module -> decl = module_scope;
3005 module -> next = ctx -> module_list;
3006
3007 ctx -> mod = module;
3008 ctx -> module_list = module;
3009
3010 oberon_init_scaner(ctx, newcode);
3011 oberon_parse_module(ctx);
3012
3013 module -> ready = 1;
3014
3015 ctx -> code = code;
3016 ctx -> code_index = code_index;
3017 ctx -> c = c;
3018 ctx -> token = token;
3019 ctx -> string = string;
3020 ctx -> integer = integer;
3021 ctx -> real = real;
3022 ctx -> longmode = longmode;
3023 ctx -> decl = decl;
3024 ctx -> mod = mod;
3025
3026 return module;
3027 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024