DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / dsw-obn.git / blob


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