DEADSOFTWARE

Запрещён возврат массива или записи функцией
[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>
10 #include "../include/oberon.h"
12 #include "oberon-internals.h"
13 #include "generator.h"
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 };
84 // =======================================================================
85 // UTILS
86 // =======================================================================
88 static void
89 oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args);
91 static void
92 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
93 {
94 va_list ptr;
95 va_start(ptr, fmt);
96 fprintf(stderr, "error: ");
97 vfprintf(stderr, fmt, ptr);
98 fprintf(stderr, "\n");
99 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
100 fprintf(stderr, " c = %c\n", ctx -> c);
101 fprintf(stderr, " token = %i\n", ctx -> token);
102 va_end(ptr);
103 exit(1);
106 static oberon_type_t *
107 oberon_new_type_ptr(int class)
109 oberon_type_t * x = malloc(sizeof *x);
110 memset(x, 0, sizeof *x);
111 x -> class = class;
112 return x;
115 static oberon_type_t *
116 oberon_new_type_integer(int size)
118 oberon_type_t * x;
119 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
120 x -> size = size;
121 return x;
124 static oberon_type_t *
125 oberon_new_type_boolean()
127 oberon_type_t * x;
128 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
129 return x;
132 static oberon_type_t *
133 oberon_new_type_real(int size)
135 oberon_type_t * x;
136 x = oberon_new_type_ptr(OBERON_TYPE_REAL);
137 x -> size = size;
138 return x;
141 static oberon_type_t *
142 oberon_new_type_char(int size)
144 oberon_type_t * x;
145 x = oberon_new_type_ptr(OBERON_TYPE_CHAR);
146 x -> size = size;
147 return x;
150 static oberon_type_t *
151 oberon_new_type_string(int size)
153 oberon_type_t * x;
154 x = oberon_new_type_ptr(OBERON_TYPE_STRING);
155 x -> size = size;
156 return x;
159 static oberon_type_t *
160 oberon_new_type_set(int size)
162 oberon_type_t * x;
163 x = oberon_new_type_ptr(OBERON_TYPE_SET);
164 x -> size = size;
165 return x;
168 // =======================================================================
169 // TABLE
170 // =======================================================================
172 static oberon_scope_t *
173 oberon_open_scope(oberon_context_t * ctx)
175 oberon_scope_t * scope = calloc(1, sizeof *scope);
176 oberon_object_t * list = calloc(1, sizeof *list);
178 scope -> ctx = ctx;
179 scope -> list = list;
180 scope -> up = ctx -> decl;
182 if(scope -> up)
184 scope -> local = scope -> up -> local;
185 scope -> parent = scope -> up -> parent;
186 scope -> parent_type = scope -> up -> parent_type;
187 scope -> exit_label = scope -> up -> exit_label;
190 ctx -> decl = scope;
191 return scope;
194 static void
195 oberon_close_scope(oberon_scope_t * scope)
197 oberon_context_t * ctx = scope -> ctx;
198 ctx -> decl = scope -> up;
201 static oberon_object_t *
202 oberon_find_object_in_list(oberon_object_t * list, char * name)
204 oberon_object_t * x = list;
205 while(x -> next && strcmp(x -> next -> name, name) != 0)
207 x = x -> next;
209 return x -> next;
212 static oberon_object_t *
213 oberon_find_object(oberon_scope_t * scope, char * name, bool check_it)
215 oberon_object_t * result = NULL;
217 oberon_scope_t * s = scope;
218 while(result == NULL && s != NULL)
220 result = oberon_find_object_in_list(s -> list, name);
221 s = s -> up;
224 if(check_it && result == NULL)
226 oberon_error(scope -> ctx, "undefined ident %s", name);
229 return result;
232 static oberon_object_t *
233 oberon_create_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only)
235 oberon_object_t * newvar = malloc(sizeof *newvar);
236 memset(newvar, 0, sizeof *newvar);
237 newvar -> name = name;
238 newvar -> class = class;
239 newvar -> export = export;
240 newvar -> read_only = read_only;
241 newvar -> local = scope -> local;
242 newvar -> parent = scope -> parent;
243 newvar -> parent_type = scope -> parent_type;
244 newvar -> module = scope -> ctx -> mod;
245 return newvar;
248 static oberon_object_t *
249 oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only, bool check_upscope)
251 if(check_upscope)
253 if(oberon_find_object(scope -> up, name, false))
255 oberon_error(scope -> ctx, "already defined");
259 oberon_object_t * x = scope -> list;
260 while(x -> next && strcmp(x -> next -> name, name) != 0)
262 x = x -> next;
265 if(x -> next)
267 oberon_error(scope -> ctx, "already defined");
270 oberon_object_t * newvar;
271 newvar = oberon_create_object(scope, name, class, export, read_only);
272 x -> next = newvar;
274 return newvar;
277 static oberon_object_t *
278 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export)
280 oberon_object_t * id;
281 id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, false, false);
282 id -> type = type;
283 oberon_generator_init_type(scope -> ctx, type);
284 return id;
287 // =======================================================================
288 // SCANER
289 // =======================================================================
291 static void
292 oberon_get_char(oberon_context_t * ctx)
294 if(ctx -> code[ctx -> code_index])
296 ctx -> code_index += 1;
297 ctx -> c = ctx -> code[ctx -> code_index];
301 static void
302 oberon_init_scaner(oberon_context_t * ctx, const char * code)
304 ctx -> code = code;
305 ctx -> code_index = 0;
306 ctx -> c = ctx -> code[ctx -> code_index];
309 static void
310 oberon_read_ident(oberon_context_t * ctx)
312 int len = 0;
313 int i = ctx -> code_index;
315 int c = ctx -> code[i];
316 while(isalnum(c))
318 i += 1;
319 len += 1;
320 c = ctx -> code[i];
323 char * ident = malloc(len + 1);
324 memcpy(ident, &ctx->code[ctx->code_index], len);
325 ident[len] = 0;
327 ctx -> code_index = i;
328 ctx -> c = ctx -> code[i];
329 ctx -> string = ident;
330 ctx -> token = IDENT;
332 if(strcmp(ident, "MODULE") == 0)
334 ctx -> token = MODULE;
336 else if(strcmp(ident, "END") == 0)
338 ctx -> token = END;
340 else if(strcmp(ident, "VAR") == 0)
342 ctx -> token = VAR;
344 else if(strcmp(ident, "BEGIN") == 0)
346 ctx -> token = BEGIN;
348 else if(strcmp(ident, "OR") == 0)
350 ctx -> token = OR;
352 else if(strcmp(ident, "DIV") == 0)
354 ctx -> token = DIV;
356 else if(strcmp(ident, "MOD") == 0)
358 ctx -> token = MOD;
360 else if(strcmp(ident, "PROCEDURE") == 0)
362 ctx -> token = PROCEDURE;
364 else if(strcmp(ident, "RETURN") == 0)
366 ctx -> token = RETURN;
368 else if(strcmp(ident, "CONST") == 0)
370 ctx -> token = CONST;
372 else if(strcmp(ident, "TYPE") == 0)
374 ctx -> token = TYPE;
376 else if(strcmp(ident, "ARRAY") == 0)
378 ctx -> token = ARRAY;
380 else if(strcmp(ident, "OF") == 0)
382 ctx -> token = OF;
384 else if(strcmp(ident, "RECORD") == 0)
386 ctx -> token = RECORD;
388 else if(strcmp(ident, "POINTER") == 0)
390 ctx -> token = POINTER;
392 else if(strcmp(ident, "TO") == 0)
394 ctx -> token = TO;
396 else if(strcmp(ident, "NIL") == 0)
398 ctx -> token = NIL;
400 else if(strcmp(ident, "IMPORT") == 0)
402 ctx -> token = IMPORT;
404 else if(strcmp(ident, "IN") == 0)
406 ctx -> token = IN;
408 else if(strcmp(ident, "IS") == 0)
410 ctx -> token = IS;
412 else if(strcmp(ident, "IF") == 0)
414 ctx -> token = IF;
416 else if(strcmp(ident, "THEN") == 0)
418 ctx -> token = THEN;
420 else if(strcmp(ident, "ELSE") == 0)
422 ctx -> token = ELSE;
424 else if(strcmp(ident, "ELSIF") == 0)
426 ctx -> token = ELSIF;
428 else if(strcmp(ident, "WHILE") == 0)
430 ctx -> token = WHILE;
432 else if(strcmp(ident, "DO") == 0)
434 ctx -> token = DO;
436 else if(strcmp(ident, "REPEAT") == 0)
438 ctx -> token = REPEAT;
440 else if(strcmp(ident, "UNTIL") == 0)
442 ctx -> token = UNTIL;
444 else if(strcmp(ident, "FOR") == 0)
446 ctx -> token = FOR;
448 else if(strcmp(ident, "BY") == 0)
450 ctx -> token = BY;
452 else if(strcmp(ident, "LOOP") == 0)
454 ctx -> token = LOOP;
456 else if(strcmp(ident, "EXIT") == 0)
458 ctx -> token = EXIT;
460 else if(strcmp(ident, "CASE") == 0)
462 ctx -> token = CASE;
464 else if(strcmp(ident, "WITH") == 0)
466 ctx -> token = WITH;
470 #define ISHEXDIGIT(x) \
471 (((x) >= '0' && (x) <= '9') || ((x) >= 'A' && (x) <= 'F'))
473 static void
474 oberon_read_number(oberon_context_t * ctx)
476 long integer;
477 double real;
478 char * ident;
479 int start_i;
480 int exp_i;
481 int end_i;
483 /*
484 * mode = 0 == DEC
485 * mode = 1 == HEX
486 * mode = 2 == REAL
487 * mode = 3 == LONGREAL
488 * mode = 4 == CHAR
489 */
490 int mode = 0;
491 start_i = ctx -> code_index;
493 while(isdigit(ctx -> c))
495 oberon_get_char(ctx);
498 end_i = ctx -> code_index;
500 if(ISHEXDIGIT(ctx -> c))
502 mode = 1;
503 while(ISHEXDIGIT(ctx -> c))
505 oberon_get_char(ctx);
508 end_i = ctx -> code_index;
510 if(ctx -> c == 'H')
512 mode = 1;
513 oberon_get_char(ctx);
515 else if(ctx -> c == 'X')
517 mode = 4;
518 oberon_get_char(ctx);
520 else
522 oberon_error(ctx, "invalid hex number");
525 else if(ctx -> c == '.')
527 oberon_get_char(ctx);
528 if(ctx -> c == '.')
530 /* Чит: избегаем конфликта с DOTDOT */
531 ctx -> code_index -= 1;
533 else
535 mode = 2;
537 while(isdigit(ctx -> c))
539 oberon_get_char(ctx);
542 if(ctx -> c == 'E' || ctx -> c == 'D')
544 exp_i = ctx -> code_index;
546 if(ctx -> c == 'D')
548 mode = 3;
551 oberon_get_char(ctx);
553 if(ctx -> c == '+' || ctx -> c == '-')
555 oberon_get_char(ctx);
558 while(isdigit(ctx -> c))
560 oberon_get_char(ctx);
561 }
564 end_i = ctx -> code_index;
567 if(mode == 0)
569 if(ctx -> c == 'H')
571 mode = 1;
572 oberon_get_char(ctx);
574 else if(ctx -> c == 'X')
576 mode = 4;
577 oberon_get_char(ctx);
581 int len = end_i - start_i;
582 ident = malloc(len + 1);
583 memcpy(ident, &ctx -> code[start_i], len);
584 ident[len] = 0;
586 ctx -> longmode = false;
587 if(mode == 3)
589 int i = exp_i - start_i;
590 ident[i] = 'E';
591 ctx -> longmode = true;
594 switch(mode)
596 case 0:
597 integer = atol(ident);
598 real = integer;
599 ctx -> token = INTEGER;
600 break;
601 case 1:
602 sscanf(ident, "%lx", &integer);
603 real = integer;
604 ctx -> token = INTEGER;
605 break;
606 case 2:
607 case 3:
608 sscanf(ident, "%lf", &real);
609 ctx -> token = REAL;
610 break;
611 case 4:
612 sscanf(ident, "%lx", &integer);
613 real = integer;
614 ctx -> token = CHAR;
615 break;
616 default:
617 oberon_error(ctx, "oberon_read_number: wat");
618 break;
621 ctx -> string = ident;
622 ctx -> integer = integer;
623 ctx -> real = real;
626 static void
627 oberon_skip_space(oberon_context_t * ctx)
629 while(isspace(ctx -> c))
631 oberon_get_char(ctx);
635 static void
636 oberon_read_comment(oberon_context_t * ctx)
638 int nesting = 1;
639 while(nesting >= 1)
641 if(ctx -> c == '(')
643 oberon_get_char(ctx);
644 if(ctx -> c == '*')
646 oberon_get_char(ctx);
647 nesting += 1;
650 else if(ctx -> c == '*')
652 oberon_get_char(ctx);
653 if(ctx -> c == ')')
655 oberon_get_char(ctx);
656 nesting -= 1;
659 else if(ctx -> c == 0)
661 oberon_error(ctx, "unterminated comment");
663 else
665 oberon_get_char(ctx);
670 static void oberon_read_string(oberon_context_t * ctx)
672 int c = ctx -> c;
673 oberon_get_char(ctx);
675 int start = ctx -> code_index;
677 while(ctx -> c != 0 && ctx -> c != c)
679 oberon_get_char(ctx);
682 if(ctx -> c == 0)
684 oberon_error(ctx, "unterminated string");
687 int end = ctx -> code_index;
689 oberon_get_char(ctx);
691 char * string = calloc(1, end - start + 1);
692 strncpy(string, &ctx -> code[start], end - start);
694 ctx -> token = STRING;
695 ctx -> string = string;
698 static void oberon_read_token(oberon_context_t * ctx);
700 static void
701 oberon_read_symbol(oberon_context_t * ctx)
703 int c = ctx -> c;
704 switch(c)
706 case 0:
707 ctx -> token = EOF_;
708 break;
709 case ';':
710 ctx -> token = SEMICOLON;
711 oberon_get_char(ctx);
712 break;
713 case ':':
714 ctx -> token = COLON;
715 oberon_get_char(ctx);
716 if(ctx -> c == '=')
718 ctx -> token = ASSIGN;
719 oberon_get_char(ctx);
721 break;
722 case '.':
723 ctx -> token = DOT;
724 oberon_get_char(ctx);
725 if(ctx -> c == '.')
727 ctx -> token = DOTDOT;
728 oberon_get_char(ctx);
730 break;
731 case '(':
732 ctx -> token = LPAREN;
733 oberon_get_char(ctx);
734 if(ctx -> c == '*')
736 oberon_get_char(ctx);
737 oberon_read_comment(ctx);
738 oberon_read_token(ctx);
740 break;
741 case ')':
742 ctx -> token = RPAREN;
743 oberon_get_char(ctx);
744 break;
745 case '=':
746 ctx -> token = EQUAL;
747 oberon_get_char(ctx);
748 break;
749 case '#':
750 ctx -> token = NEQ;
751 oberon_get_char(ctx);
752 break;
753 case '<':
754 ctx -> token = LESS;
755 oberon_get_char(ctx);
756 if(ctx -> c == '=')
758 ctx -> token = LEQ;
759 oberon_get_char(ctx);
761 break;
762 case '>':
763 ctx -> token = GREAT;
764 oberon_get_char(ctx);
765 if(ctx -> c == '=')
767 ctx -> token = GEQ;
768 oberon_get_char(ctx);
770 break;
771 case '+':
772 ctx -> token = PLUS;
773 oberon_get_char(ctx);
774 break;
775 case '-':
776 ctx -> token = MINUS;
777 oberon_get_char(ctx);
778 break;
779 case '*':
780 ctx -> token = STAR;
781 oberon_get_char(ctx);
782 if(ctx -> c == ')')
784 oberon_get_char(ctx);
785 oberon_error(ctx, "unstarted comment");
787 break;
788 case '/':
789 ctx -> token = SLASH;
790 oberon_get_char(ctx);
791 break;
792 case '&':
793 ctx -> token = AND;
794 oberon_get_char(ctx);
795 break;
796 case '~':
797 ctx -> token = NOT;
798 oberon_get_char(ctx);
799 break;
800 case ',':
801 ctx -> token = COMMA;
802 oberon_get_char(ctx);
803 break;
804 case '[':
805 ctx -> token = LBRACK;
806 oberon_get_char(ctx);
807 break;
808 case ']':
809 ctx -> token = RBRACK;
810 oberon_get_char(ctx);
811 break;
812 case '^':
813 ctx -> token = UPARROW;
814 oberon_get_char(ctx);
815 break;
816 case '"':
817 oberon_read_string(ctx);
818 break;
819 case '\'':
820 oberon_read_string(ctx);
821 break;
822 case '{':
823 ctx -> token = LBRACE;
824 oberon_get_char(ctx);
825 break;
826 case '}':
827 ctx -> token = RBRACE;
828 oberon_get_char(ctx);
829 break;
830 case '|':
831 ctx -> token = BAR;
832 oberon_get_char(ctx);
833 break;
834 default:
835 oberon_error(ctx, "invalid char %c", ctx -> c);
836 break;
840 static void
841 oberon_read_token(oberon_context_t * ctx)
843 oberon_skip_space(ctx);
845 int c = ctx -> c;
846 if(isalpha(c))
848 oberon_read_ident(ctx);
850 else if(isdigit(c))
852 oberon_read_number(ctx);
854 else
856 oberon_read_symbol(ctx);
860 // =======================================================================
861 // EXPRESSION
862 // =======================================================================
864 static void oberon_expect_token(oberon_context_t * ctx, int token);
865 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
866 static void oberon_assert_token(oberon_context_t * ctx, int token);
867 static char * oberon_assert_ident(oberon_context_t * ctx);
868 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
869 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
870 static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr);
872 static oberon_expr_t *
873 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
875 oberon_oper_t * operator;
876 operator = malloc(sizeof *operator);
877 memset(operator, 0, sizeof *operator);
879 operator -> is_item = 0;
880 operator -> result = result;
881 operator -> read_only = 1;
882 operator -> op = op;
883 operator -> left = left;
884 operator -> right = right;
886 return (oberon_expr_t *) operator;
889 static oberon_expr_t *
890 oberon_new_item(int mode, oberon_type_t * result, int read_only)
892 oberon_item_t * item;
893 item = malloc(sizeof *item);
894 memset(item, 0, sizeof *item);
896 item -> is_item = 1;
897 item -> result = result;
898 item -> read_only = read_only;
899 item -> mode = mode;
901 return (oberon_expr_t *)item;
904 static oberon_expr_t *
905 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
907 oberon_expr_t * expr;
908 oberon_type_t * result;
910 result = a -> result;
912 if(token == MINUS)
914 if(result -> class == OBERON_TYPE_SET)
916 expr = oberon_new_operator(OP_COMPLEMENTATION, result, a, NULL);
918 else if(result -> class == OBERON_TYPE_INTEGER)
920 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
922 else
924 oberon_error(ctx, "incompatible operator type");
927 else if(token == NOT)
929 if(result -> class != OBERON_TYPE_BOOLEAN)
931 oberon_error(ctx, "incompatible operator type");
934 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
936 else
938 oberon_error(ctx, "oberon_make_unary_op: wat");
941 return expr;
944 static void
945 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
947 oberon_expr_t * last;
949 *num_expr = 1;
950 if(const_expr)
952 *first = last = (oberon_expr_t *) oberon_const_expr(ctx);
954 else
956 *first = last = oberon_expr(ctx);
958 while(ctx -> token == COMMA)
960 oberon_assert_token(ctx, COMMA);
961 oberon_expr_t * current;
963 if(const_expr)
965 current = (oberon_expr_t *) oberon_const_expr(ctx);
967 else
969 current = oberon_expr(ctx);
972 last -> next = current;
973 last = current;
974 *num_expr += 1;
978 static oberon_expr_t *
979 oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
981 return oberon_new_operator(OP_CAST, pref, expr, NULL);
984 static oberon_expr_t *
985 oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec)
987 oberon_type_t * from = expr -> result;
988 oberon_type_t * to = rec;
990 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
992 from = from -> base;
993 to = to -> base;
996 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
998 oberon_error(ctx, "must be record type");
1001 return oberon_cast_expr(ctx, expr, rec);
1004 static oberon_type_t *
1005 oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1007 oberon_type_t * result;
1008 if(a -> class == OBERON_TYPE_REAL && b -> class == OBERON_TYPE_INTEGER)
1010 result = a;
1012 else if(b -> class == OBERON_TYPE_REAL && a -> class == OBERON_TYPE_INTEGER)
1014 result = b;
1016 else if(a -> class != b -> class)
1018 oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types");
1020 else if(a -> size > b -> size)
1022 result = a;
1024 else
1026 result = b;
1029 return result;
1032 static void
1033 oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to)
1035 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
1037 from = from -> base;
1038 to = to -> base;
1041 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
1043 oberon_error(ctx, "not a record");
1046 oberon_type_t * t = from;
1047 while(t != NULL && t != to)
1049 t = t -> base;
1052 if(t == NULL)
1054 oberon_error(ctx, "incompatible record types");
1058 static void
1059 oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst)
1061 if(dst -> read_only)
1063 oberon_error(ctx, "read-only destination");
1066 if(dst -> is_item == false)
1068 oberon_error(ctx, "not variable");
1071 switch(dst -> item.mode)
1073 case MODE_VAR:
1074 case MODE_CALL:
1075 case MODE_INDEX:
1076 case MODE_FIELD:
1077 case MODE_DEREF:
1078 case MODE_NEW:
1079 /* accept */
1080 break;
1081 default:
1082 oberon_error(ctx, "not variable");
1083 break;
1087 static void
1088 oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src)
1090 if(src -> is_item)
1092 if(src -> item.mode == MODE_TYPE)
1094 oberon_error(ctx, "not variable");
1099 static oberon_expr_t *
1100 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
1102 // Допускается:
1103 // Если классы типов равны
1104 // Если INTEGER переводится в REAL
1105 // Если STRING переводится в CHAR
1106 // Если STRING переводится в ARRAY OF CHAR
1107 // Если NIL переводится в POINTER
1108 // Если NIL переводится в PROCEDURE
1110 oberon_check_src(ctx, expr);
1112 bool error = false;
1113 if(pref -> class != expr -> result -> class)
1115 if(expr -> result -> class == OBERON_TYPE_NIL)
1117 if(pref -> class != OBERON_TYPE_POINTER
1118 && pref -> class != OBERON_TYPE_PROCEDURE)
1120 error = true;
1123 else if(expr -> result -> class == OBERON_TYPE_STRING)
1125 if(pref -> class == OBERON_TYPE_CHAR)
1127 if(expr -> is_item && expr -> item.mode == MODE_STRING)
1129 if(strlen(expr -> item.string) != 1)
1131 error = true;
1134 else
1136 error = true;
1139 else if(pref -> class == OBERON_TYPE_ARRAY)
1141 if(pref -> base -> class != OBERON_TYPE_CHAR)
1143 error = true;
1146 else
1148 error = true;
1151 else if(expr -> result -> class == OBERON_TYPE_INTEGER)
1153 if(pref -> class != OBERON_TYPE_REAL)
1155 error = true;
1158 else
1160 error = true;
1164 if(error)
1166 oberon_error(ctx, "oberon_autocast_to: incompatible types");
1169 if(pref -> class == OBERON_TYPE_CHAR)
1171 if(expr -> result -> class == OBERON_TYPE_STRING)
1173 int c = expr -> item.string[0];
1174 expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true);
1175 expr -> item.integer = c;
1178 else if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL)
1180 if(expr -> result -> size > pref -> size)
1182 oberon_error(ctx, "incompatible size");
1184 else
1186 expr = oberon_cast_expr(ctx, expr, pref);
1189 else if(pref -> class == OBERON_TYPE_RECORD)
1191 oberon_check_record_compatibility(ctx, expr -> result, pref);
1192 expr = oberno_make_record_cast(ctx, expr, pref);
1194 else if(pref -> class == OBERON_TYPE_POINTER)
1196 assert(pref -> base);
1197 if(expr -> result -> class == OBERON_TYPE_NIL)
1199 // do nothing
1201 else if(expr -> result -> base -> class == OBERON_TYPE_RECORD)
1203 oberon_check_record_compatibility(ctx, expr -> result, pref);
1204 expr = oberno_make_record_cast(ctx, expr, pref);
1206 else if(expr -> result -> base != pref -> base)
1208 oberon_error(ctx, "incompatible pointer types");
1212 return expr;
1215 static void
1216 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb)
1218 oberon_type_t * a = (*ea) -> result;
1219 oberon_type_t * b = (*eb) -> result;
1220 oberon_type_t * preq = oberon_get_equal_expr_type(ctx, a, b);
1221 *ea = oberon_autocast_to(ctx, *ea, preq);
1222 *eb = oberon_autocast_to(ctx, *eb, preq);
1225 static void
1226 oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig)
1228 if(desig -> mode != MODE_CALL)
1230 oberon_error(ctx, "expected mode CALL");
1233 oberon_type_t * fn = desig -> parent -> result;
1234 int num_args = desig -> num_args;
1235 int num_decl = fn -> num_decl;
1237 if(num_args < num_decl)
1239 oberon_error(ctx, "too few arguments");
1241 else if(num_args > num_decl)
1243 oberon_error(ctx, "too many arguments");
1246 /* Делаем проверку на запись и делаем автокаст */
1247 oberon_expr_t * casted[num_args];
1248 oberon_expr_t * arg = desig -> args;
1249 oberon_object_t * param = fn -> decl;
1250 for(int i = 0; i < num_args; i++)
1252 if(param -> class == OBERON_CLASS_VAR_PARAM)
1254 if(arg -> result != param -> type)
1256 oberon_error(ctx, "incompatible type");
1258 if(arg -> read_only)
1260 oberon_error(ctx, "assign to read-only var");
1262 casted[i] = arg;
1264 else
1266 casted[i] = oberon_autocast_to(ctx, arg, param -> type);
1269 arg = arg -> next;
1270 param = param -> next;
1273 /* Создаём новый список выражений */
1274 if(num_args > 0)
1276 arg = casted[0];
1277 for(int i = 0; i < num_args - 1; i++)
1279 casted[i] -> next = casted[i + 1];
1281 desig -> args = arg;
1285 static oberon_expr_t *
1286 oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1288 oberon_type_t * signature = item -> result;
1289 if(signature -> class != OBERON_TYPE_PROCEDURE)
1291 oberon_error(ctx, "not a procedure");
1294 oberon_expr_t * call;
1296 if(signature -> sysproc)
1298 if(signature -> genfunc == NULL)
1300 oberon_error(ctx, "not a function-procedure");
1303 call = signature -> genfunc(ctx, num_args, list_args);
1305 else
1307 if(signature -> base -> class == OBERON_TYPE_NOTYPE)
1309 oberon_error(ctx, "attempt to call procedure in expression");
1312 call = oberon_new_item(MODE_CALL, signature -> base, true);
1313 call -> item.parent = item;
1314 call -> item.num_args = num_args;
1315 call -> item.args = list_args;
1316 oberon_autocast_call(ctx, (oberon_item_t *) call);
1319 return call;
1322 static void
1323 oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1325 oberon_type_t * signature = item -> result;
1326 if(signature -> class != OBERON_TYPE_PROCEDURE)
1328 oberon_error(ctx, "not a procedure");
1331 oberon_expr_t * call;
1333 if(signature -> sysproc)
1335 if(signature -> genproc == NULL)
1337 oberon_error(ctx, "not a procedure");
1340 signature -> genproc(ctx, num_args, list_args);
1342 else
1344 if(signature -> base -> class != OBERON_TYPE_NOTYPE)
1346 oberon_error(ctx, "attempt to call function as non-typed procedure");
1349 call = oberon_new_item(MODE_CALL, signature -> base, true);
1350 call -> item.parent = item;
1351 call -> item.num_args = num_args;
1352 call -> item.args = list_args;
1353 oberon_autocast_call(ctx, (oberon_item_t *) call);
1354 oberon_generate_call_proc(ctx, call);
1358 #define ISEXPR(x) \
1359 (((x) == PLUS) \
1360 || ((x) == MINUS) \
1361 || ((x) == IDENT) \
1362 || ((x) == INTEGER) \
1363 || ((x) == REAL) \
1364 || ((x) == CHAR) \
1365 || ((x) == STRING) \
1366 || ((x) == NIL) \
1367 || ((x) == LPAREN) \
1368 || ((x) == NOT))
1370 static oberon_expr_t *
1371 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
1373 if(expr -> result -> class != OBERON_TYPE_POINTER)
1375 oberon_error(ctx, "not a pointer");
1378 assert(expr -> is_item);
1380 oberon_expr_t * selector;
1381 selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
1382 selector -> item.parent = (oberon_item_t *) expr;
1384 return selector;
1387 static oberon_expr_t *
1388 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
1390 if(desig -> result -> class == OBERON_TYPE_POINTER)
1392 desig = oberno_make_dereferencing(ctx, desig);
1395 assert(desig -> is_item);
1397 if(desig -> result -> class != OBERON_TYPE_ARRAY)
1399 oberon_error(ctx, "not array");
1402 oberon_type_t * base;
1403 base = desig -> result -> base;
1405 if(index -> result -> class != OBERON_TYPE_INTEGER)
1407 oberon_error(ctx, "index must be integer");
1410 // Статическая проверка границ массива
1411 if(desig -> result -> size != 0)
1413 if(index -> is_item)
1415 if(index -> item.mode == MODE_INTEGER)
1417 int arr_size = desig -> result -> size;
1418 int index_int = index -> item.integer;
1419 if(index_int < 0 || index_int > arr_size - 1)
1421 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
1427 oberon_expr_t * selector;
1428 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
1429 selector -> item.parent = (oberon_item_t *) desig;
1430 selector -> item.num_args = 1;
1431 selector -> item.args = index;
1433 return selector;
1436 static oberon_expr_t *
1437 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
1439 if(expr -> result -> class == OBERON_TYPE_POINTER)
1441 expr = oberno_make_dereferencing(ctx, expr);
1444 assert(expr -> is_item);
1446 if(expr -> result -> class != OBERON_TYPE_RECORD)
1448 oberon_error(ctx, "not record");
1451 oberon_type_t * rec = expr -> result;
1453 oberon_object_t * field;
1454 field = oberon_find_object(rec -> scope, name, true);
1456 if(field -> export == 0)
1458 if(field -> module != ctx -> mod)
1460 oberon_error(ctx, "field not exported");
1464 int read_only = expr -> read_only;
1465 if(field -> read_only)
1467 if(field -> module != ctx -> mod)
1469 read_only = 1;
1473 oberon_expr_t * selector;
1474 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
1475 selector -> item.var = field;
1476 selector -> item.parent = (oberon_item_t *) expr;
1478 return selector;
1481 #define ISSELECTOR(x) \
1482 (((x) == LBRACK) \
1483 || ((x) == DOT) \
1484 || ((x) == UPARROW) \
1485 || ((x) == LPAREN))
1487 static oberon_object_t *
1488 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1490 char * name;
1491 oberon_object_t * x;
1493 name = oberon_assert_ident(ctx);
1494 x = oberon_find_object(ctx -> decl, name, check);
1496 if(x != NULL)
1498 if(x -> class == OBERON_CLASS_MODULE)
1500 oberon_assert_token(ctx, DOT);
1501 name = oberon_assert_ident(ctx);
1502 /* Наличие объектов в левых модулях всегда проверяется */
1503 x = oberon_find_object(x -> module -> decl, name, 1);
1505 if(x -> export == 0)
1507 oberon_error(ctx, "not exported");
1512 if(xname)
1514 *xname = name;
1517 return x;
1520 static oberon_expr_t *
1521 oberon_ident_item(oberon_context_t * ctx, char * name)
1523 bool read_only;
1524 oberon_object_t * x;
1525 oberon_expr_t * expr;
1527 x = oberon_find_object(ctx -> decl, name, true);
1529 read_only = false;
1530 if(x -> class == OBERON_CLASS_CONST || x -> class == OBERON_CLASS_PROC)
1532 read_only = true;
1535 expr = oberon_new_item(MODE_VAR, x -> type, read_only);
1536 expr -> item.var = x;
1537 return expr;
1540 static oberon_expr_t *
1541 oberon_qualident_expr(oberon_context_t * ctx)
1543 oberon_object_t * var;
1544 oberon_expr_t * expr;
1546 var = oberon_qualident(ctx, NULL, 1);
1548 int read_only = 0;
1549 if(var -> read_only)
1551 if(var -> module != ctx -> mod)
1553 read_only = 1;
1557 switch(var -> class)
1559 case OBERON_CLASS_CONST:
1560 // TODO copy value
1561 expr = (oberon_expr_t *) var -> value;
1562 break;
1563 case OBERON_CLASS_TYPE:
1564 expr = oberon_new_item(MODE_TYPE, var -> type, read_only);
1565 break;
1566 case OBERON_CLASS_VAR:
1567 case OBERON_CLASS_VAR_PARAM:
1568 case OBERON_CLASS_PARAM:
1569 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1570 break;
1571 case OBERON_CLASS_PROC:
1572 expr = oberon_new_item(MODE_VAR, var -> type, true);
1573 break;
1574 default:
1575 oberon_error(ctx, "invalid designator");
1576 break;
1579 expr -> item.var = var;
1581 return expr;
1584 static void
1585 oberon_check_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * type)
1587 /* Охрана типа применима, если */
1588 /* 1. v - параметр-переменная типа запись, или v - указатель, и если */
1589 /* 2. T - расширение статического типа v */
1591 if(expr -> is_item
1592 && expr -> item.mode == MODE_VAR
1593 && expr -> item.var -> class == OBERON_CLASS_VAR_PARAM)
1595 // accept
1597 else if(expr -> result -> class == OBERON_TYPE_POINTER
1598 || expr -> result -> class == OBERON_TYPE_RECORD)
1600 // accept
1602 else
1604 oberon_error(ctx, "guard type used only with var-param or pointers");
1607 oberon_check_record_compatibility(ctx, type, expr -> result);
1610 static oberon_expr_t *
1611 oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype)
1613 oberon_type_t * type;
1615 if(objtype -> class != OBERON_CLASS_TYPE)
1617 oberon_error(ctx, "must be type");
1619 type = objtype -> type;
1621 oberon_check_type_guard(ctx, expr, type);
1622 return oberno_make_record_cast(ctx, expr, objtype -> type);
1625 static oberon_expr_t *
1626 oberon_designator(oberon_context_t * ctx)
1628 char * name;
1629 oberon_expr_t * expr;
1630 oberon_object_t * objtype;
1632 expr = oberon_qualident_expr(ctx);
1634 while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
1636 switch(ctx -> token)
1638 case DOT:
1639 oberon_assert_token(ctx, DOT);
1640 name = oberon_assert_ident(ctx);
1641 expr = oberon_make_record_selector(ctx, expr, name);
1642 break;
1643 case LBRACK:
1644 oberon_assert_token(ctx, LBRACK);
1645 int num_indexes = 0;
1646 oberon_expr_t * indexes = NULL;
1647 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1648 oberon_assert_token(ctx, RBRACK);
1650 for(int i = 0; i < num_indexes; i++)
1652 expr = oberon_make_array_selector(ctx, expr, indexes);
1653 indexes = indexes -> next;
1655 break;
1656 case UPARROW:
1657 oberon_assert_token(ctx, UPARROW);
1658 expr = oberno_make_dereferencing(ctx, expr);
1659 break;
1660 case LPAREN:
1661 oberon_assert_token(ctx, LPAREN);
1662 objtype = oberon_qualident(ctx, NULL, true);
1663 oberon_assert_token(ctx, RPAREN);
1664 expr = oberon_make_type_guard(ctx, expr, objtype);
1665 break;
1666 default:
1667 oberon_error(ctx, "oberon_designator: wat");
1668 break;
1672 return expr;
1675 static oberon_expr_t *
1676 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1678 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1679 if(ctx -> token == LPAREN)
1681 oberon_assert_token(ctx, LPAREN);
1683 int num_args = 0;
1684 oberon_expr_t * arguments = NULL;
1686 if(ISEXPR(ctx -> token))
1688 oberon_expr_list(ctx, &num_args, &arguments, 0);
1691 assert(expr -> is_item == 1);
1692 expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
1694 oberon_assert_token(ctx, RPAREN);
1697 return expr;
1700 static void
1701 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1703 assert(expr -> is_item);
1705 int num_args = 0;
1706 oberon_expr_t * arguments = NULL;
1708 if(ctx -> token == LPAREN)
1710 oberon_assert_token(ctx, LPAREN);
1712 if(ISEXPR(ctx -> token))
1714 oberon_expr_list(ctx, &num_args, &arguments, 0);
1717 oberon_assert_token(ctx, RPAREN);
1720 /* Вызов происходит даже без скобок */
1721 oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
1724 static oberon_type_t *
1725 oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i)
1727 if(i >= -128 && i <= 127)
1729 return ctx -> byte_type;
1731 else if(i >= -32768 && i <= 32767)
1733 return ctx -> shortint_type;
1735 else if(i >= -2147483648 && i <= 2147483647)
1737 return ctx -> int_type;
1739 else
1741 return ctx -> longint_type;
1745 static oberon_expr_t *
1746 oberon_integer_item(oberon_context_t * ctx, int64_t i)
1748 oberon_expr_t * expr;
1749 oberon_type_t * result;
1750 result = oberon_get_type_of_int_value(ctx, i);
1751 expr = oberon_new_item(MODE_INTEGER, result, true);
1752 expr -> item.integer = i;
1753 return expr;
1756 static oberon_expr_t *
1757 oberon_element(oberon_context_t * ctx)
1759 oberon_expr_t * e1;
1760 oberon_expr_t * e2;
1762 e1 = oberon_expr(ctx);
1763 if(e1 -> result -> class != OBERON_TYPE_INTEGER)
1765 oberon_error(ctx, "expected integer");
1768 e2 = NULL;
1769 if(ctx -> token == DOTDOT)
1771 oberon_assert_token(ctx, DOTDOT);
1772 e2 = oberon_expr(ctx);
1773 if(e2 -> result -> class != OBERON_TYPE_INTEGER)
1775 oberon_error(ctx, "expected integer");
1779 oberon_expr_t * set;
1780 set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2);
1781 return set;
1784 static oberon_expr_t *
1785 oberon_set(oberon_context_t * ctx)
1787 oberon_expr_t * set;
1788 oberon_expr_t * elements;
1789 set = oberon_new_item(MODE_SET, ctx -> set_type, true);
1790 set -> item.integer = 0;
1792 oberon_assert_token(ctx, LBRACE);
1793 if(ISEXPR(ctx -> token))
1795 elements = oberon_element(ctx);
1796 set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements);
1797 while(ctx -> token == COMMA)
1799 oberon_assert_token(ctx, COMMA);
1800 elements = oberon_element(ctx);
1801 set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements);
1804 oberon_assert_token(ctx, RBRACE);
1806 return set;
1809 static oberon_expr_t *
1810 oberon_make_boolean(oberon_context_t * ctx, bool cond)
1812 oberon_expr_t * expr;
1813 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1814 expr -> item.integer = cond;
1815 return expr;
1818 static oberon_expr_t *
1819 oberon_factor(oberon_context_t * ctx)
1821 oberon_expr_t * expr;
1822 oberon_type_t * result;
1824 switch(ctx -> token)
1826 case IDENT:
1827 expr = oberon_designator(ctx);
1828 expr = oberon_opt_func_parens(ctx, expr);
1829 break;
1830 case INTEGER:
1831 expr = oberon_integer_item(ctx, ctx -> integer);
1832 oberon_assert_token(ctx, INTEGER);
1833 break;
1834 case CHAR:
1835 result = ctx -> char_type;
1836 expr = oberon_new_item(MODE_CHAR, result, true);
1837 expr -> item.integer = ctx -> integer;
1838 oberon_assert_token(ctx, CHAR);
1839 break;
1840 case STRING:
1841 result = ctx -> string_type;
1842 expr = oberon_new_item(MODE_STRING, result, true);
1843 expr -> item.string = ctx -> string;
1844 oberon_assert_token(ctx, STRING);
1845 break;
1846 case REAL:
1847 result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type);
1848 expr = oberon_new_item(MODE_REAL, result, 1);
1849 expr -> item.real = ctx -> real;
1850 oberon_assert_token(ctx, REAL);
1851 break;
1852 case LBRACE:
1853 expr = oberon_set(ctx);
1854 break;
1855 case LPAREN:
1856 oberon_assert_token(ctx, LPAREN);
1857 expr = oberon_expr(ctx);
1858 oberon_assert_token(ctx, RPAREN);
1859 break;
1860 case NOT:
1861 oberon_assert_token(ctx, NOT);
1862 expr = oberon_factor(ctx);
1863 expr = oberon_make_unary_op(ctx, NOT, expr);
1864 break;
1865 case NIL:
1866 oberon_assert_token(ctx, NIL);
1867 expr = oberon_new_item(MODE_NIL, ctx -> nil_type, true);
1868 break;
1869 default:
1870 oberon_error(ctx, "invalid expression");
1873 return expr;
1876 static void
1877 oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e)
1879 oberon_expr_t * expr = *e;
1880 if(expr -> result -> class == OBERON_TYPE_INTEGER)
1882 if(expr -> result -> size <= ctx -> real_type -> size)
1884 *e = oberon_cast_expr(ctx, expr, ctx -> real_type);
1886 else
1888 *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type);
1891 else if(expr -> result -> class != OBERON_TYPE_REAL)
1893 oberon_error(ctx, "required numeric type");
1897 static bool
1898 oberon_is_numeric_type(oberon_type_t * t)
1900 return (t -> class == OBERON_TYPE_INTEGER) || (t -> class == OBERON_TYPE_REAL);
1903 static bool
1904 oberon_is_char_type(oberon_type_t * t)
1906 return (t -> class == OBERON_TYPE_CHAR);
1909 static bool
1910 oberon_is_string_type(oberon_type_t * t)
1912 return (t -> class == OBERON_TYPE_STRING)
1913 || (t -> class == OBERON_TYPE_ARRAY && t -> base -> class == OBERON_TYPE_CHAR);
1916 static bool
1917 oberon_is_boolean_type(oberon_type_t * t)
1919 return (t -> class == OBERON_TYPE_BOOLEAN);
1922 static bool
1923 oberon_is_set_type(oberon_type_t * t)
1925 return (t -> class == OBERON_TYPE_SET);
1928 static bool
1929 oberon_is_pointer_type(oberon_type_t * t)
1931 return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL);
1934 static bool
1935 oberon_is_procedure_type(oberon_type_t * t)
1937 return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL);
1940 static oberon_expr_t *
1941 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1943 oberon_expr_t * expr;
1944 oberon_type_t * result;
1946 bool error = false;
1947 if(token == IN)
1949 if(a -> result -> class != OBERON_TYPE_INTEGER)
1951 oberon_error(ctx, "must be integer");
1954 if(b -> result -> class != OBERON_TYPE_SET)
1956 oberon_error(ctx, "must be set");
1959 result = ctx -> bool_type;
1960 expr = oberon_new_operator(OP_IN, result, a, b);
1962 else if(token == IS)
1964 if(b -> is_item == false || b -> item.mode != MODE_TYPE)
1966 oberon_error(ctx, "requires type");
1969 result = ctx -> bool_type;
1970 oberon_check_type_guard(ctx, a, b -> result);
1971 expr = oberon_new_operator(OP_IS, result, a, b);
1973 else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND)
1975 if(token >= LESS && token <= GEQ)
1977 if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result))
1979 // accept
1981 else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result))
1983 // accept
1985 else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result))
1987 // accept
1989 else
1991 oberon_error(ctx, "invalid comparation");
1994 else if(token == EQUAL || token == NEQ)
1996 if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result))
1998 // accept
2000 else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result))
2002 // accept
2004 else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result))
2006 // accept
2008 else if(oberon_is_boolean_type(a -> result) && oberon_is_boolean_type(b -> result))
2010 // accept
2012 else if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result))
2014 // accept
2016 else if(oberon_is_pointer_type(a -> result) && oberon_is_pointer_type(b -> result))
2018 // accept
2020 else if(oberon_is_procedure_type(a -> result) && oberon_is_procedure_type(b -> result))
2022 // accept
2024 else
2026 oberon_error(ctx, "invalid comparation");
2029 else if(token == AND || token == OR)
2031 if(!oberon_is_boolean_type(a -> result) || !oberon_is_boolean_type(b -> result))
2033 oberon_error(ctx, "invalid comparation");
2036 else
2038 oberon_error(ctx, "wat");
2041 oberon_autocast_binary_op(ctx, &a, &b);
2042 result = ctx -> bool_type;
2044 if(token == EQUAL)
2046 expr = oberon_new_operator(OP_EQ, result, a, b);
2048 else if(token == NEQ)
2050 expr = oberon_new_operator(OP_NEQ, result, a, b);
2052 else if(token == LESS)
2054 expr = oberon_new_operator(OP_LSS, result, a, b);
2056 else if(token == LEQ)
2058 expr = oberon_new_operator(OP_LEQ, result, a, b);
2060 else if(token == GREAT)
2062 expr = oberon_new_operator(OP_GRT, result, a, b);
2064 else if(token == GEQ)
2066 expr = oberon_new_operator(OP_GEQ, result, a, b);
2068 else if(token == OR)
2070 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
2072 else if(token == AND)
2074 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
2076 else
2078 oberon_error(ctx, "oberon_make_bin_op: bool wat");
2081 else if(token == SLASH)
2083 if(a -> result -> class == OBERON_TYPE_SET
2084 || b -> result -> class == OBERON_TYPE_SET)
2086 oberon_autocast_binary_op(ctx, &a, &b);
2087 result = a -> result;
2088 expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b);
2090 else
2092 oberon_autocast_to_real(ctx, &a);
2093 oberon_autocast_to_real(ctx, &b);
2094 oberon_autocast_binary_op(ctx, &a, &b);
2095 result = a -> result;
2096 expr = oberon_new_operator(OP_DIV, result, a, b);
2099 else if(token == DIV)
2101 if(a -> result -> class != OBERON_TYPE_INTEGER
2102 || b -> result -> class != OBERON_TYPE_INTEGER)
2104 oberon_error(ctx, "operator DIV requires integer type");
2107 oberon_autocast_binary_op(ctx, &a, &b);
2108 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
2110 else
2112 oberon_autocast_binary_op(ctx, &a, &b);
2113 result = a -> result;
2114 if(result -> class == OBERON_TYPE_SET)
2116 switch(token)
2118 case PLUS:
2119 expr = oberon_new_operator(OP_UNION, result, a, b);
2120 break;
2121 case MINUS:
2122 expr = oberon_new_operator(OP_DIFFERENCE, result, a, b);
2123 break;
2124 case STAR:
2125 expr = oberon_new_operator(OP_INTERSECTION, result, a, b);
2126 break;
2127 default:
2128 error = true;
2129 break;
2132 else if(result -> class == OBERON_TYPE_INTEGER
2133 || result -> class == OBERON_TYPE_REAL)
2135 switch(token)
2137 case PLUS:
2138 expr = oberon_new_operator(OP_ADD, result, a, b);
2139 break;
2140 case MINUS:
2141 expr = oberon_new_operator(OP_SUB, result, a, b);
2142 break;
2143 case STAR:
2144 expr = oberon_new_operator(OP_MUL, result, a, b);
2145 break;
2146 case MOD:
2147 expr = oberon_new_operator(OP_MOD, result, a, b);
2148 break;
2149 default:
2150 error = true;
2151 break;
2154 else
2156 error = true;
2160 if(error)
2162 oberon_error(ctx, "invalid operation");
2165 return expr;
2168 #define ISMULOP(x) \
2169 ((x) >= STAR && (x) <= AND)
2171 static oberon_expr_t *
2172 oberon_term_expr(oberon_context_t * ctx)
2174 oberon_expr_t * expr;
2176 expr = oberon_factor(ctx);
2177 while(ISMULOP(ctx -> token))
2179 int token = ctx -> token;
2180 oberon_read_token(ctx);
2182 oberon_expr_t * inter = oberon_factor(ctx);
2183 expr = oberon_make_bin_op(ctx, token, expr, inter);
2186 return expr;
2189 #define ISADDOP(x) \
2190 ((x) >= PLUS && (x) <= OR)
2192 static oberon_expr_t *
2193 oberon_simple_expr(oberon_context_t * ctx)
2195 oberon_expr_t * expr;
2197 int minus = 0;
2198 if(ctx -> token == PLUS)
2200 minus = 0;
2201 oberon_assert_token(ctx, PLUS);
2203 else if(ctx -> token == MINUS)
2205 minus = 1;
2206 oberon_assert_token(ctx, MINUS);
2209 expr = oberon_term_expr(ctx);
2211 if(minus)
2213 expr = oberon_make_unary_op(ctx, MINUS, expr);
2216 while(ISADDOP(ctx -> token))
2218 int token = ctx -> token;
2219 oberon_read_token(ctx);
2221 oberon_expr_t * inter = oberon_term_expr(ctx);
2222 expr = oberon_make_bin_op(ctx, token, expr, inter);
2225 return expr;
2228 #define ISRELATION(x) \
2229 ((x) >= EQUAL && (x) <= IS)
2231 static oberon_expr_t *
2232 oberon_expr(oberon_context_t * ctx)
2234 oberon_expr_t * expr;
2236 expr = oberon_simple_expr(ctx);
2237 while(ISRELATION(ctx -> token))
2239 int token = ctx -> token;
2240 oberon_read_token(ctx);
2242 oberon_expr_t * inter = oberon_simple_expr(ctx);
2243 expr = oberon_make_bin_op(ctx, token, expr, inter);
2246 return expr;
2249 static void
2250 oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr)
2252 if(expr -> is_item == 0)
2254 oberon_error(ctx, "const expression are required");
2257 switch(expr -> item.mode)
2259 case MODE_INTEGER:
2260 case MODE_BOOLEAN:
2261 case MODE_NIL:
2262 case MODE_REAL:
2263 case MODE_CHAR:
2264 case MODE_STRING:
2265 case MODE_TYPE:
2266 /* accept */
2267 break;
2268 default:
2269 oberon_error(ctx, "const expression are required");
2270 break;
2274 static oberon_item_t *
2275 oberon_const_expr(oberon_context_t * ctx)
2277 oberon_expr_t * expr;
2278 expr = oberon_expr(ctx);
2279 oberon_check_const(ctx, expr);
2280 return (oberon_item_t *) expr;
2283 // =======================================================================
2284 // PARSER
2285 // =======================================================================
2287 static void oberon_decl_seq(oberon_context_t * ctx);
2288 static void oberon_statement_seq(oberon_context_t * ctx);
2289 static void oberon_initialize_decl(oberon_context_t * ctx);
2291 static void
2292 oberon_expect_token(oberon_context_t * ctx, int token)
2294 if(ctx -> token != token)
2296 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
2300 static void
2301 oberon_assert_token(oberon_context_t * ctx, int token)
2303 oberon_expect_token(ctx, token);
2304 oberon_read_token(ctx);
2307 static char *
2308 oberon_assert_ident(oberon_context_t * ctx)
2310 oberon_expect_token(ctx, IDENT);
2311 char * ident = ctx -> string;
2312 oberon_read_token(ctx);
2313 return ident;
2316 static void
2317 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
2319 switch(ctx -> token)
2321 case STAR:
2322 oberon_assert_token(ctx, STAR);
2323 *export = 1;
2324 *read_only = 0;
2325 break;
2326 case MINUS:
2327 oberon_assert_token(ctx, MINUS);
2328 *export = 1;
2329 *read_only = 1;
2330 break;
2331 default:
2332 *export = 0;
2333 *read_only = 0;
2334 break;
2338 static oberon_object_t *
2339 oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
2341 char * name;
2342 int export;
2343 int read_only;
2344 oberon_object_t * x;
2346 name = oberon_assert_ident(ctx);
2347 oberon_def(ctx, &export, &read_only);
2349 x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
2350 return x;
2353 static void
2354 oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
2356 *num = 1;
2357 *list = oberon_ident_def(ctx, class, check_upscope);
2358 while(ctx -> token == COMMA)
2360 oberon_assert_token(ctx, COMMA);
2361 oberon_ident_def(ctx, class, check_upscope);
2362 *num += 1;
2366 static void
2367 oberon_var_decl(oberon_context_t * ctx)
2369 int num;
2370 oberon_object_t * list;
2371 oberon_type_t * type;
2372 type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2374 oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
2375 oberon_assert_token(ctx, COLON);
2376 oberon_type(ctx, &type);
2378 oberon_object_t * var = list;
2379 for(int i = 0; i < num; i++)
2381 var -> type = type;
2382 var = var -> next;
2386 static oberon_object_t *
2387 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
2389 int class = OBERON_CLASS_PARAM;
2390 if(ctx -> token == VAR)
2392 oberon_read_token(ctx);
2393 class = OBERON_CLASS_VAR_PARAM;
2396 int num;
2397 oberon_object_t * list;
2398 oberon_ident_list(ctx, class, false, &num, &list);
2400 oberon_assert_token(ctx, COLON);
2402 oberon_type_t * type;
2403 type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2404 oberon_type(ctx, &type);
2406 oberon_object_t * param = list;
2407 for(int i = 0; i < num; i++)
2409 param -> type = type;
2410 param = param -> next;
2413 *num_decl += num;
2414 return list;
2417 #define ISFPSECTION \
2418 ((ctx -> token == VAR) || (ctx -> token == IDENT))
2420 static void
2421 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
2423 oberon_assert_token(ctx, LPAREN);
2425 if(ISFPSECTION)
2427 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
2428 while(ctx -> token == SEMICOLON)
2430 oberon_assert_token(ctx, SEMICOLON);
2431 oberon_fp_section(ctx, &signature -> num_decl);
2435 oberon_assert_token(ctx, RPAREN);
2437 if(ctx -> token == COLON)
2439 oberon_assert_token(ctx, COLON);
2441 oberon_object_t * typeobj;
2442 typeobj = oberon_qualident(ctx, NULL, 1);
2443 if(typeobj -> class != OBERON_CLASS_TYPE)
2445 oberon_error(ctx, "function result is not type");
2447 if(typeobj -> type -> class == OBERON_TYPE_RECORD
2448 || typeobj -> type -> class == OBERON_TYPE_ARRAY)
2450 oberon_error(ctx, "records or arrays could not be result of function");
2452 signature -> base = typeobj -> type;
2456 static void
2457 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
2459 oberon_type_t * signature;
2460 signature = *type;
2461 signature -> class = OBERON_TYPE_PROCEDURE;
2462 signature -> num_decl = 0;
2463 signature -> base = ctx -> notype_type;
2464 signature -> decl = NULL;
2466 if(ctx -> token == LPAREN)
2468 oberon_formal_pars(ctx, signature);
2472 static void
2473 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
2475 if(a -> num_decl != b -> num_decl)
2477 oberon_error(ctx, "number parameters not matched");
2480 int num_param = a -> num_decl;
2481 oberon_object_t * param_a = a -> decl;
2482 oberon_object_t * param_b = b -> decl;
2483 for(int i = 0; i < num_param; i++)
2485 if(strcmp(param_a -> name, param_b -> name) != 0)
2487 oberon_error(ctx, "param %i name not matched", i + 1);
2490 if(param_a -> type != param_b -> type)
2492 oberon_error(ctx, "param %i type not matched", i + 1);
2495 param_a = param_a -> next;
2496 param_b = param_b -> next;
2500 static void
2501 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
2503 oberon_object_t * proc = ctx -> decl -> parent;
2504 oberon_type_t * result_type = proc -> type -> base;
2506 if(result_type -> class == OBERON_TYPE_NOTYPE)
2508 if(expr != NULL)
2510 oberon_error(ctx, "procedure has no result type");
2513 else
2515 if(expr == NULL)
2517 oberon_error(ctx, "procedure requires expression on result");
2520 expr = oberon_autocast_to(ctx, expr, result_type);
2523 proc -> has_return = 1;
2525 oberon_generate_return(ctx, expr);
2528 static void
2529 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
2531 oberon_assert_token(ctx, SEMICOLON);
2533 ctx -> decl = proc -> scope;
2535 oberon_decl_seq(ctx);
2537 oberon_generate_begin_proc(ctx, proc);
2539 if(ctx -> token == BEGIN)
2541 oberon_assert_token(ctx, BEGIN);
2542 oberon_statement_seq(ctx);
2545 oberon_assert_token(ctx, END);
2546 char * name = oberon_assert_ident(ctx);
2547 if(strcmp(name, proc -> name) != 0)
2549 oberon_error(ctx, "procedure name not matched");
2552 if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE
2553 && proc -> has_return == 0)
2555 oberon_make_return(ctx, NULL);
2558 if(proc -> has_return == 0)
2560 oberon_error(ctx, "procedure requires return");
2563 oberon_generate_end_proc(ctx);
2564 oberon_close_scope(ctx -> decl);
2567 static void
2568 oberon_proc_decl(oberon_context_t * ctx)
2570 oberon_assert_token(ctx, PROCEDURE);
2572 int forward = 0;
2573 if(ctx -> token == UPARROW)
2575 oberon_assert_token(ctx, UPARROW);
2576 forward = 1;
2579 char * name;
2580 int export;
2581 int read_only;
2582 name = oberon_assert_ident(ctx);
2583 oberon_def(ctx, &export, &read_only);
2585 oberon_scope_t * proc_scope;
2586 proc_scope = oberon_open_scope(ctx);
2587 ctx -> decl -> local = 1;
2589 oberon_type_t * signature;
2590 signature = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2591 oberon_opt_formal_pars(ctx, &signature);
2593 //oberon_initialize_decl(ctx);
2594 oberon_generator_init_type(ctx, signature);
2595 oberon_close_scope(ctx -> decl);
2597 oberon_object_t * proc;
2598 proc = oberon_find_object(ctx -> decl, name, 0);
2599 if(proc == NULL)
2601 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
2602 proc -> type = signature;
2603 proc -> scope = proc_scope;
2604 oberon_generator_init_proc(ctx, proc);
2606 else
2608 if(proc -> class != OBERON_CLASS_PROC)
2610 oberon_error(ctx, "mult definition");
2613 if(forward == 0)
2615 if(proc -> linked)
2617 oberon_error(ctx, "mult procedure definition");
2621 if(proc -> export != export || proc -> read_only != read_only)
2623 oberon_error(ctx, "export type not matched");
2626 oberon_compare_signatures(ctx, proc -> type, signature);
2629 proc_scope -> parent = proc;
2630 oberon_object_t * param = proc_scope -> list -> next;
2631 while(param)
2633 param -> parent = proc;
2634 param = param -> next;
2637 if(forward == 0)
2639 proc -> linked = 1;
2640 oberon_proc_decl_body(ctx, proc);
2644 static void
2645 oberon_const_decl(oberon_context_t * ctx)
2647 oberon_item_t * value;
2648 oberon_object_t * constant;
2650 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
2651 oberon_assert_token(ctx, EQUAL);
2652 value = oberon_const_expr(ctx);
2653 constant -> value = value;
2656 static void
2657 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
2659 if(size -> is_item == 0)
2661 oberon_error(ctx, "requires constant");
2664 if(size -> item.mode != MODE_INTEGER)
2666 oberon_error(ctx, "requires integer constant");
2669 oberon_type_t * arr;
2670 arr = *type;
2671 arr -> class = OBERON_TYPE_ARRAY;
2672 arr -> size = size -> item.integer;
2673 arr -> base = base;
2676 static void
2677 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2679 char * name;
2680 oberon_object_t * to;
2682 to = oberon_qualident(ctx, &name, 0);
2684 //name = oberon_assert_ident(ctx);
2685 //to = oberon_find_object(ctx -> decl, name, 0);
2687 if(to != NULL)
2689 if(to -> class != OBERON_CLASS_TYPE)
2691 oberon_error(ctx, "not a type");
2694 else
2696 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2697 to -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2700 *type = to -> type;
2703 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2705 /*
2706 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2707 */
2709 static void
2710 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2712 if(sizes == NULL)
2714 *type = base;
2715 return;
2718 oberon_type_t * dim;
2719 dim = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2721 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2723 oberon_make_array_type(ctx, sizes, dim, type);
2726 static void
2727 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2729 type -> class = OBERON_TYPE_ARRAY;
2730 type -> size = 0;
2731 type -> base = base;
2734 static void
2735 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2737 if(ctx -> token == IDENT)
2739 int num;
2740 oberon_object_t * list;
2741 oberon_type_t * type;
2742 type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2744 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2745 oberon_assert_token(ctx, COLON);
2747 oberon_scope_t * current = ctx -> decl;
2748 ctx -> decl = modscope;
2749 oberon_type(ctx, &type);
2750 ctx -> decl = current;
2752 oberon_object_t * field = list;
2753 for(int i = 0; i < num; i++)
2755 field -> type = type;
2756 field = field -> next;
2759 rec -> num_decl += num;
2763 static void
2764 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2766 oberon_scope_t * modscope = ctx -> mod -> decl;
2767 oberon_scope_t * oldscope = ctx -> decl;
2768 ctx -> decl = modscope;
2770 if(ctx -> token == LPAREN)
2772 oberon_assert_token(ctx, LPAREN);
2774 oberon_object_t * typeobj;
2775 typeobj = oberon_qualident(ctx, NULL, true);
2777 if(typeobj -> class != OBERON_CLASS_TYPE)
2779 oberon_error(ctx, "base must be type");
2782 oberon_type_t * base = typeobj -> type;
2783 if(base -> class == OBERON_TYPE_POINTER)
2785 base = base -> base;
2788 if(base -> class != OBERON_TYPE_RECORD)
2790 oberon_error(ctx, "base must be record type");
2793 rec -> base = base;
2794 ctx -> decl = base -> scope;
2796 oberon_assert_token(ctx, RPAREN);
2798 else
2800 ctx -> decl = NULL;
2803 oberon_scope_t * this_scope;
2804 this_scope = oberon_open_scope(ctx);
2805 this_scope -> local = true;
2806 this_scope -> parent = NULL;
2807 this_scope -> parent_type = rec;
2809 oberon_field_list(ctx, rec, modscope);
2810 while(ctx -> token == SEMICOLON)
2812 oberon_assert_token(ctx, SEMICOLON);
2813 oberon_field_list(ctx, rec, modscope);
2816 rec -> scope = this_scope;
2817 rec -> decl = this_scope -> list -> next;
2818 ctx -> decl = oldscope;
2821 static void
2822 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2824 if(ctx -> token == IDENT)
2826 oberon_qualident_type(ctx, type);
2828 else if(ctx -> token == ARRAY)
2830 oberon_assert_token(ctx, ARRAY);
2832 int num_sizes = 0;
2833 oberon_expr_t * sizes;
2835 if(ISEXPR(ctx -> token))
2837 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2840 oberon_assert_token(ctx, OF);
2842 oberon_type_t * base;
2843 base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2844 oberon_type(ctx, &base);
2846 if(num_sizes == 0)
2848 oberon_make_open_array(ctx, base, *type);
2850 else
2852 oberon_make_multiarray(ctx, sizes, base, type);
2855 else if(ctx -> token == RECORD)
2857 oberon_type_t * rec;
2858 rec = *type;
2859 rec -> class = OBERON_TYPE_RECORD;
2860 rec -> module = ctx -> mod;
2862 oberon_assert_token(ctx, RECORD);
2863 oberon_type_record_body(ctx, rec);
2864 oberon_assert_token(ctx, END);
2866 *type = rec;
2868 else if(ctx -> token == POINTER)
2870 oberon_assert_token(ctx, POINTER);
2871 oberon_assert_token(ctx, TO);
2873 oberon_type_t * base;
2874 base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2875 oberon_type(ctx, &base);
2877 oberon_type_t * ptr;
2878 ptr = *type;
2879 ptr -> class = OBERON_TYPE_POINTER;
2880 ptr -> base = base;
2882 else if(ctx -> token == PROCEDURE)
2884 oberon_open_scope(ctx);
2885 oberon_assert_token(ctx, PROCEDURE);
2886 oberon_opt_formal_pars(ctx, type);
2887 oberon_close_scope(ctx -> decl);
2889 else
2891 oberon_error(ctx, "invalid type declaration");
2895 static void
2896 oberon_type_decl(oberon_context_t * ctx)
2898 char * name;
2899 oberon_object_t * newtype;
2900 oberon_type_t * type;
2901 int export;
2902 int read_only;
2904 name = oberon_assert_ident(ctx);
2905 oberon_def(ctx, &export, &read_only);
2907 newtype = oberon_find_object(ctx -> decl, name, 0);
2908 if(newtype == NULL)
2910 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2911 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2912 assert(newtype -> type);
2914 else
2916 if(newtype -> class != OBERON_CLASS_TYPE)
2918 oberon_error(ctx, "mult definition");
2921 if(newtype -> linked)
2923 oberon_error(ctx, "mult definition - already linked");
2926 newtype -> export = export;
2927 newtype -> read_only = read_only;
2930 oberon_assert_token(ctx, EQUAL);
2932 type = newtype -> type;
2933 oberon_type(ctx, &type);
2935 if(type -> class == OBERON_TYPE_NOTYPE)
2937 oberon_error(ctx, "recursive alias declaration");
2940 newtype -> type = type;
2941 newtype -> linked = 1;
2944 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2945 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2947 static void
2948 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2950 if(type -> class != OBERON_TYPE_POINTER
2951 && type -> class != OBERON_TYPE_ARRAY)
2953 return;
2956 if(type -> recursive)
2958 oberon_error(ctx, "recursive pointer declaration");
2961 if(type -> class == OBERON_TYPE_POINTER
2962 && type -> base -> class == OBERON_TYPE_POINTER)
2964 oberon_error(ctx, "attempt to make pointer to pointer");
2967 type -> recursive = 1;
2969 oberon_prevent_recursive_pointer(ctx, type -> base);
2971 type -> recursive = 0;
2974 static void
2975 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2977 if(type -> class != OBERON_TYPE_RECORD)
2979 return;
2982 if(type -> recursive)
2984 oberon_error(ctx, "recursive record declaration");
2987 type -> recursive = 1;
2989 if(type -> base)
2991 oberon_prevent_recursive_record(ctx, type -> base);
2994 int num_fields = type -> num_decl;
2995 oberon_object_t * field = type -> decl;
2996 for(int i = 0; i < num_fields; i++)
2998 oberon_prevent_recursive_object(ctx, field);
2999 field = field -> next;
3002 type -> recursive = 0;
3004 static void
3005 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
3007 if(type -> class != OBERON_TYPE_PROCEDURE)
3009 return;
3012 if(type -> recursive)
3014 oberon_error(ctx, "recursive procedure declaration");
3017 type -> recursive = 1;
3019 int num_fields = type -> num_decl;
3020 oberon_object_t * field = type -> decl;
3021 for(int i = 0; i < num_fields; i++)
3023 oberon_prevent_recursive_object(ctx, field);
3024 field = field -> next;
3027 type -> recursive = 0;
3030 static void
3031 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
3033 if(type -> class != OBERON_TYPE_ARRAY)
3035 return;
3038 if(type -> recursive)
3040 oberon_error(ctx, "recursive array declaration");
3043 type -> recursive = 1;
3045 oberon_prevent_recursive_type(ctx, type -> base);
3047 type -> recursive = 0;
3050 static void
3051 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
3053 if(type -> class == OBERON_TYPE_POINTER)
3055 oberon_prevent_recursive_pointer(ctx, type);
3057 else if(type -> class == OBERON_TYPE_RECORD)
3059 oberon_prevent_recursive_record(ctx, type);
3061 else if(type -> class == OBERON_TYPE_ARRAY)
3063 oberon_prevent_recursive_array(ctx, type);
3065 else if(type -> class == OBERON_TYPE_PROCEDURE)
3067 oberon_prevent_recursive_procedure(ctx, type);
3071 static void
3072 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
3074 switch(x -> class)
3076 case OBERON_CLASS_VAR:
3077 case OBERON_CLASS_TYPE:
3078 case OBERON_CLASS_PARAM:
3079 case OBERON_CLASS_VAR_PARAM:
3080 case OBERON_CLASS_FIELD:
3081 oberon_prevent_recursive_type(ctx, x -> type);
3082 break;
3083 case OBERON_CLASS_CONST:
3084 case OBERON_CLASS_PROC:
3085 case OBERON_CLASS_MODULE:
3086 break;
3087 default:
3088 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
3089 break;
3093 static void
3094 oberon_prevent_recursive_decl(oberon_context_t * ctx)
3096 oberon_object_t * x = ctx -> decl -> list -> next;
3098 while(x)
3100 oberon_prevent_recursive_object(ctx, x);
3101 x = x -> next;
3105 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
3106 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
3108 static void
3109 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
3111 if(type -> class != OBERON_TYPE_RECORD)
3113 return;
3116 int num_fields = type -> num_decl;
3117 oberon_object_t * field = type -> decl;
3118 for(int i = 0; i < num_fields; i++)
3120 if(field -> type -> class == OBERON_TYPE_POINTER)
3122 oberon_initialize_type(ctx, field -> type);
3125 oberon_initialize_object(ctx, field);
3126 field = field -> next;
3129 oberon_generator_init_record(ctx, type);
3132 static void
3133 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
3135 if(type -> class == OBERON_TYPE_NOTYPE)
3137 oberon_error(ctx, "undeclarated type");
3140 if(type -> initialized)
3142 return;
3145 type -> initialized = 1;
3147 if(type -> class == OBERON_TYPE_POINTER)
3149 oberon_initialize_type(ctx, type -> base);
3150 oberon_generator_init_type(ctx, type);
3152 else if(type -> class == OBERON_TYPE_ARRAY)
3154 if(type -> size != 0)
3156 if(type -> base -> class == OBERON_TYPE_ARRAY)
3158 if(type -> base -> size == 0)
3160 oberon_error(ctx, "open array not allowed as array element");
3165 oberon_initialize_type(ctx, type -> base);
3166 oberon_generator_init_type(ctx, type);
3168 else if(type -> class == OBERON_TYPE_RECORD)
3170 oberon_generator_init_type(ctx, type);
3171 oberon_initialize_record_fields(ctx, type);
3173 else if(type -> class == OBERON_TYPE_PROCEDURE)
3175 int num_fields = type -> num_decl;
3176 oberon_object_t * field = type -> decl;
3177 for(int i = 0; i < num_fields; i++)
3179 oberon_initialize_object(ctx, field);
3180 field = field -> next;
3181 }
3183 oberon_generator_init_type(ctx, type);
3185 else
3187 oberon_generator_init_type(ctx, type);
3191 static void
3192 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
3194 if(x -> initialized)
3196 return;
3199 x -> initialized = 1;
3201 switch(x -> class)
3203 case OBERON_CLASS_TYPE:
3204 oberon_initialize_type(ctx, x -> type);
3205 break;
3206 case OBERON_CLASS_VAR:
3207 case OBERON_CLASS_FIELD:
3208 if(x -> type -> class == OBERON_TYPE_ARRAY)
3210 if(x -> type -> size == 0)
3212 oberon_error(ctx, "open array not allowed as variable or field");
3215 oberon_initialize_type(ctx, x -> type);
3216 oberon_generator_init_var(ctx, x);
3217 break;
3218 case OBERON_CLASS_PARAM:
3219 case OBERON_CLASS_VAR_PARAM:
3220 oberon_initialize_type(ctx, x -> type);
3221 oberon_generator_init_var(ctx, x);
3222 break;
3223 case OBERON_CLASS_CONST:
3224 case OBERON_CLASS_PROC:
3225 case OBERON_CLASS_MODULE:
3226 break;
3227 default:
3228 oberon_error(ctx, "oberon_initialize_object: wat");
3229 break;
3233 static void
3234 oberon_initialize_decl(oberon_context_t * ctx)
3236 oberon_object_t * x = ctx -> decl -> list;
3238 while(x -> next)
3240 oberon_initialize_object(ctx, x -> next);
3241 x = x -> next;
3242 }
3245 static void
3246 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
3248 oberon_object_t * x = ctx -> decl -> list;
3250 while(x -> next)
3252 if(x -> next -> class == OBERON_CLASS_PROC)
3254 if(x -> next -> linked == 0)
3256 oberon_error(ctx, "unresolved forward declaration");
3259 x = x -> next;
3260 }
3263 static void
3264 oberon_decl_seq(oberon_context_t * ctx)
3266 if(ctx -> token == CONST)
3268 oberon_assert_token(ctx, CONST);
3269 while(ctx -> token == IDENT)
3271 oberon_const_decl(ctx);
3272 oberon_assert_token(ctx, SEMICOLON);
3276 if(ctx -> token == TYPE)
3278 oberon_assert_token(ctx, TYPE);
3279 while(ctx -> token == IDENT)
3281 oberon_type_decl(ctx);
3282 oberon_assert_token(ctx, SEMICOLON);
3286 if(ctx -> token == VAR)
3288 oberon_assert_token(ctx, VAR);
3289 while(ctx -> token == IDENT)
3291 oberon_var_decl(ctx);
3292 oberon_assert_token(ctx, SEMICOLON);
3296 oberon_prevent_recursive_decl(ctx);
3297 oberon_initialize_decl(ctx);
3299 while(ctx -> token == PROCEDURE)
3301 oberon_proc_decl(ctx);
3302 oberon_assert_token(ctx, SEMICOLON);
3305 oberon_prevent_undeclarated_procedures(ctx);
3308 static oberon_expr_t *
3309 oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type)
3311 oberon_object_t * x;
3312 oberon_expr_t * expr;
3314 x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false);
3315 x -> local = true;
3316 x -> type = type;
3317 oberon_generator_init_temp_var(ctx, x);
3319 expr = oberon_new_item(MODE_VAR, type, false);
3320 expr -> item.var = x;
3321 return expr;
3324 static void
3325 oberon_statement_seq(oberon_context_t * ctx);
3327 static void
3328 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
3330 if(src -> is_item
3331 && src -> item.mode == MODE_STRING
3332 && src -> result -> class == OBERON_TYPE_STRING
3333 && dst -> result -> class == OBERON_TYPE_ARRAY
3334 && dst -> result -> base -> class == OBERON_TYPE_CHAR
3335 && dst -> result -> size > 0)
3338 if(strlen(src -> item.string) < dst -> result -> size)
3340 src -> next = dst;
3341 oberon_make_copy_call(ctx, 2, src);
3343 else
3345 oberon_error(ctx, "string too long for destination");
3348 else
3350 oberon_check_dst(ctx, dst);
3351 src = oberon_autocast_to(ctx, src, dst -> result);
3352 oberon_generate_assign(ctx, src, dst);
3356 static oberon_expr_t *
3357 oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val)
3359 oberon_expr_t * e1;
3360 oberon_expr_t * e2;
3361 oberon_expr_t * cond;
3362 oberon_expr_t * cond2;
3364 e1 = (oberon_expr_t *) oberon_const_expr(ctx);
3365 oberon_autocast_to(ctx, e1, val -> result);
3367 e2 = NULL;
3368 if(ctx -> token == DOTDOT)
3370 oberon_assert_token(ctx, DOTDOT);
3371 e2 = (oberon_expr_t *) oberon_const_expr(ctx);
3372 oberon_autocast_to(ctx, e2, val -> result);
3375 if(e2 == NULL)
3377 /* val == e1 */
3378 cond = oberon_make_bin_op(ctx, EQUAL, val, e1);
3380 else
3382 /* val >= e1 && val <= e2 */
3383 cond = oberon_make_bin_op(ctx, GEQ, val, e1);
3384 cond2 = oberon_make_bin_op(ctx, LEQ, val, e2);
3385 cond = oberon_make_bin_op(ctx, AND, cond, cond2);
3388 return cond;
3391 static void
3392 oberon_case(oberon_context_t * ctx, oberon_expr_t * val, gen_label_t * end)
3394 oberon_expr_t * cond;
3395 oberon_expr_t * cond2;
3396 gen_label_t * this_end;
3398 if(ISEXPR(ctx -> token))
3400 this_end = oberon_generator_reserve_label(ctx);
3402 cond = oberon_case_labels(ctx, val);
3403 while(ctx -> token == COMMA)
3405 oberon_assert_token(ctx, COMMA);
3406 /* cond || cond2 */
3407 cond2 = oberon_case_labels(ctx, val);
3408 cond = oberon_make_bin_op(ctx, OR, cond, cond2);
3410 oberon_assert_token(ctx, COLON);
3412 oberon_generate_branch(ctx, cond, false, this_end);
3413 oberon_statement_seq(ctx);
3414 oberon_generate_goto(ctx, end);
3416 oberon_generate_label(ctx, this_end);
3420 static void
3421 oberon_case_statement(oberon_context_t * ctx)
3423 oberon_expr_t * val;
3424 oberon_expr_t * expr;
3425 gen_label_t * end;
3427 end = oberon_generator_reserve_label(ctx);
3429 oberon_assert_token(ctx, CASE);
3430 expr = oberon_expr(ctx);
3431 val = oberon_make_temp_var_item(ctx, expr -> result);
3432 oberon_assign(ctx, expr, val);
3433 oberon_assert_token(ctx, OF);
3434 oberon_case(ctx, val, end);
3435 while(ctx -> token == BAR)
3437 oberon_assert_token(ctx, BAR);
3438 oberon_case(ctx, val, end);
3441 if(ctx -> token == ELSE)
3443 oberon_assert_token(ctx, ELSE);
3444 oberon_statement_seq(ctx);
3447 oberon_generate_label(ctx, end);
3448 oberon_assert_token(ctx, END);
3451 static void
3452 oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end)
3454 oberon_expr_t * val;
3455 oberon_expr_t * var;
3456 oberon_expr_t * type;
3457 oberon_expr_t * cond;
3458 oberon_expr_t * cast;
3459 oberon_type_t * old_type;
3460 gen_var_t * old_var;
3461 gen_label_t * this_end;
3463 this_end = oberon_generator_reserve_label(ctx);
3465 var = oberon_qualident_expr(ctx);
3466 oberon_assert_token(ctx, COLON);
3467 type = oberon_qualident_expr(ctx);
3468 cond = oberon_make_bin_op(ctx, IS, var, type);
3470 oberon_assert_token(ctx, DO);
3471 oberon_generate_branch(ctx, cond, false, this_end);
3473 /* Сохраняем ссылку во временной переменной */
3474 val = oberon_make_temp_var_item(ctx, type -> result);
3475 cast = oberno_make_record_cast(ctx, var, type -> result);
3476 oberon_assign(ctx, cast, val);
3477 /* Подменяем тип у оригинальной переменной */
3478 old_type = var -> item.var -> type;
3479 var -> item.var -> type = type -> result;
3480 /* Подменяем ссылку на переменную */
3481 old_var = var -> item.var -> gen_var;
3482 var -> item.var -> gen_var = val -> item.var -> gen_var;
3484 oberon_statement_seq(ctx);
3485 oberon_generate_goto(ctx, end);
3486 oberon_generate_label(ctx, this_end);
3488 /* Возвращаем исходное состояние */
3489 var -> item.var -> gen_var = old_var;
3490 var -> item.var -> type = old_type;
3493 static void
3494 oberon_with_statement(oberon_context_t * ctx)
3496 gen_label_t * end;
3497 end = oberon_generator_reserve_label(ctx);
3499 oberon_assert_token(ctx, WITH);
3500 oberon_with_guard_do(ctx, end);
3501 while(ctx -> token == BAR)
3503 oberon_assert_token(ctx, BAR);
3504 oberon_with_guard_do(ctx, end);
3507 if(ctx -> token == ELSE)
3509 oberon_assert_token(ctx, ELSE);
3510 oberon_statement_seq(ctx);
3513 oberon_generate_label(ctx, end);
3514 oberon_assert_token(ctx, END);
3517 static void
3518 oberon_statement(oberon_context_t * ctx)
3520 oberon_expr_t * item1;
3521 oberon_expr_t * item2;
3523 if(ctx -> token == IDENT)
3525 item1 = oberon_designator(ctx);
3526 if(ctx -> token == ASSIGN)
3528 oberon_assert_token(ctx, ASSIGN);
3529 item2 = oberon_expr(ctx);
3530 oberon_assign(ctx, item2, item1);
3532 else
3534 oberon_opt_proc_parens(ctx, item1);
3537 else if(ctx -> token == IF)
3539 gen_label_t * end;
3540 gen_label_t * els;
3541 oberon_expr_t * cond;
3543 els = oberon_generator_reserve_label(ctx);
3544 end = oberon_generator_reserve_label(ctx);
3546 oberon_assert_token(ctx, IF);
3547 cond = oberon_expr(ctx);
3548 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3550 oberon_error(ctx, "condition must be boolean");
3552 oberon_assert_token(ctx, THEN);
3553 oberon_generate_branch(ctx, cond, false, els);
3554 oberon_statement_seq(ctx);
3555 oberon_generate_goto(ctx, end);
3556 oberon_generate_label(ctx, els);
3558 while(ctx -> token == ELSIF)
3560 els = oberon_generator_reserve_label(ctx);
3562 oberon_assert_token(ctx, ELSIF);
3563 cond = oberon_expr(ctx);
3564 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3566 oberon_error(ctx, "condition must be boolean");
3568 oberon_assert_token(ctx, THEN);
3569 oberon_generate_branch(ctx, cond, false, els);
3570 oberon_statement_seq(ctx);
3571 oberon_generate_goto(ctx, end);
3572 oberon_generate_label(ctx, els);
3575 if(ctx -> token == ELSE)
3577 oberon_assert_token(ctx, ELSE);
3578 oberon_statement_seq(ctx);
3581 oberon_generate_label(ctx, end);
3582 oberon_assert_token(ctx, END);
3584 else if(ctx -> token == WHILE)
3586 gen_label_t * begin;
3587 gen_label_t * end;
3588 oberon_expr_t * cond;
3590 begin = oberon_generator_reserve_label(ctx);
3591 end = oberon_generator_reserve_label(ctx);
3593 oberon_assert_token(ctx, WHILE);
3594 oberon_generate_label(ctx, begin);
3595 cond = oberon_expr(ctx);
3596 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3598 oberon_error(ctx, "condition must be boolean");
3600 oberon_generate_branch(ctx, cond, false, end);
3602 oberon_assert_token(ctx, DO);
3603 oberon_statement_seq(ctx);
3604 oberon_generate_goto(ctx, begin);
3606 oberon_assert_token(ctx, END);
3607 oberon_generate_label(ctx, end);
3609 else if(ctx -> token == REPEAT)
3611 gen_label_t * begin;
3612 oberon_expr_t * cond;
3614 begin = oberon_generator_reserve_label(ctx);
3615 oberon_generate_label(ctx, begin);
3616 oberon_assert_token(ctx, REPEAT);
3618 oberon_statement_seq(ctx);
3620 oberon_assert_token(ctx, UNTIL);
3622 cond = oberon_expr(ctx);
3623 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3625 oberon_error(ctx, "condition must be boolean");
3628 oberon_generate_branch(ctx, cond, true, begin);
3630 else if(ctx -> token == FOR)
3632 oberon_expr_t * from;
3633 oberon_expr_t * index;
3634 oberon_expr_t * to;
3635 oberon_expr_t * bound;
3636 oberon_expr_t * by;
3637 oberon_expr_t * cond;
3638 oberon_expr_t * count;
3639 gen_label_t * begin;
3640 gen_label_t * end;
3641 char * iname;
3642 int op;
3644 begin = oberon_generator_reserve_label(ctx);
3645 end = oberon_generator_reserve_label(ctx);
3647 oberon_assert_token(ctx, FOR);
3648 iname = oberon_assert_ident(ctx);
3649 index = oberon_ident_item(ctx, iname);
3650 oberon_assert_token(ctx, ASSIGN);
3651 from = oberon_expr(ctx);
3652 oberon_assert_token(ctx, TO);
3653 bound = oberon_make_temp_var_item(ctx, index -> result);
3654 to = oberon_expr(ctx);
3655 oberon_assign(ctx, to, bound); // сначала temp
3656 oberon_assign(ctx, from, index); // потом i
3657 if(ctx -> token == BY)
3659 oberon_assert_token(ctx, BY);
3660 by = (oberon_expr_t *) oberon_const_expr(ctx);
3662 else
3664 by = oberon_integer_item(ctx, 1);
3667 if(by -> result -> class != OBERON_TYPE_INTEGER)
3669 oberon_error(ctx, "must be integer");
3672 if(by -> item.integer > 0)
3674 op = LEQ;
3676 else if(by -> item.integer < 0)
3678 op = GEQ;
3680 else
3682 oberon_error(ctx, "zero step not allowed");
3685 oberon_assert_token(ctx, DO);
3686 oberon_generate_label(ctx, begin);
3687 cond = oberon_make_bin_op(ctx, op, index, bound);
3688 oberon_generate_branch(ctx, cond, false, end);
3689 oberon_statement_seq(ctx);
3690 count = oberon_make_bin_op(ctx, PLUS, index, by);
3691 oberon_assign(ctx, count, index);
3692 oberon_generate_goto(ctx, begin);
3693 oberon_generate_label(ctx, end);
3694 oberon_assert_token(ctx, END);
3696 else if(ctx -> token == LOOP)
3698 gen_label_t * begin;
3699 gen_label_t * end;
3701 begin = oberon_generator_reserve_label(ctx);
3702 end = oberon_generator_reserve_label(ctx);
3704 oberon_open_scope(ctx);
3705 oberon_assert_token(ctx, LOOP);
3706 oberon_generate_label(ctx, begin);
3707 ctx -> decl -> exit_label = end;
3708 oberon_statement_seq(ctx);
3709 oberon_generate_goto(ctx, begin);
3710 oberon_generate_label(ctx, end);
3711 oberon_assert_token(ctx, END);
3712 oberon_close_scope(ctx -> decl);
3714 else if(ctx -> token == EXIT)
3716 oberon_assert_token(ctx, EXIT);
3717 if(ctx -> decl -> exit_label == NULL)
3719 oberon_error(ctx, "not in LOOP-END");
3721 oberon_generate_goto(ctx, ctx -> decl -> exit_label);
3723 else if(ctx -> token == CASE)
3725 oberon_case_statement(ctx);
3727 else if(ctx -> token == WITH)
3729 oberon_with_statement(ctx);
3731 else if(ctx -> token == RETURN)
3733 oberon_assert_token(ctx, RETURN);
3734 if(ISEXPR(ctx -> token))
3736 oberon_expr_t * expr;
3737 expr = oberon_expr(ctx);
3738 oberon_make_return(ctx, expr);
3740 else
3742 oberon_make_return(ctx, NULL);
3747 static void
3748 oberon_statement_seq(oberon_context_t * ctx)
3750 oberon_statement(ctx);
3751 while(ctx -> token == SEMICOLON)
3753 oberon_assert_token(ctx, SEMICOLON);
3754 oberon_statement(ctx);
3758 static void
3759 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
3761 oberon_module_t * m = ctx -> module_list;
3762 while(m && strcmp(m -> name, name) != 0)
3764 m = m -> next;
3767 if(m == NULL)
3769 const char * code;
3770 code = ctx -> import_module(name);
3771 if(code == NULL)
3773 oberon_error(ctx, "no such module");
3776 m = oberon_compile_module(ctx, code);
3777 assert(m);
3780 if(m -> ready == 0)
3782 oberon_error(ctx, "cyclic module import");
3785 oberon_object_t * ident;
3786 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
3787 ident -> module = m;
3790 static void
3791 oberon_import_decl(oberon_context_t * ctx)
3793 char * alias;
3794 char * name;
3796 alias = name = oberon_assert_ident(ctx);
3797 if(ctx -> token == ASSIGN)
3799 oberon_assert_token(ctx, ASSIGN);
3800 name = oberon_assert_ident(ctx);
3803 oberon_import_module(ctx, alias, name);
3806 static void
3807 oberon_import_list(oberon_context_t * ctx)
3809 oberon_assert_token(ctx, IMPORT);
3811 oberon_import_decl(ctx);
3812 while(ctx -> token == COMMA)
3814 oberon_assert_token(ctx, COMMA);
3815 oberon_import_decl(ctx);
3818 oberon_assert_token(ctx, SEMICOLON);
3821 static void
3822 oberon_parse_module(oberon_context_t * ctx)
3824 char * name1;
3825 char * name2;
3826 oberon_read_token(ctx);
3828 oberon_assert_token(ctx, MODULE);
3829 name1 = oberon_assert_ident(ctx);
3830 oberon_assert_token(ctx, SEMICOLON);
3831 ctx -> mod -> name = name1;
3833 oberon_generator_init_module(ctx, ctx -> mod);
3835 if(ctx -> token == IMPORT)
3837 oberon_import_list(ctx);
3840 oberon_decl_seq(ctx);
3842 oberon_generate_begin_module(ctx);
3843 if(ctx -> token == BEGIN)
3845 oberon_assert_token(ctx, BEGIN);
3846 oberon_statement_seq(ctx);
3848 oberon_generate_end_module(ctx);
3850 oberon_assert_token(ctx, END);
3851 name2 = oberon_assert_ident(ctx);
3852 oberon_expect_token(ctx, DOT);
3854 if(strcmp(name1, name2) != 0)
3856 oberon_error(ctx, "module name not matched");
3859 oberon_generator_fini_module(ctx -> mod);
3862 // =======================================================================
3863 // LIBRARY
3864 // =======================================================================
3866 static void
3867 register_default_types(oberon_context_t * ctx)
3869 ctx -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
3870 oberon_generator_init_type(ctx, ctx -> notype_type);
3872 ctx -> nil_type = oberon_new_type_ptr(OBERON_TYPE_NIL);
3873 oberon_generator_init_type(ctx, ctx -> nil_type);
3875 ctx -> string_type = oberon_new_type_string(1);
3876 oberon_generator_init_type(ctx, ctx -> string_type);
3878 ctx -> bool_type = oberon_new_type_boolean();
3879 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
3881 ctx -> char_type = oberon_new_type_char(1);
3882 oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1);
3884 ctx -> byte_type = oberon_new_type_integer(1);
3885 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> byte_type, 1);
3887 ctx -> shortint_type = oberon_new_type_integer(2);
3888 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> shortint_type, 1);
3890 ctx -> int_type = oberon_new_type_integer(4);
3891 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> int_type, 1);
3893 ctx -> longint_type = oberon_new_type_integer(8);
3894 oberon_define_type(ctx -> world_scope, "HUGEINT", ctx -> longint_type, 1);
3896 ctx -> real_type = oberon_new_type_real(4);
3897 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
3899 ctx -> longreal_type = oberon_new_type_real(8);
3900 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
3902 ctx -> set_type = oberon_new_type_set(4);
3903 oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1);
3906 static void
3907 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
3909 oberon_object_t * proc;
3910 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
3911 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
3912 proc -> type -> sysproc = true;
3913 proc -> type -> genfunc = f;
3914 proc -> type -> genproc = p;
3917 static oberon_expr_t *
3918 oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3920 if(num_args < 1)
3922 oberon_error(ctx, "too few arguments");
3925 if(num_args > 1)
3927 oberon_error(ctx, "too mach arguments");
3930 oberon_expr_t * arg;
3931 arg = list_args;
3933 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3935 oberon_error(ctx, "MIN accept only type");
3938 oberon_expr_t * expr;
3939 int bits = arg -> result -> size * 8;
3940 switch(arg -> result -> class)
3942 case OBERON_TYPE_INTEGER:
3943 expr = oberon_integer_item(ctx, -powl(2, bits - 1));
3944 break;
3945 case OBERON_TYPE_SET:
3946 expr = oberon_integer_item(ctx, 0);
3947 break;
3948 default:
3949 oberon_error(ctx, "allowed only basic types");
3950 break;
3953 return expr;
3956 static oberon_expr_t *
3957 oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3959 if(num_args < 1)
3961 oberon_error(ctx, "too few arguments");
3964 if(num_args > 1)
3966 oberon_error(ctx, "too mach arguments");
3969 oberon_expr_t * arg;
3970 arg = list_args;
3972 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3974 oberon_error(ctx, "MAX accept only type");
3977 oberon_expr_t * expr;
3978 int bits = arg -> result -> size * 8;
3979 switch(arg -> result -> class)
3981 case OBERON_TYPE_INTEGER:
3982 expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1);
3983 break;
3984 case OBERON_TYPE_SET:
3985 expr = oberon_integer_item(ctx, bits);
3986 break;
3987 default:
3988 oberon_error(ctx, "allowed only basic types");
3989 break;
3992 return expr;
3995 static oberon_expr_t *
3996 oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3998 if(num_args < 1)
4000 oberon_error(ctx, "too few arguments");
4003 if(num_args > 1)
4005 oberon_error(ctx, "too mach arguments");
4008 oberon_expr_t * arg;
4009 arg = list_args;
4011 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
4013 oberon_error(ctx, "SIZE accept only type");
4016 int size;
4017 oberon_expr_t * expr;
4018 oberon_type_t * type = arg -> result;
4019 switch(type -> class)
4021 case OBERON_TYPE_INTEGER:
4022 case OBERON_TYPE_BOOLEAN:
4023 case OBERON_TYPE_REAL:
4024 case OBERON_TYPE_CHAR:
4025 case OBERON_TYPE_SET:
4026 size = type -> size;
4027 break;
4028 default:
4029 oberon_error(ctx, "TODO SIZE");
4030 break;
4033 expr = oberon_integer_item(ctx, size);
4034 return expr;
4037 static oberon_expr_t *
4038 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
4040 if(num_args < 1)
4042 oberon_error(ctx, "too few arguments");
4045 if(num_args > 1)
4047 oberon_error(ctx, "too mach arguments");
4050 oberon_expr_t * arg;
4051 arg = list_args;
4052 oberon_check_src(ctx, arg);
4054 oberon_type_t * result_type;
4055 result_type = arg -> result;
4057 if(result_type -> class != OBERON_TYPE_INTEGER)
4059 oberon_error(ctx, "ABS accepts only integers");
4062 oberon_expr_t * expr;
4063 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
4064 return expr;
4067 static void
4068 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
4070 if(num_args < 1)
4072 oberon_error(ctx, "too few arguments");
4075 oberon_expr_t * dst;
4076 dst = list_args;
4077 oberon_check_dst(ctx, dst);
4079 oberon_type_t * type;
4080 type = dst -> result;
4082 if(type -> class != OBERON_TYPE_POINTER)
4084 oberon_error(ctx, "not a pointer");
4087 type = type -> base;
4089 oberon_expr_t * src;
4090 src = oberon_new_item(MODE_NEW, dst -> result, 0);
4091 src -> item.num_args = 0;
4092 src -> item.args = NULL;
4094 int max_args = 1;
4095 if(type -> class == OBERON_TYPE_ARRAY)
4097 if(type -> size == 0)
4099 oberon_type_t * x = type;
4100 while(x -> class == OBERON_TYPE_ARRAY)
4102 if(x -> size == 0)
4104 max_args += 1;
4106 x = x -> base;
4110 if(num_args < max_args)
4112 oberon_error(ctx, "too few arguments");
4115 if(num_args > max_args)
4117 oberon_error(ctx, "too mach arguments");
4120 int num_sizes = max_args - 1;
4121 oberon_expr_t * size_list = list_args -> next;
4123 oberon_expr_t * arg = size_list;
4124 for(int i = 0; i < max_args - 1; i++)
4126 oberon_check_src(ctx, arg);
4127 if(arg -> result -> class != OBERON_TYPE_INTEGER)
4129 oberon_error(ctx, "size must be integer");
4131 arg = arg -> next;
4134 src -> item.num_args = num_sizes;
4135 src -> item.args = size_list;
4137 else if(type -> class != OBERON_TYPE_RECORD)
4139 oberon_error(ctx, "oberon_make_new_call: wat");
4142 if(num_args > max_args)
4144 oberon_error(ctx, "too mach arguments");
4147 oberon_assign(ctx, src, dst);
4150 static void
4151 oberon_make_copy_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
4153 if(num_args < 2)
4155 oberon_error(ctx, "too few arguments");
4158 if(num_args > 2)
4160 oberon_error(ctx, "too mach arguments");
4163 oberon_expr_t * src;
4164 src = list_args;
4165 oberon_check_src(ctx, src);
4167 oberon_expr_t * dst;
4168 dst = list_args -> next;
4169 oberon_check_dst(ctx, dst);
4171 if(!oberon_is_string_type(src -> result))
4173 oberon_error(ctx, "source must be string or array of char");
4176 if(!oberon_is_string_type(dst -> result))
4178 oberon_error(ctx, "dst must be array of char");
4181 oberon_generate_copy(ctx, src, dst);
4184 static void
4185 oberon_make_assert_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
4187 if(num_args < 1)
4189 oberon_error(ctx, "too few arguments");
4192 if(num_args > 2)
4194 oberon_error(ctx, "too mach arguments");
4197 oberon_expr_t * cond;
4198 cond = list_args;
4199 oberon_check_src(ctx, cond);
4201 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
4203 oberon_error(ctx, "expected boolean");
4206 if(num_args == 1)
4208 oberon_generate_assert(ctx, cond);
4210 else
4212 oberon_expr_t * num;
4213 num = list_args -> next;
4214 oberon_check_src(ctx, num);
4216 if(num -> result -> class != OBERON_TYPE_INTEGER)
4218 oberon_error(ctx, "expected integer");
4221 oberon_check_const(ctx, num);
4223 oberon_generate_assert_n(ctx, cond, num -> item.integer);
4227 static void
4228 oberon_make_halt_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
4230 if(num_args < 1)
4232 oberon_error(ctx, "too few arguments");
4235 if(num_args > 1)
4237 oberon_error(ctx, "too mach arguments");
4240 oberon_expr_t * num;
4241 num = list_args;
4242 oberon_check_src(ctx, num);
4244 if(num -> result -> class != OBERON_TYPE_INTEGER)
4246 oberon_error(ctx, "expected integer");
4249 oberon_check_const(ctx, num);
4251 oberon_generate_halt(ctx, num -> item.integer);
4254 static void
4255 oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr)
4257 oberon_object_t * constant;
4258 constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST, true, false, false);
4259 oberon_check_const(ctx, expr);
4260 constant -> value = (oberon_item_t *) expr;
4263 oberon_context_t *
4264 oberon_create_context(ModuleImportCallback import_module)
4266 oberon_context_t * ctx = calloc(1, sizeof *ctx);
4268 oberon_scope_t * world_scope;
4269 world_scope = oberon_open_scope(ctx);
4270 ctx -> world_scope = world_scope;
4272 ctx -> import_module = import_module;
4274 oberon_generator_init_context(ctx);
4276 register_default_types(ctx);
4278 /* Constants */
4279 oberon_new_const(ctx, "TRUE", oberon_make_boolean(ctx, true));
4280 oberon_new_const(ctx, "FALSE", oberon_make_boolean(ctx, false));
4282 /* Functions */
4283 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
4284 oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL);
4285 oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
4286 oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
4288 /* Procedures */
4289 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
4290 oberon_new_intrinsic(ctx, "COPY", NULL, oberon_make_copy_call);
4291 oberon_new_intrinsic(ctx, "ASSERT", NULL, oberon_make_assert_call);
4292 oberon_new_intrinsic(ctx, "HALT", NULL, oberon_make_halt_call);
4294 return ctx;
4297 void
4298 oberon_destroy_context(oberon_context_t * ctx)
4300 oberon_generator_destroy_context(ctx);
4301 free(ctx);
4304 oberon_module_t *
4305 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
4307 const char * code = ctx -> code;
4308 int code_index = ctx -> code_index;
4309 char c = ctx -> c;
4310 int token = ctx -> token;
4311 char * string = ctx -> string;
4312 int integer = ctx -> integer;
4313 int real = ctx -> real;
4314 bool longmode = ctx -> longmode;
4315 oberon_scope_t * decl = ctx -> decl;
4316 oberon_module_t * mod = ctx -> mod;
4318 oberon_scope_t * module_scope;
4319 module_scope = oberon_open_scope(ctx);
4321 oberon_module_t * module;
4322 module = calloc(1, sizeof *module);
4323 module -> decl = module_scope;
4324 module -> next = ctx -> module_list;
4326 ctx -> mod = module;
4327 ctx -> module_list = module;
4329 oberon_init_scaner(ctx, newcode);
4330 oberon_parse_module(ctx);
4332 module -> ready = 1;
4334 ctx -> code = code;
4335 ctx -> code_index = code_index;
4336 ctx -> c = c;
4337 ctx -> token = token;
4338 ctx -> string = string;
4339 ctx -> integer = integer;
4340 ctx -> real = real;
4341 ctx -> longmode = longmode;
4342 ctx -> decl = decl;
4343 ctx -> mod = mod;
4345 return module;