DEADSOFTWARE

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