DEADSOFTWARE

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