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