DEADSOFTWARE

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