DEADSOFTWARE

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