DEADSOFTWARE

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