DEADSOFTWARE
GIT / REPO / FRED-BOY

Projects / dsw-obn.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
JVM: Добавлены фреймы (без передачи их локальным функциям)
[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 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
2481 proc -> type = signature;
2482 proc -> scope = proc_scope;
2483 oberon_generator_init_proc(ctx, proc);
2484 }
2485 else
2486 {
2487 if(proc -> class != OBERON_CLASS_PROC)
2488 {
2489 oberon_error(ctx, "mult definition");
2490 }
2491
2492 if(forward == 0)
2493 {
2494 if(proc -> linked)
2495 {
2496 oberon_error(ctx, "mult procedure definition");
2497 }
2498 }
2499
2500 if(proc -> export != export || proc -> read_only != read_only)
2501 {
2502 oberon_error(ctx, "export type not matched");
2503 }
2504
2505 oberon_compare_signatures(ctx, proc -> type, signature);
2506 }
2507
2508 proc_scope -> parent = proc;
2509 oberon_object_t * param = proc_scope -> list -> next;
2510 while(param)
2511 {
2512 param -> parent = proc;
2513 param = param -> next;
2514 }
2515
2516 if(forward == 0)
2517 {
2518 proc -> linked = 1;
2519 oberon_proc_decl_body(ctx, proc);
2520 }
2521 }
2522
2523 static void
2524 oberon_const_decl(oberon_context_t * ctx)
2525 {
2526 oberon_item_t * value;
2527 oberon_object_t * constant;
2528
2529 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
2530 oberon_assert_token(ctx, EQUAL);
2531 value = oberon_const_expr(ctx);
2532 constant -> value = value;
2533 }
2534
2535 static void
2536 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
2537 {
2538 if(size -> is_item == 0)
2539 {
2540 oberon_error(ctx, "requires constant");
2541 }
2542
2543 if(size -> item.mode != MODE_INTEGER)
2544 {
2545 oberon_error(ctx, "requires integer constant");
2546 }
2547
2548 oberon_type_t * arr;
2549 arr = *type;
2550 arr -> class = OBERON_TYPE_ARRAY;
2551 arr -> size = size -> item.integer;
2552 arr -> base = base;
2553 }
2554
2555 static void
2556 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2557 {
2558 char * name;
2559 oberon_object_t * to;
2560
2561 to = oberon_qualident(ctx, &name, 0);
2562
2563 //name = oberon_assert_ident(ctx);
2564 //to = oberon_find_object(ctx -> decl, name, 0);
2565
2566 if(to != NULL)
2567 {
2568 if(to -> class != OBERON_CLASS_TYPE)
2569 {
2570 oberon_error(ctx, "not a type");
2571 }
2572 }
2573 else
2574 {
2575 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2576 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2577 }
2578
2579 *type = to -> type;
2580 }
2581
2582 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2583
2584 /*
2585 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2586 */
2587
2588 static void
2589 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2590 {
2591 if(sizes == NULL)
2592 {
2593 *type = base;
2594 return;
2595 }
2596
2597 oberon_type_t * dim;
2598 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2599
2600 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2601
2602 oberon_make_array_type(ctx, sizes, dim, type);
2603 }
2604
2605 static void
2606 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2607 {
2608 type -> class = OBERON_TYPE_ARRAY;
2609 type -> size = 0;
2610 type -> base = base;
2611 }
2612
2613 static void
2614 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2615 {
2616 if(ctx -> token == IDENT)
2617 {
2618 int num;
2619 oberon_object_t * list;
2620 oberon_type_t * type;
2621 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2622
2623 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2624 oberon_assert_token(ctx, COLON);
2625
2626 oberon_scope_t * current = ctx -> decl;
2627 ctx -> decl = modscope;
2628 oberon_type(ctx, &type);
2629 ctx -> decl = current;
2630
2631 oberon_object_t * field = list;
2632 for(int i = 0; i < num; i++)
2633 {
2634 field -> type = type;
2635 field = field -> next;
2636 }
2637
2638 rec -> num_decl += num;
2639 }
2640 }
2641
2642 static void
2643 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2644 {
2645 oberon_scope_t * modscope = ctx -> mod -> decl;
2646 oberon_scope_t * oldscope = ctx -> decl;
2647 ctx -> decl = modscope;
2648
2649 if(ctx -> token == LPAREN)
2650 {
2651 oberon_assert_token(ctx, LPAREN);
2652
2653 oberon_object_t * typeobj;
2654 typeobj = oberon_qualident(ctx, NULL, true);
2655
2656 if(typeobj -> class != OBERON_CLASS_TYPE)
2657 {
2658 oberon_error(ctx, "base must be type");
2659 }
2660
2661 oberon_type_t * base = typeobj -> type;
2662 if(base -> class == OBERON_TYPE_POINTER)
2663 {
2664 base = base -> base;
2665 }
2666
2667 if(base -> class != OBERON_TYPE_RECORD)
2668 {
2669 oberon_error(ctx, "base must be record type");
2670 }
2671
2672 rec -> base = base;
2673 ctx -> decl = base -> scope;
2674
2675 oberon_assert_token(ctx, RPAREN);
2676 }
2677 else
2678 {
2679 ctx -> decl = NULL;
2680 }
2681
2682 oberon_scope_t * this_scope;
2683 this_scope = oberon_open_scope(ctx);
2684 this_scope -> local = true;
2685 this_scope -> parent = NULL;
2686 this_scope -> parent_type = rec;
2687
2688 oberon_field_list(ctx, rec, modscope);
2689 while(ctx -> token == SEMICOLON)
2690 {
2691 oberon_assert_token(ctx, SEMICOLON);
2692 oberon_field_list(ctx, rec, modscope);
2693 }
2694
2695 rec -> scope = this_scope;
2696 rec -> decl = this_scope -> list -> next;
2697 ctx -> decl = oldscope;
2698 }
2699
2700 static void
2701 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2702 {
2703 if(ctx -> token == IDENT)
2704 {
2705 oberon_qualident_type(ctx, type);
2706 }
2707 else if(ctx -> token == ARRAY)
2708 {
2709 oberon_assert_token(ctx, ARRAY);
2710
2711 int num_sizes = 0;
2712 oberon_expr_t * sizes;
2713
2714 if(ISEXPR(ctx -> token))
2715 {
2716 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2717 }
2718
2719 oberon_assert_token(ctx, OF);
2720
2721 oberon_type_t * base;
2722 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2723 oberon_type(ctx, &base);
2724
2725 if(num_sizes == 0)
2726 {
2727 oberon_make_open_array(ctx, base, *type);
2728 }
2729 else
2730 {
2731 oberon_make_multiarray(ctx, sizes, base, type);
2732 }
2733 }
2734 else if(ctx -> token == RECORD)
2735 {
2736 oberon_type_t * rec;
2737 rec = *type;
2738 rec -> class = OBERON_TYPE_RECORD;
2739 rec -> module = ctx -> mod;
2740
2741 oberon_assert_token(ctx, RECORD);
2742 oberon_type_record_body(ctx, rec);
2743 oberon_assert_token(ctx, END);
2744
2745 *type = rec;
2746 }
2747 else if(ctx -> token == POINTER)
2748 {
2749 oberon_assert_token(ctx, POINTER);
2750 oberon_assert_token(ctx, TO);
2751
2752 oberon_type_t * base;
2753 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2754 oberon_type(ctx, &base);
2755
2756 oberon_type_t * ptr;
2757 ptr = *type;
2758 ptr -> class = OBERON_TYPE_POINTER;
2759 ptr -> base = base;
2760 }
2761 else if(ctx -> token == PROCEDURE)
2762 {
2763 oberon_open_scope(ctx);
2764 oberon_assert_token(ctx, PROCEDURE);
2765 oberon_opt_formal_pars(ctx, type);
2766 oberon_close_scope(ctx -> decl);
2767 }
2768 else
2769 {
2770 oberon_error(ctx, "invalid type declaration");
2771 }
2772 }
2773
2774 static void
2775 oberon_type_decl(oberon_context_t * ctx)
2776 {
2777 char * name;
2778 oberon_object_t * newtype;
2779 oberon_type_t * type;
2780 int export;
2781 int read_only;
2782
2783 name = oberon_assert_ident(ctx);
2784 oberon_def(ctx, &export, &read_only);
2785
2786 newtype = oberon_find_object(ctx -> decl, name, 0);
2787 if(newtype == NULL)
2788 {
2789 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2790 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2791 assert(newtype -> type);
2792 }
2793 else
2794 {
2795 if(newtype -> class != OBERON_CLASS_TYPE)
2796 {
2797 oberon_error(ctx, "mult definition");
2798 }
2799
2800 if(newtype -> linked)
2801 {
2802 oberon_error(ctx, "mult definition - already linked");
2803 }
2804
2805 newtype -> export = export;
2806 newtype -> read_only = read_only;
2807 }
2808
2809 oberon_assert_token(ctx, EQUAL);
2810
2811 type = newtype -> type;
2812 oberon_type(ctx, &type);
2813
2814 if(type -> class == OBERON_TYPE_VOID)
2815 {
2816 oberon_error(ctx, "recursive alias declaration");
2817 }
2818
2819 newtype -> type = type;
2820 newtype -> linked = 1;
2821 }
2822
2823 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2824 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2825
2826 static void
2827 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2828 {
2829 if(type -> class != OBERON_TYPE_POINTER
2830 && type -> class != OBERON_TYPE_ARRAY)
2831 {
2832 return;
2833 }
2834
2835 if(type -> recursive)
2836 {
2837 oberon_error(ctx, "recursive pointer declaration");
2838 }
2839
2840 if(type -> class == OBERON_TYPE_POINTER
2841 && type -> base -> class == OBERON_TYPE_POINTER)
2842 {
2843 oberon_error(ctx, "attempt to make pointer to pointer");
2844 }
2845
2846 type -> recursive = 1;
2847
2848 oberon_prevent_recursive_pointer(ctx, type -> base);
2849
2850 type -> recursive = 0;
2851 }
2852
2853 static void
2854 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2855 {
2856 if(type -> class != OBERON_TYPE_RECORD)
2857 {
2858 return;
2859 }
2860
2861 if(type -> recursive)
2862 {
2863 oberon_error(ctx, "recursive record declaration");
2864 }
2865
2866 type -> recursive = 1;
2867
2868 int num_fields = type -> num_decl;
2869 oberon_object_t * field = type -> decl;
2870 for(int i = 0; i < num_fields; i++)
2871 {
2872 oberon_prevent_recursive_object(ctx, field);
2873 field = field -> next;
2874 }
2875
2876 type -> recursive = 0;
2877 }
2878 static void
2879 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2880 {
2881 if(type -> class != OBERON_TYPE_PROCEDURE)
2882 {
2883 return;
2884 }
2885
2886 if(type -> recursive)
2887 {
2888 oberon_error(ctx, "recursive procedure declaration");
2889 }
2890
2891 type -> recursive = 1;
2892
2893 int num_fields = type -> num_decl;
2894 oberon_object_t * field = type -> decl;
2895 for(int i = 0; i < num_fields; i++)
2896 {
2897 oberon_prevent_recursive_object(ctx, field);
2898 field = field -> next;
2899 }
2900
2901 type -> recursive = 0;
2902 }
2903
2904 static void
2905 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2906 {
2907 if(type -> class != OBERON_TYPE_ARRAY)
2908 {
2909 return;
2910 }
2911
2912 if(type -> recursive)
2913 {
2914 oberon_error(ctx, "recursive array declaration");
2915 }
2916
2917 type -> recursive = 1;
2918
2919 oberon_prevent_recursive_type(ctx, type -> base);
2920
2921 type -> recursive = 0;
2922 }
2923
2924 static void
2925 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2926 {
2927 if(type -> class == OBERON_TYPE_POINTER)
2928 {
2929 oberon_prevent_recursive_pointer(ctx, type);
2930 }
2931 else if(type -> class == OBERON_TYPE_RECORD)
2932 {
2933 oberon_prevent_recursive_record(ctx, type);
2934 }
2935 else if(type -> class == OBERON_TYPE_ARRAY)
2936 {
2937 oberon_prevent_recursive_array(ctx, type);
2938 }
2939 else if(type -> class == OBERON_TYPE_PROCEDURE)
2940 {
2941 oberon_prevent_recursive_procedure(ctx, type);
2942 }
2943 }
2944
2945 static void
2946 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2947 {
2948 switch(x -> class)
2949 {
2950 case OBERON_CLASS_VAR:
2951 case OBERON_CLASS_TYPE:
2952 case OBERON_CLASS_PARAM:
2953 case OBERON_CLASS_VAR_PARAM:
2954 case OBERON_CLASS_FIELD:
2955 oberon_prevent_recursive_type(ctx, x -> type);
2956 break;
2957 case OBERON_CLASS_CONST:
2958 case OBERON_CLASS_PROC:
2959 case OBERON_CLASS_MODULE:
2960 break;
2961 default:
2962 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2963 break;
2964 }
2965 }
2966
2967 static void
2968 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2969 {
2970 oberon_object_t * x = ctx -> decl -> list -> next;
2971
2972 while(x)
2973 {
2974 oberon_prevent_recursive_object(ctx, x);
2975 x = x -> next;
2976 }
2977 }
2978
2979 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2980 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2981
2982 static void
2983 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2984 {
2985 if(type -> class != OBERON_TYPE_RECORD)
2986 {
2987 return;
2988 }
2989
2990 int num_fields = type -> num_decl;
2991 oberon_object_t * field = type -> decl;
2992 for(int i = 0; i < num_fields; i++)
2993 {
2994 if(field -> type -> class == OBERON_TYPE_POINTER)
2995 {
2996 oberon_initialize_type(ctx, field -> type);
2997 }
2998
2999 oberon_initialize_object(ctx, field);
3000 field = field -> next;
3001 }
3002
3003 oberon_generator_init_record(ctx, type);
3004 }
3005
3006 static void
3007 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
3008 {
3009 if(type -> class == OBERON_TYPE_VOID)
3010 {
3011 oberon_error(ctx, "undeclarated type");
3012 }
3013
3014 if(type -> initialized)
3015 {
3016 return;
3017 }
3018
3019 type -> initialized = 1;
3020
3021 if(type -> class == OBERON_TYPE_POINTER)
3022 {
3023 oberon_initialize_type(ctx, type -> base);
3024 oberon_generator_init_type(ctx, type);
3025 }
3026 else if(type -> class == OBERON_TYPE_ARRAY)
3027 {
3028 if(type -> size != 0)
3029 {
3030 if(type -> base -> class == OBERON_TYPE_ARRAY)
3031 {
3032 if(type -> base -> size == 0)
3033 {
3034 oberon_error(ctx, "open array not allowed as array element");
3035 }
3036 }
3037 }
3038
3039 oberon_initialize_type(ctx, type -> base);
3040 oberon_generator_init_type(ctx, type);
3041 }
3042 else if(type -> class == OBERON_TYPE_RECORD)
3043 {
3044 oberon_generator_init_type(ctx, type);
3045 oberon_initialize_record_fields(ctx, type);
3046 }
3047 else if(type -> class == OBERON_TYPE_PROCEDURE)
3048 {
3049 int num_fields = type -> num_decl;
3050 oberon_object_t * field = type -> decl;
3051 for(int i = 0; i < num_fields; i++)
3052 {
3053 oberon_initialize_object(ctx, field);
3054 field = field -> next;
3055 }
3056
3057 oberon_generator_init_type(ctx, type);
3058 }
3059 else
3060 {
3061 oberon_generator_init_type(ctx, type);
3062 }
3063 }
3064
3065 static void
3066 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
3067 {
3068 if(x -> initialized)
3069 {
3070 return;
3071 }
3072
3073 x -> initialized = 1;
3074
3075 switch(x -> class)
3076 {
3077 case OBERON_CLASS_TYPE:
3078 oberon_initialize_type(ctx, x -> type);
3079 break;
3080 case OBERON_CLASS_VAR:
3081 case OBERON_CLASS_FIELD:
3082 if(x -> type -> class == OBERON_TYPE_ARRAY)
3083 {
3084 if(x -> type -> size == 0)
3085 {
3086 oberon_error(ctx, "open array not allowed as variable or field");
3087 }
3088 }
3089 oberon_initialize_type(ctx, x -> type);
3090 oberon_generator_init_var(ctx, x);
3091 break;
3092 case OBERON_CLASS_PARAM:
3093 case OBERON_CLASS_VAR_PARAM:
3094 oberon_initialize_type(ctx, x -> type);
3095 oberon_generator_init_var(ctx, x);
3096 break;
3097 case OBERON_CLASS_CONST:
3098 case OBERON_CLASS_PROC:
3099 case OBERON_CLASS_MODULE:
3100 break;
3101 default:
3102 oberon_error(ctx, "oberon_initialize_object: wat");
3103 break;
3104 }
3105 }
3106
3107 static void
3108 oberon_initialize_decl(oberon_context_t * ctx)
3109 {
3110 oberon_object_t * x = ctx -> decl -> list;
3111
3112 while(x -> next)
3113 {
3114 oberon_initialize_object(ctx, x -> next);
3115 x = x -> next;
3116 }
3117 }
3118
3119 static void
3120 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
3121 {
3122 oberon_object_t * x = ctx -> decl -> list;
3123
3124 while(x -> next)
3125 {
3126 if(x -> next -> class == OBERON_CLASS_PROC)
3127 {
3128 if(x -> next -> linked == 0)
3129 {
3130 oberon_error(ctx, "unresolved forward declaration");
3131 }
3132 }
3133 x = x -> next;
3134 }
3135 }
3136
3137 static void
3138 oberon_decl_seq(oberon_context_t * ctx)
3139 {
3140 if(ctx -> token == CONST)
3141 {
3142 oberon_assert_token(ctx, CONST);
3143 while(ctx -> token == IDENT)
3144 {
3145 oberon_const_decl(ctx);
3146 oberon_assert_token(ctx, SEMICOLON);
3147 }
3148 }
3149
3150 if(ctx -> token == TYPE)
3151 {
3152 oberon_assert_token(ctx, TYPE);
3153 while(ctx -> token == IDENT)
3154 {
3155 oberon_type_decl(ctx);
3156 oberon_assert_token(ctx, SEMICOLON);
3157 }
3158 }
3159
3160 if(ctx -> token == VAR)
3161 {
3162 oberon_assert_token(ctx, VAR);
3163 while(ctx -> token == IDENT)
3164 {
3165 oberon_var_decl(ctx);
3166 oberon_assert_token(ctx, SEMICOLON);
3167 }
3168 }
3169
3170 oberon_prevent_recursive_decl(ctx);
3171 oberon_initialize_decl(ctx);
3172
3173 while(ctx -> token == PROCEDURE)
3174 {
3175 oberon_proc_decl(ctx);
3176 oberon_assert_token(ctx, SEMICOLON);
3177 }
3178
3179 oberon_prevent_undeclarated_procedures(ctx);
3180 }
3181
3182 static oberon_expr_t *
3183 oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type)
3184 {
3185 oberon_object_t * x;
3186 oberon_expr_t * expr;
3187
3188 x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false);
3189 x -> local = true;
3190 x -> type = type;
3191 oberon_generator_init_temp_var(ctx, x);
3192
3193 expr = oberon_new_item(MODE_VAR, type, false);
3194 expr -> item.var = x;
3195 return expr;
3196 }
3197
3198 static void
3199 oberon_statement_seq(oberon_context_t * ctx);
3200
3201 static void
3202 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
3203 {
3204 if(dst -> read_only)
3205 {
3206 oberon_error(ctx, "read-only destination");
3207 }
3208
3209 oberon_check_dst(ctx, dst);
3210 src = oberon_autocast_to(ctx, src, dst -> result);
3211 oberon_generate_assign(ctx, src, dst);
3212 }
3213
3214 static oberon_expr_t *
3215 oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val)
3216 {
3217 oberon_expr_t * e1;
3218 oberon_expr_t * e2;
3219 oberon_expr_t * cond;
3220 oberon_expr_t * cond2;
3221
3222 e1 = (oberon_expr_t *) oberon_const_expr(ctx);
3223 oberon_autocast_to(ctx, e1, val -> result);
3224
3225 e2 = NULL;
3226 if(ctx -> token == DOTDOT)
3227 {
3228 oberon_assert_token(ctx, DOTDOT);
3229 e2 = (oberon_expr_t *) oberon_const_expr(ctx);
3230 oberon_autocast_to(ctx, e2, val -> result);
3231 }
3232
3233 if(e2 == NULL)
3234 {
3235 /* val == e1 */
3236 cond = oberon_make_bin_op(ctx, EQUAL, val, e1);
3237 }
3238 else
3239 {
3240 /* val >= e1 && val <= e2 */
3241 cond = oberon_make_bin_op(ctx, GEQ, val, e1);
3242 cond2 = oberon_make_bin_op(ctx, LEQ, val, e2);
3243 cond = oberon_make_bin_op(ctx, AND, cond, cond2);
3244 }
3245
3246 return cond;
3247 }
3248
3249 static void
3250 oberon_case(oberon_context_t * ctx, oberon_expr_t * val, gen_label_t * end)
3251 {
3252 oberon_expr_t * cond;
3253 oberon_expr_t * cond2;
3254 gen_label_t * this_end;
3255
3256 if(ISEXPR(ctx -> token))
3257 {
3258 this_end = oberon_generator_reserve_label(ctx);
3259
3260 cond = oberon_case_labels(ctx, val);
3261 while(ctx -> token == COMMA)
3262 {
3263 oberon_assert_token(ctx, COMMA);
3264 /* cond || cond2 */
3265 cond2 = oberon_case_labels(ctx, val);
3266 cond = oberon_make_bin_op(ctx, OR, cond, cond2);
3267 }
3268 oberon_assert_token(ctx, COLON);
3269
3270 oberon_generate_branch(ctx, cond, false, this_end);
3271 oberon_statement_seq(ctx);
3272 oberon_generate_goto(ctx, end);
3273
3274 oberon_generate_label(ctx, this_end);
3275 }
3276 }
3277
3278 static void
3279 oberon_case_statement(oberon_context_t * ctx)
3280 {
3281 oberon_expr_t * val;
3282 oberon_expr_t * expr;
3283 gen_label_t * end;
3284
3285 end = oberon_generator_reserve_label(ctx);
3286
3287 oberon_assert_token(ctx, CASE);
3288 expr = oberon_expr(ctx);
3289 val = oberon_make_temp_var_item(ctx, expr -> result);
3290 oberon_assign(ctx, expr, val);
3291 oberon_assert_token(ctx, OF);
3292 oberon_case(ctx, val, end);
3293 while(ctx -> token == BAR)
3294 {
3295 oberon_assert_token(ctx, BAR);
3296 oberon_case(ctx, val, end);
3297 }
3298
3299 if(ctx -> token == ELSE)
3300 {
3301 oberon_assert_token(ctx, ELSE);
3302 oberon_statement_seq(ctx);
3303 }
3304
3305 oberon_generate_label(ctx, end);
3306 oberon_assert_token(ctx, END);
3307 }
3308
3309 static void
3310 oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end)
3311 {
3312 oberon_expr_t * val;
3313 oberon_expr_t * var;
3314 oberon_expr_t * type;
3315 oberon_expr_t * cond;
3316 oberon_expr_t * cast;
3317 oberon_type_t * old_type;
3318 gen_var_t * old_var;
3319 gen_label_t * this_end;
3320
3321 this_end = oberon_generator_reserve_label(ctx);
3322
3323 var = oberon_qualident_expr(ctx);
3324 oberon_assert_token(ctx, COLON);
3325 type = oberon_qualident_expr(ctx);
3326 cond = oberon_make_bin_op(ctx, IS, var, type);
3327
3328 oberon_assert_token(ctx, DO);
3329 oberon_generate_branch(ctx, cond, false, this_end);
3330
3331 /* Сохраняем ссылку во временной переменной */
3332 val = oberon_make_temp_var_item(ctx, type -> result);
3333 cast = oberno_make_record_cast(ctx, var, type -> result);
3334 oberon_assign(ctx, cast, val);
3335 /* Подменяем тип у оригинальной переменной */
3336 old_type = var -> item.var -> type;
3337 var -> item.var -> type = type -> result;
3338 /* Подменяем ссылку на переменную */
3339 old_var = var -> item.var -> gen_var;
3340 var -> item.var -> gen_var = val -> item.var -> gen_var;
3341
3342 oberon_statement_seq(ctx);
3343 oberon_generate_goto(ctx, end);
3344 oberon_generate_label(ctx, this_end);
3345
3346 /* Возвращаем исходное состояние */
3347 var -> item.var -> gen_var = old_var;
3348 var -> item.var -> type = old_type;
3349 }
3350
3351 static void
3352 oberon_with_statement(oberon_context_t * ctx)
3353 {
3354 gen_label_t * end;
3355 end = oberon_generator_reserve_label(ctx);
3356
3357 oberon_assert_token(ctx, WITH);
3358 oberon_with_guard_do(ctx, end);
3359 while(ctx -> token == BAR)
3360 {
3361 oberon_assert_token(ctx, BAR);
3362 oberon_with_guard_do(ctx, end);
3363 }
3364
3365 if(ctx -> token == ELSE)
3366 {
3367 oberon_assert_token(ctx, ELSE);
3368 oberon_statement_seq(ctx);
3369 }
3370
3371 oberon_generate_label(ctx, end);
3372 oberon_assert_token(ctx, END);
3373 }
3374
3375 static void
3376 oberon_statement(oberon_context_t * ctx)
3377 {
3378 oberon_expr_t * item1;
3379 oberon_expr_t * item2;
3380
3381 if(ctx -> token == IDENT)
3382 {
3383 item1 = oberon_designator(ctx);
3384 if(ctx -> token == ASSIGN)
3385 {
3386 oberon_assert_token(ctx, ASSIGN);
3387 item2 = oberon_expr(ctx);
3388 oberon_assign(ctx, item2, item1);
3389 }
3390 else
3391 {
3392 oberon_opt_proc_parens(ctx, item1);
3393 }
3394 }
3395 else if(ctx -> token == IF)
3396 {
3397 gen_label_t * end;
3398 gen_label_t * els;
3399 oberon_expr_t * cond;
3400
3401 els = oberon_generator_reserve_label(ctx);
3402 end = oberon_generator_reserve_label(ctx);
3403
3404 oberon_assert_token(ctx, IF);
3405 cond = oberon_expr(ctx);
3406 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3407 {
3408 oberon_error(ctx, "condition must be boolean");
3409 }
3410 oberon_assert_token(ctx, THEN);
3411 oberon_generate_branch(ctx, cond, false, els);
3412 oberon_statement_seq(ctx);
3413 oberon_generate_goto(ctx, end);
3414 oberon_generate_label(ctx, els);
3415
3416 while(ctx -> token == ELSIF)
3417 {
3418 els = oberon_generator_reserve_label(ctx);
3419
3420 oberon_assert_token(ctx, ELSIF);
3421 cond = oberon_expr(ctx);
3422 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3423 {
3424 oberon_error(ctx, "condition must be boolean");
3425 }
3426 oberon_assert_token(ctx, THEN);
3427 oberon_generate_branch(ctx, cond, false, els);
3428 oberon_statement_seq(ctx);
3429 oberon_generate_goto(ctx, end);
3430 oberon_generate_label(ctx, els);
3431 }
3432
3433 if(ctx -> token == ELSE)
3434 {
3435 oberon_assert_token(ctx, ELSE);
3436 oberon_statement_seq(ctx);
3437 }
3438
3439 oberon_generate_label(ctx, end);
3440 oberon_assert_token(ctx, END);
3441 }
3442 else if(ctx -> token == WHILE)
3443 {
3444 gen_label_t * begin;
3445 gen_label_t * end;
3446 oberon_expr_t * cond;
3447
3448 begin = oberon_generator_reserve_label(ctx);
3449 end = oberon_generator_reserve_label(ctx);
3450
3451 oberon_assert_token(ctx, WHILE);
3452 oberon_generate_label(ctx, begin);
3453 cond = oberon_expr(ctx);
3454 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3455 {
3456 oberon_error(ctx, "condition must be boolean");
3457 }
3458 oberon_generate_branch(ctx, cond, false, end);
3459
3460 oberon_assert_token(ctx, DO);
3461 oberon_statement_seq(ctx);
3462 oberon_generate_goto(ctx, begin);
3463
3464 oberon_assert_token(ctx, END);
3465 oberon_generate_label(ctx, end);
3466 }
3467 else if(ctx -> token == REPEAT)
3468 {
3469 gen_label_t * begin;
3470 oberon_expr_t * cond;
3471
3472 begin = oberon_generator_reserve_label(ctx);
3473 oberon_generate_label(ctx, begin);
3474 oberon_assert_token(ctx, REPEAT);
3475
3476 oberon_statement_seq(ctx);
3477
3478 oberon_assert_token(ctx, UNTIL);
3479
3480 cond = oberon_expr(ctx);
3481 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3482 {
3483 oberon_error(ctx, "condition must be boolean");
3484 }
3485
3486 oberon_generate_branch(ctx, cond, true, begin);
3487 }
3488 else if(ctx -> token == FOR)
3489 {
3490 oberon_expr_t * from;
3491 oberon_expr_t * index;
3492 oberon_expr_t * to;
3493 oberon_expr_t * bound;
3494 oberon_expr_t * by;
3495 oberon_expr_t * cond;
3496 oberon_expr_t * count;
3497 gen_label_t * begin;
3498 gen_label_t * end;
3499 char * iname;
3500 int op;
3501
3502 begin = oberon_generator_reserve_label(ctx);
3503 end = oberon_generator_reserve_label(ctx);
3504
3505 oberon_assert_token(ctx, FOR);
3506 iname = oberon_assert_ident(ctx);
3507 index = oberon_ident_item(ctx, iname);
3508 oberon_assert_token(ctx, ASSIGN);
3509 from = oberon_expr(ctx);
3510 oberon_assign(ctx, from, index);
3511 oberon_assert_token(ctx, TO);
3512 bound = oberon_make_temp_var_item(ctx, index -> result);
3513 to = oberon_expr(ctx);
3514 oberon_assign(ctx, to, bound);
3515 if(ctx -> token == BY)
3516 {
3517 oberon_assert_token(ctx, BY);
3518 by = (oberon_expr_t *) oberon_const_expr(ctx);
3519 }
3520 else
3521 {
3522 by = oberon_integer_item(ctx, 1);
3523 }
3524
3525 if(by -> result -> class != OBERON_TYPE_INTEGER)
3526 {
3527 oberon_error(ctx, "must be integer");
3528 }
3529
3530 if(by -> item.integer > 0)
3531 {
3532 op = LEQ;
3533 }
3534 else if(by -> item.integer < 0)
3535 {
3536 op = GEQ;
3537 }
3538 else
3539 {
3540 oberon_error(ctx, "zero step not allowed");
3541 }
3542
3543 oberon_assert_token(ctx, DO);
3544 oberon_generate_label(ctx, begin);
3545 cond = oberon_make_bin_op(ctx, op, index, bound);
3546 oberon_generate_branch(ctx, cond, false, end);
3547 oberon_statement_seq(ctx);
3548 count = oberon_make_bin_op(ctx, PLUS, index, by);
3549 oberon_assign(ctx, count, index);
3550 oberon_generate_goto(ctx, begin);
3551 oberon_generate_label(ctx, end);
3552 oberon_assert_token(ctx, END);
3553 }
3554 else if(ctx -> token == LOOP)
3555 {
3556 gen_label_t * begin;
3557 gen_label_t * end;
3558
3559 begin = oberon_generator_reserve_label(ctx);
3560 end = oberon_generator_reserve_label(ctx);
3561
3562 oberon_open_scope(ctx);
3563 oberon_assert_token(ctx, LOOP);
3564 oberon_generate_label(ctx, begin);
3565 ctx -> decl -> exit_label = end;
3566 oberon_statement_seq(ctx);
3567 oberon_generate_goto(ctx, begin);
3568 oberon_generate_label(ctx, end);
3569 oberon_assert_token(ctx, END);
3570 oberon_close_scope(ctx -> decl);
3571 }
3572 else if(ctx -> token == EXIT)
3573 {
3574 oberon_assert_token(ctx, EXIT);
3575 if(ctx -> decl -> exit_label == NULL)
3576 {
3577 oberon_error(ctx, "not in LOOP-END");
3578 }
3579 oberon_generate_goto(ctx, ctx -> decl -> exit_label);
3580 }
3581 else if(ctx -> token == CASE)
3582 {
3583 oberon_case_statement(ctx);
3584 }
3585 else if(ctx -> token == WITH)
3586 {
3587 oberon_with_statement(ctx);
3588 }
3589 else if(ctx -> token == RETURN)
3590 {
3591 oberon_assert_token(ctx, RETURN);
3592 if(ISEXPR(ctx -> token))
3593 {
3594 oberon_expr_t * expr;
3595 expr = oberon_expr(ctx);
3596 oberon_make_return(ctx, expr);
3597 }
3598 else
3599 {
3600 oberon_make_return(ctx, NULL);
3601 }
3602 }
3603 }
3604
3605 static void
3606 oberon_statement_seq(oberon_context_t * ctx)
3607 {
3608 oberon_statement(ctx);
3609 while(ctx -> token == SEMICOLON)
3610 {
3611 oberon_assert_token(ctx, SEMICOLON);
3612 oberon_statement(ctx);
3613 }
3614 }
3615
3616 static void
3617 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
3618 {
3619 oberon_module_t * m = ctx -> module_list;
3620 while(m && strcmp(m -> name, name) != 0)
3621 {
3622 m = m -> next;
3623 }
3624
3625 if(m == NULL)
3626 {
3627 const char * code;
3628 code = ctx -> import_module(name);
3629 if(code == NULL)
3630 {
3631 oberon_error(ctx, "no such module");
3632 }
3633
3634 m = oberon_compile_module(ctx, code);
3635 assert(m);
3636 }
3637
3638 if(m -> ready == 0)
3639 {
3640 oberon_error(ctx, "cyclic module import");
3641 }
3642
3643 oberon_object_t * ident;
3644 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
3645 ident -> module = m;
3646 }
3647
3648 static void
3649 oberon_import_decl(oberon_context_t * ctx)
3650 {
3651 char * alias;
3652 char * name;
3653
3654 alias = name = oberon_assert_ident(ctx);
3655 if(ctx -> token == ASSIGN)
3656 {
3657 oberon_assert_token(ctx, ASSIGN);
3658 name = oberon_assert_ident(ctx);
3659 }
3660
3661 oberon_import_module(ctx, alias, name);
3662 }
3663
3664 static void
3665 oberon_import_list(oberon_context_t * ctx)
3666 {
3667 oberon_assert_token(ctx, IMPORT);
3668
3669 oberon_import_decl(ctx);
3670 while(ctx -> token == COMMA)
3671 {
3672 oberon_assert_token(ctx, COMMA);
3673 oberon_import_decl(ctx);
3674 }
3675
3676 oberon_assert_token(ctx, SEMICOLON);
3677 }
3678
3679 static void
3680 oberon_parse_module(oberon_context_t * ctx)
3681 {
3682 char * name1;
3683 char * name2;
3684 oberon_read_token(ctx);
3685
3686 oberon_assert_token(ctx, MODULE);
3687 name1 = oberon_assert_ident(ctx);
3688 oberon_assert_token(ctx, SEMICOLON);
3689 ctx -> mod -> name = name1;
3690
3691 oberon_generator_init_module(ctx, ctx -> mod);
3692
3693 if(ctx -> token == IMPORT)
3694 {
3695 oberon_import_list(ctx);
3696 }
3697
3698 oberon_decl_seq(ctx);
3699
3700 oberon_generate_begin_module(ctx);
3701 if(ctx -> token == BEGIN)
3702 {
3703 oberon_assert_token(ctx, BEGIN);
3704 oberon_statement_seq(ctx);
3705 }
3706 oberon_generate_end_module(ctx);
3707
3708 oberon_assert_token(ctx, END);
3709 name2 = oberon_assert_ident(ctx);
3710 oberon_assert_token(ctx, DOT);
3711
3712 if(strcmp(name1, name2) != 0)
3713 {
3714 oberon_error(ctx, "module name not matched");
3715 }
3716
3717 oberon_generator_fini_module(ctx -> mod);
3718 }
3719
3720 // =======================================================================
3721 // LIBRARY
3722 // =======================================================================
3723
3724 static void
3725 register_default_types(oberon_context_t * ctx)
3726 {
3727 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
3728 oberon_generator_init_type(ctx, ctx -> void_type);
3729
3730 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
3731 ctx -> void_ptr_type -> base = ctx -> void_type;
3732 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
3733
3734 ctx -> string_type = oberon_new_type_string(1);
3735 oberon_generator_init_type(ctx, ctx -> string_type);
3736
3737 ctx -> bool_type = oberon_new_type_boolean();
3738 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
3739
3740 ctx -> byte_type = oberon_new_type_integer(1);
3741 oberon_define_type(ctx -> world_scope, "BYTE", ctx -> byte_type, 1);
3742
3743 ctx -> shortint_type = oberon_new_type_integer(2);
3744 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> shortint_type, 1);
3745
3746 ctx -> int_type = oberon_new_type_integer(4);
3747 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
3748
3749 ctx -> longint_type = oberon_new_type_integer(8);
3750 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> longint_type, 1);
3751
3752 ctx -> real_type = oberon_new_type_real(4);
3753 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
3754
3755 ctx -> longreal_type = oberon_new_type_real(8);
3756 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
3757
3758 ctx -> char_type = oberon_new_type_char(1);
3759 oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1);
3760
3761 ctx -> set_type = oberon_new_type_set(4);
3762 oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1);
3763 }
3764
3765 static void
3766 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
3767 {
3768 oberon_object_t * proc;
3769 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
3770 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
3771 proc -> type -> sysproc = true;
3772 proc -> type -> genfunc = f;
3773 proc -> type -> genproc = p;
3774 }
3775
3776 static oberon_expr_t *
3777 oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3778 {
3779 if(num_args < 1)
3780 {
3781 oberon_error(ctx, "too few arguments");
3782 }
3783
3784 if(num_args > 1)
3785 {
3786 oberon_error(ctx, "too mach arguments");
3787 }
3788
3789 oberon_expr_t * arg;
3790 arg = list_args;
3791
3792 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3793 {
3794 oberon_error(ctx, "MIN accept only type");
3795 }
3796
3797 oberon_expr_t * expr;
3798 int bits = arg -> result -> size * 8;
3799 switch(arg -> result -> class)
3800 {
3801 case OBERON_TYPE_INTEGER:
3802 expr = oberon_integer_item(ctx, -powl(2, bits - 1));
3803 break;
3804 case OBERON_TYPE_SET:
3805 expr = oberon_integer_item(ctx, 0);
3806 break;
3807 default:
3808 oberon_error(ctx, "allowed only basic types");
3809 break;
3810 }
3811
3812 return expr;
3813 }
3814
3815 static oberon_expr_t *
3816 oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3817 {
3818 if(num_args < 1)
3819 {
3820 oberon_error(ctx, "too few arguments");
3821 }
3822
3823 if(num_args > 1)
3824 {
3825 oberon_error(ctx, "too mach arguments");
3826 }
3827
3828 oberon_expr_t * arg;
3829 arg = list_args;
3830
3831 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3832 {
3833 oberon_error(ctx, "MAX accept only type");
3834 }
3835
3836 oberon_expr_t * expr;
3837 int bits = arg -> result -> size * 8;
3838 switch(arg -> result -> class)
3839 {
3840 case OBERON_TYPE_INTEGER:
3841 expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1);
3842 break;
3843 case OBERON_TYPE_SET:
3844 expr = oberon_integer_item(ctx, bits);
3845 break;
3846 default:
3847 oberon_error(ctx, "allowed only basic types");
3848 break;
3849 }
3850
3851 return expr;
3852 }
3853
3854 static oberon_expr_t *
3855 oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3856 {
3857 if(num_args < 1)
3858 {
3859 oberon_error(ctx, "too few arguments");
3860 }
3861
3862 if(num_args > 1)
3863 {
3864 oberon_error(ctx, "too mach arguments");
3865 }
3866
3867 oberon_expr_t * arg;
3868 arg = list_args;
3869
3870 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3871 {
3872 oberon_error(ctx, "SIZE accept only type");
3873 }
3874
3875 int size;
3876 oberon_expr_t * expr;
3877 oberon_type_t * type = arg -> result;
3878 switch(type -> class)
3879 {
3880 case OBERON_TYPE_INTEGER:
3881 case OBERON_TYPE_BOOLEAN:
3882 case OBERON_TYPE_REAL:
3883 case OBERON_TYPE_CHAR:
3884 case OBERON_TYPE_SET:
3885 size = type -> size;
3886 break;
3887 default:
3888 oberon_error(ctx, "TODO SIZE");
3889 break;
3890 }
3891
3892 expr = oberon_integer_item(ctx, size);
3893 return expr;
3894 }
3895
3896 static oberon_expr_t *
3897 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3898 {
3899 if(num_args < 1)
3900 {
3901 oberon_error(ctx, "too few arguments");
3902 }
3903
3904 if(num_args > 1)
3905 {
3906 oberon_error(ctx, "too mach arguments");
3907 }
3908
3909 oberon_expr_t * arg;
3910 arg = list_args;
3911 oberon_check_src(ctx, arg);
3912
3913 oberon_type_t * result_type;
3914 result_type = arg -> result;
3915
3916 if(result_type -> class != OBERON_TYPE_INTEGER)
3917 {
3918 oberon_error(ctx, "ABS accepts only integers");
3919 }
3920
3921 oberon_expr_t * expr;
3922 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
3923 return expr;
3924 }
3925
3926 static void
3927 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3928 {
3929 if(num_args < 1)
3930 {
3931 oberon_error(ctx, "too few arguments");
3932 }
3933
3934
3935 oberon_expr_t * dst;
3936 dst = list_args;
3937 oberon_check_dst(ctx, dst);
3938
3939 oberon_type_t * type;
3940 type = dst -> result;
3941
3942 if(type -> class != OBERON_TYPE_POINTER)
3943 {
3944 oberon_error(ctx, "not a pointer");
3945 }
3946
3947 type = type -> base;
3948
3949 oberon_expr_t * src;
3950 src = oberon_new_item(MODE_NEW, dst -> result, 0);
3951 src -> item.num_args = 0;
3952 src -> item.args = NULL;
3953
3954 int max_args = 1;
3955 if(type -> class == OBERON_TYPE_ARRAY)
3956 {
3957 if(type -> size == 0)
3958 {
3959 oberon_type_t * x = type;
3960 while(x -> class == OBERON_TYPE_ARRAY)
3961 {
3962 if(x -> size == 0)
3963 {
3964 max_args += 1;
3965 }
3966 x = x -> base;
3967 }
3968 }
3969
3970 if(num_args < max_args)
3971 {
3972 oberon_error(ctx, "too few arguments");
3973 }
3974
3975 if(num_args > max_args)
3976 {
3977 oberon_error(ctx, "too mach arguments");
3978 }
3979
3980 int num_sizes = max_args - 1;
3981 oberon_expr_t * size_list = list_args -> next;
3982
3983 oberon_expr_t * arg = size_list;
3984 for(int i = 0; i < max_args - 1; i++)
3985 {
3986 oberon_check_src(ctx, arg);
3987 if(arg -> result -> class != OBERON_TYPE_INTEGER)
3988 {
3989 oberon_error(ctx, "size must be integer");
3990 }
3991 arg = arg -> next;
3992 }
3993
3994 src -> item.num_args = num_sizes;
3995 src -> item.args = size_list;
3996 }
3997 else if(type -> class != OBERON_TYPE_RECORD)
3998 {
3999 oberon_error(ctx, "oberon_make_new_call: wat");
4000 }
4001
4002 if(num_args > max_args)
4003 {
4004 oberon_error(ctx, "too mach arguments");
4005 }
4006
4007 oberon_assign(ctx, src, dst);
4008 }
4009
4010 oberon_context_t *
4011 oberon_create_context(ModuleImportCallback import_module)
4012 {
4013 oberon_context_t * ctx = calloc(1, sizeof *ctx);
4014
4015 oberon_scope_t * world_scope;
4016 world_scope = oberon_open_scope(ctx);
4017 ctx -> world_scope = world_scope;
4018
4019 ctx -> import_module = import_module;
4020
4021 oberon_generator_init_context(ctx);
4022
4023 register_default_types(ctx);
4024
4025 /* Functions */
4026 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
4027 oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL);
4028 oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
4029 oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
4030
4031 /* Procedures */
4032 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
4033
4034 return ctx;
4035 }
4036
4037 void
4038 oberon_destroy_context(oberon_context_t * ctx)
4039 {
4040 oberon_generator_destroy_context(ctx);
4041 free(ctx);
4042 }
4043
4044 oberon_module_t *
4045 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
4046 {
4047 const char * code = ctx -> code;
4048 int code_index = ctx -> code_index;
4049 char c = ctx -> c;
4050 int token = ctx -> token;
4051 char * string = ctx -> string;
4052 int integer = ctx -> integer;
4053 int real = ctx -> real;
4054 bool longmode = ctx -> longmode;
4055 oberon_scope_t * decl = ctx -> decl;
4056 oberon_module_t * mod = ctx -> mod;
4057
4058 oberon_scope_t * module_scope;
4059 module_scope = oberon_open_scope(ctx);
4060
4061 oberon_module_t * module;
4062 module = calloc(1, sizeof *module);
4063 module -> decl = module_scope;
4064 module -> next = ctx -> module_list;
4065
4066 ctx -> mod = module;
4067 ctx -> module_list = module;
4068
4069 oberon_init_scaner(ctx, newcode);
4070 oberon_parse_module(ctx);
4071
4072 module -> ready = 1;
4073
4074 ctx -> code = code;
4075 ctx -> code_index = code_index;
4076 ctx -> c = c;
4077 ctx -> token = token;
4078 ctx -> string = string;
4079 ctx -> integer = integer;
4080 ctx -> real = real;
4081 ctx -> longmode = longmode;
4082 ctx -> decl = decl;
4083 ctx -> mod = mod;
4084
4085 return module;
4086 }
Another attempt to make Oberon compiler
DEADSOFTWARE 2012-2025