DEADSOFTWARE

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


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