DEADSOFTWARE

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