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