DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / dsw-obn.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Добавлена конструкция WITH
[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 -> read_only)
1227 {
1228 oberon_error(ctx, "assign to read-only var");
1229 }
1230 }
1231
1232 casted[i] = oberon_autocast_to(ctx, arg, param -> type);
1233 arg = arg -> next;
1234 param = param -> next;
1235 }
1236
1237 /* Создаём новый список выражений */
1238 if(num_args > 0)
1239 {
1240 arg = casted[0];
1241 for(int i = 0; i < num_args - 1; i++)
1242 {
1243 casted[i] -> next = casted[i + 1];
1244 }
1245 desig -> args = arg;
1246 }
1247 }
1248
1249 static oberon_expr_t *
1250 oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1251 {
1252 oberon_type_t * signature = item -> result;
1253 if(signature -> class != OBERON_TYPE_PROCEDURE)
1254 {
1255 oberon_error(ctx, "not a procedure");
1256 }
1257
1258 oberon_expr_t * call;
1259
1260 if(signature -> sysproc)
1261 {
1262 if(signature -> genfunc == NULL)
1263 {
1264 oberon_error(ctx, "not a function-procedure");
1265 }
1266
1267 call = signature -> genfunc(ctx, num_args, list_args);
1268 }
1269 else
1270 {
1271 if(signature -> base -> class == OBERON_TYPE_VOID)
1272 {
1273 oberon_error(ctx, "attempt to call procedure in expression");
1274 }
1275
1276 call = oberon_new_item(MODE_CALL, signature -> base, true);
1277 call -> item.parent = item;
1278 call -> item.num_args = num_args;
1279 call -> item.args = list_args;
1280 oberon_autocast_call(ctx, (oberon_item_t *) call);
1281 }
1282
1283 return call;
1284 }
1285
1286 static void
1287 oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1288 {
1289 oberon_type_t * signature = item -> result;
1290 if(signature -> class != OBERON_TYPE_PROCEDURE)
1291 {
1292 oberon_error(ctx, "not a procedure");
1293 }
1294
1295 oberon_expr_t * call;
1296
1297 if(signature -> sysproc)
1298 {
1299 if(signature -> genproc == NULL)
1300 {
1301 oberon_error(ctx, "not a procedure");
1302 }
1303
1304 signature -> genproc(ctx, num_args, list_args);
1305 }
1306 else
1307 {
1308 if(signature -> base -> class != OBERON_TYPE_VOID)
1309 {
1310 oberon_error(ctx, "attempt to call function as non-typed procedure");
1311 }
1312
1313 call = oberon_new_item(MODE_CALL, signature -> base, true);
1314 call -> item.parent = item;
1315 call -> item.num_args = num_args;
1316 call -> item.args = list_args;
1317 oberon_autocast_call(ctx, (oberon_item_t *) call);
1318 oberon_generate_call_proc(ctx, call);
1319 }
1320 }
1321
1322 #define ISEXPR(x) \
1323 (((x) == PLUS) \
1324 || ((x) == MINUS) \
1325 || ((x) == IDENT) \
1326 || ((x) == INTEGER) \
1327 || ((x) == REAL) \
1328 || ((x) == CHAR) \
1329 || ((x) == STRING) \
1330 || ((x) == NIL) \
1331 || ((x) == LPAREN) \
1332 || ((x) == NOT) \
1333 || ((x) == TRUE) \
1334 || ((x) == FALSE))
1335
1336 static oberon_expr_t *
1337 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
1338 {
1339 printf("oberno_make_dereferencing\n");
1340 if(expr -> result -> class != OBERON_TYPE_POINTER)
1341 {
1342 oberon_error(ctx, "not a pointer");
1343 }
1344
1345 assert(expr -> is_item);
1346
1347 oberon_expr_t * selector;
1348 selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
1349 selector -> item.parent = (oberon_item_t *) expr;
1350
1351 return selector;
1352 }
1353
1354 static oberon_expr_t *
1355 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
1356 {
1357 if(desig -> result -> class == OBERON_TYPE_POINTER)
1358 {
1359 desig = oberno_make_dereferencing(ctx, desig);
1360 }
1361
1362 assert(desig -> is_item);
1363
1364 if(desig -> result -> class != OBERON_TYPE_ARRAY)
1365 {
1366 oberon_error(ctx, "not array");
1367 }
1368
1369 oberon_type_t * base;
1370 base = desig -> result -> base;
1371
1372 if(index -> result -> class != OBERON_TYPE_INTEGER)
1373 {
1374 oberon_error(ctx, "index must be integer");
1375 }
1376
1377 // Статическая проверка границ массива
1378 if(desig -> result -> size != 0)
1379 {
1380 if(index -> is_item)
1381 {
1382 if(index -> item.mode == MODE_INTEGER)
1383 {
1384 int arr_size = desig -> result -> size;
1385 int index_int = index -> item.integer;
1386 if(index_int < 0 || index_int > arr_size - 1)
1387 {
1388 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
1389 }
1390 }
1391 }
1392 }
1393
1394 oberon_expr_t * selector;
1395 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
1396 selector -> item.parent = (oberon_item_t *) desig;
1397 selector -> item.num_args = 1;
1398 selector -> item.args = index;
1399
1400 return selector;
1401 }
1402
1403 static oberon_expr_t *
1404 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
1405 {
1406 if(expr -> result -> class == OBERON_TYPE_POINTER)
1407 {
1408 expr = oberno_make_dereferencing(ctx, expr);
1409 }
1410
1411 assert(expr -> is_item);
1412
1413 if(expr -> result -> class != OBERON_TYPE_RECORD)
1414 {
1415 oberon_error(ctx, "not record");
1416 }
1417
1418 oberon_type_t * rec = expr -> result;
1419
1420 oberon_object_t * field;
1421 field = oberon_find_object(rec -> scope, name, true);
1422
1423 if(field -> export == 0)
1424 {
1425 if(field -> module != ctx -> mod)
1426 {
1427 oberon_error(ctx, "field not exported");
1428 }
1429 }
1430
1431 int read_only = 0;
1432 if(field -> read_only)
1433 {
1434 if(field -> module != ctx -> mod)
1435 {
1436 read_only = 1;
1437 }
1438 }
1439
1440 oberon_expr_t * selector;
1441 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
1442 selector -> item.var = field;
1443 selector -> item.parent = (oberon_item_t *) expr;
1444
1445 return selector;
1446 }
1447
1448 #define ISSELECTOR(x) \
1449 (((x) == LBRACK) \
1450 || ((x) == DOT) \
1451 || ((x) == UPARROW) \
1452 || ((x) == LPAREN))
1453
1454 static oberon_object_t *
1455 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1456 {
1457 char * name;
1458 oberon_object_t * x;
1459
1460 name = oberon_assert_ident(ctx);
1461 x = oberon_find_object(ctx -> decl, name, check);
1462
1463 if(x != NULL)
1464 {
1465 if(x -> class == OBERON_CLASS_MODULE)
1466 {
1467 oberon_assert_token(ctx, DOT);
1468 name = oberon_assert_ident(ctx);
1469 /* Наличие объектов в левых модулях всегда проверяется */
1470 x = oberon_find_object(x -> module -> decl, name, 1);
1471
1472 if(x -> export == 0)
1473 {
1474 oberon_error(ctx, "not exported");
1475 }
1476 }
1477 }
1478
1479 if(xname)
1480 {
1481 *xname = name;
1482 }
1483
1484 return x;
1485 }
1486
1487 static oberon_expr_t *
1488 oberon_ident_item(oberon_context_t * ctx, char * name)
1489 {
1490 bool read_only;
1491 oberon_object_t * x;
1492 oberon_expr_t * expr;
1493
1494 x = oberon_find_object(ctx -> decl, name, true);
1495
1496 read_only = false;
1497 if(x -> class == OBERON_CLASS_CONST || x -> class == OBERON_CLASS_PROC)
1498 {
1499 read_only = true;
1500 }
1501
1502 expr = oberon_new_item(MODE_VAR, x -> type, read_only);
1503 expr -> item.var = x;
1504 return expr;
1505 }
1506
1507 static oberon_expr_t *
1508 oberon_qualident_expr(oberon_context_t * ctx)
1509 {
1510 oberon_object_t * var;
1511 oberon_expr_t * expr;
1512
1513 var = oberon_qualident(ctx, NULL, 1);
1514
1515 int read_only = 0;
1516 if(var -> read_only)
1517 {
1518 if(var -> module != ctx -> mod)
1519 {
1520 read_only = 1;
1521 }
1522 }
1523
1524 switch(var -> class)
1525 {
1526 case OBERON_CLASS_CONST:
1527 // TODO copy value
1528 expr = (oberon_expr_t *) var -> value;
1529 break;
1530 case OBERON_CLASS_TYPE:
1531 expr = oberon_new_item(MODE_TYPE, var -> type, read_only);
1532 break;
1533 case OBERON_CLASS_VAR:
1534 case OBERON_CLASS_VAR_PARAM:
1535 case OBERON_CLASS_PARAM:
1536 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1537 break;
1538 case OBERON_CLASS_PROC:
1539 expr = oberon_new_item(MODE_VAR, var -> type, true);
1540 break;
1541 default:
1542 oberon_error(ctx, "invalid designator");
1543 break;
1544 }
1545
1546 expr -> item.var = var;
1547
1548 return expr;
1549 }
1550
1551 static oberon_expr_t *
1552 oberon_designator(oberon_context_t * ctx)
1553 {
1554 char * name;
1555 oberon_expr_t * expr;
1556
1557 expr = oberon_qualident_expr(ctx);
1558
1559 while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
1560 {
1561 switch(ctx -> token)
1562 {
1563 case DOT:
1564 oberon_assert_token(ctx, DOT);
1565 name = oberon_assert_ident(ctx);
1566 expr = oberon_make_record_selector(ctx, expr, name);
1567 break;
1568 case LBRACK:
1569 oberon_assert_token(ctx, LBRACK);
1570 int num_indexes = 0;
1571 oberon_expr_t * indexes = NULL;
1572 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1573 oberon_assert_token(ctx, RBRACK);
1574
1575 for(int i = 0; i < num_indexes; i++)
1576 {
1577 expr = oberon_make_array_selector(ctx, expr, indexes);
1578 indexes = indexes -> next;
1579 }
1580 break;
1581 case UPARROW:
1582 oberon_assert_token(ctx, UPARROW);
1583 expr = oberno_make_dereferencing(ctx, expr);
1584 break;
1585 case LPAREN:
1586 oberon_assert_token(ctx, LPAREN);
1587 oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1);
1588 if(objtype -> class != OBERON_CLASS_TYPE)
1589 {
1590 oberon_error(ctx, "must be type");
1591 }
1592 oberon_assert_token(ctx, RPAREN);
1593 expr = oberno_make_record_cast(ctx, expr, objtype -> type);
1594 break;
1595 default:
1596 oberon_error(ctx, "oberon_designator: wat");
1597 break;
1598 }
1599 }
1600
1601 return expr;
1602 }
1603
1604 static oberon_expr_t *
1605 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1606 {
1607 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1608 if(ctx -> token == LPAREN)
1609 {
1610 oberon_assert_token(ctx, LPAREN);
1611
1612 int num_args = 0;
1613 oberon_expr_t * arguments = NULL;
1614
1615 if(ISEXPR(ctx -> token))
1616 {
1617 oberon_expr_list(ctx, &num_args, &arguments, 0);
1618 }
1619
1620 assert(expr -> is_item == 1);
1621 expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
1622
1623 oberon_assert_token(ctx, RPAREN);
1624 }
1625
1626 return expr;
1627 }
1628
1629 static void
1630 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1631 {
1632 assert(expr -> is_item);
1633
1634 int num_args = 0;
1635 oberon_expr_t * arguments = NULL;
1636
1637 if(ctx -> token == LPAREN)
1638 {
1639 oberon_assert_token(ctx, LPAREN);
1640
1641 if(ISEXPR(ctx -> token))
1642 {
1643 oberon_expr_list(ctx, &num_args, &arguments, 0);
1644 }
1645
1646 oberon_assert_token(ctx, RPAREN);
1647 }
1648
1649 /* Вызов происходит даже без скобок */
1650 oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
1651 }
1652
1653 static oberon_type_t *
1654 oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i)
1655 {
1656 if(i >= -128 && i <= 127)
1657 {
1658 return ctx -> byte_type;
1659 }
1660 else if(i >= -32768 && i <= 32767)
1661 {
1662 return ctx -> shortint_type;
1663 }
1664 else if(i >= -2147483648 && i <= 2147483647)
1665 {
1666 return ctx -> int_type;
1667 }
1668 else
1669 {
1670 return ctx -> longint_type;
1671 }
1672 }
1673
1674 static oberon_expr_t *
1675 oberon_integer_item(oberon_context_t * ctx, int64_t i)
1676 {
1677 oberon_expr_t * expr;
1678 oberon_type_t * result;
1679 result = oberon_get_type_of_int_value(ctx, i);
1680 expr = oberon_new_item(MODE_INTEGER, result, true);
1681 expr -> item.integer = i;
1682 return expr;
1683 }
1684
1685 static oberon_expr_t *
1686 oberon_element(oberon_context_t * ctx)
1687 {
1688 oberon_expr_t * e1;
1689 oberon_expr_t * e2;
1690
1691 e1 = oberon_expr(ctx);
1692 if(e1 -> result -> class != OBERON_TYPE_INTEGER)
1693 {
1694 oberon_error(ctx, "expected integer");
1695 }
1696
1697 e2 = NULL;
1698 if(ctx -> token == DOTDOT)
1699 {
1700 oberon_assert_token(ctx, DOTDOT);
1701 e2 = oberon_expr(ctx);
1702 if(e2 -> result -> class != OBERON_TYPE_INTEGER)
1703 {
1704 oberon_error(ctx, "expected integer");
1705 }
1706 }
1707
1708 oberon_expr_t * set;
1709 set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2);
1710 return set;
1711 }
1712
1713 static oberon_expr_t *
1714 oberon_set(oberon_context_t * ctx)
1715 {
1716 oberon_expr_t * set;
1717 oberon_expr_t * elements;
1718 set = oberon_new_item(MODE_SET, ctx -> set_type, true);
1719 set -> item.integer = 0;
1720
1721 oberon_assert_token(ctx, LBRACE);
1722 if(ISEXPR(ctx -> token))
1723 {
1724 elements = oberon_element(ctx);
1725 set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements);
1726 while(ctx -> token == COMMA)
1727 {
1728 oberon_assert_token(ctx, COMMA);
1729 elements = oberon_element(ctx);
1730 set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements);
1731 }
1732 }
1733 oberon_assert_token(ctx, RBRACE);
1734
1735 return set;
1736 }
1737
1738 static oberon_expr_t *
1739 oberon_factor(oberon_context_t * ctx)
1740 {
1741 oberon_expr_t * expr;
1742 oberon_type_t * result;
1743
1744 switch(ctx -> token)
1745 {
1746 case IDENT:
1747 expr = oberon_designator(ctx);
1748 expr = oberon_opt_func_parens(ctx, expr);
1749 break;
1750 case INTEGER:
1751 expr = oberon_integer_item(ctx, ctx -> integer);
1752 oberon_assert_token(ctx, INTEGER);
1753 break;
1754 case CHAR:
1755 result = ctx -> char_type;
1756 expr = oberon_new_item(MODE_CHAR, result, true);
1757 expr -> item.integer = ctx -> integer;
1758 oberon_assert_token(ctx, CHAR);
1759 break;
1760 case STRING:
1761 result = ctx -> string_type;
1762 expr = oberon_new_item(MODE_STRING, result, true);
1763 expr -> item.string = ctx -> string;
1764 oberon_assert_token(ctx, STRING);
1765 break;
1766 case REAL:
1767 result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type);
1768 expr = oberon_new_item(MODE_REAL, result, 1);
1769 expr -> item.real = ctx -> real;
1770 oberon_assert_token(ctx, REAL);
1771 break;
1772 case TRUE:
1773 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1774 expr -> item.boolean = true;
1775 oberon_assert_token(ctx, TRUE);
1776 break;
1777 case FALSE:
1778 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1779 expr -> item.boolean = false;
1780 oberon_assert_token(ctx, FALSE);
1781 break;
1782 case LBRACE:
1783 expr = oberon_set(ctx);
1784 break;
1785 case LPAREN:
1786 oberon_assert_token(ctx, LPAREN);
1787 expr = oberon_expr(ctx);
1788 oberon_assert_token(ctx, RPAREN);
1789 break;
1790 case NOT:
1791 oberon_assert_token(ctx, NOT);
1792 expr = oberon_factor(ctx);
1793 expr = oberon_make_unary_op(ctx, NOT, expr);
1794 break;
1795 case NIL:
1796 oberon_assert_token(ctx, NIL);
1797 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, true);
1798 break;
1799 default:
1800 oberon_error(ctx, "invalid expression");
1801 }
1802
1803 return expr;
1804 }
1805
1806 #define ITMAKESBOOLEAN(x) \
1807 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1808
1809 #define ITUSEONLYINTEGER(x) \
1810 ((x) >= LESS && (x) <= GEQ)
1811
1812 #define ITUSEONLYBOOLEAN(x) \
1813 (((x) == OR) || ((x) == AND))
1814
1815 static void
1816 oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e)
1817 {
1818 oberon_expr_t * expr = *e;
1819 if(expr -> result -> class == OBERON_TYPE_INTEGER)
1820 {
1821 if(expr -> result -> size <= ctx -> real_type -> size)
1822 {
1823 *e = oberon_cast_expr(ctx, expr, ctx -> real_type);
1824 }
1825 else
1826 {
1827 *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type);
1828 }
1829 }
1830 else if(expr -> result -> class != OBERON_TYPE_REAL)
1831 {
1832 oberon_error(ctx, "required numeric type");
1833 }
1834 }
1835
1836 static oberon_expr_t *
1837 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1838 {
1839 oberon_expr_t * expr;
1840 oberon_type_t * result;
1841
1842 bool error = false;
1843 if(token == IN)
1844 {
1845 if(a -> result -> class != OBERON_TYPE_INTEGER)
1846 {
1847 oberon_error(ctx, "must be integer");
1848 }
1849
1850 if(b -> result -> class != OBERON_TYPE_SET)
1851 {
1852 oberon_error(ctx, "must be set");
1853 }
1854
1855 result = ctx -> bool_type;
1856 expr = oberon_new_operator(OP_IN, result, a, b);
1857 }
1858 else if(token == IS)
1859 {
1860 oberon_type_t * v = a -> result;
1861 if(v -> class == OBERON_TYPE_POINTER)
1862 {
1863 v = v -> base;
1864 if(v -> class != OBERON_TYPE_RECORD)
1865 {
1866 oberon_error(ctx, "must be record");
1867 }
1868 }
1869 else if(v -> class != OBERON_TYPE_RECORD)
1870 {
1871 oberon_error(ctx, "must be record");
1872 }
1873
1874 if(b -> is_item == false || b -> item.mode != MODE_TYPE)
1875 {
1876 oberon_error(ctx, "requires type");
1877 }
1878
1879 oberon_type_t * t = b -> result;
1880 if(t -> class == OBERON_TYPE_POINTER)
1881 {
1882 t = t -> base;
1883 if(t -> class != OBERON_TYPE_RECORD)
1884 {
1885 oberon_error(ctx, "must be record");
1886 }
1887 }
1888 else if(t -> class != OBERON_TYPE_RECORD)
1889 {
1890 oberon_error(ctx, "must be record");
1891 }
1892
1893 result = ctx -> bool_type;
1894 expr = oberon_new_operator(OP_IS, result, a, b);
1895 }
1896 else if(ITMAKESBOOLEAN(token))
1897 {
1898 if(ITUSEONLYINTEGER(token))
1899 {
1900 if(a -> result -> class == OBERON_TYPE_INTEGER
1901 || b -> result -> class == OBERON_TYPE_INTEGER
1902 || a -> result -> class == OBERON_TYPE_REAL
1903 || b -> result -> class == OBERON_TYPE_REAL)
1904 {
1905 // accept
1906 }
1907 else
1908 {
1909 oberon_error(ctx, "used only with numeric types");
1910 }
1911 }
1912 else if(ITUSEONLYBOOLEAN(token))
1913 {
1914 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1915 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1916 {
1917 oberon_error(ctx, "used only with boolean type");
1918 }
1919 }
1920
1921 oberon_autocast_binary_op(ctx, &a, &b);
1922 result = ctx -> bool_type;
1923
1924 if(token == EQUAL)
1925 {
1926 expr = oberon_new_operator(OP_EQ, result, a, b);
1927 }
1928 else if(token == NEQ)
1929 {
1930 expr = oberon_new_operator(OP_NEQ, result, a, b);
1931 }
1932 else if(token == LESS)
1933 {
1934 expr = oberon_new_operator(OP_LSS, result, a, b);
1935 }
1936 else if(token == LEQ)
1937 {
1938 expr = oberon_new_operator(OP_LEQ, result, a, b);
1939 }
1940 else if(token == GREAT)
1941 {
1942 expr = oberon_new_operator(OP_GRT, result, a, b);
1943 }
1944 else if(token == GEQ)
1945 {
1946 expr = oberon_new_operator(OP_GEQ, result, a, b);
1947 }
1948 else if(token == OR)
1949 {
1950 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1951 }
1952 else if(token == AND)
1953 {
1954 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1955 }
1956 else
1957 {
1958 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1959 }
1960 }
1961 else if(token == SLASH)
1962 {
1963 if(a -> result -> class == OBERON_TYPE_SET
1964 || b -> result -> class == OBERON_TYPE_SET)
1965 {
1966 oberon_autocast_binary_op(ctx, &a, &b);
1967 result = a -> result;
1968 expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b);
1969 }
1970 else
1971 {
1972 oberon_autocast_to_real(ctx, &a);
1973 oberon_autocast_to_real(ctx, &b);
1974 oberon_autocast_binary_op(ctx, &a, &b);
1975 result = a -> result;
1976 expr = oberon_new_operator(OP_DIV, result, a, b);
1977 }
1978 }
1979 else if(token == DIV)
1980 {
1981 if(a -> result -> class != OBERON_TYPE_INTEGER
1982 || b -> result -> class != OBERON_TYPE_INTEGER)
1983 {
1984 oberon_error(ctx, "operator DIV requires integer type");
1985 }
1986
1987 oberon_autocast_binary_op(ctx, &a, &b);
1988 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1989 }
1990 else
1991 {
1992 oberon_autocast_binary_op(ctx, &a, &b);
1993 result = a -> result;
1994 if(result -> class == OBERON_TYPE_SET)
1995 {
1996 switch(token)
1997 {
1998 case PLUS:
1999 expr = oberon_new_operator(OP_UNION, result, a, b);
2000 break;
2001 case MINUS:
2002 expr = oberon_new_operator(OP_DIFFERENCE, result, a, b);
2003 break;
2004 case STAR:
2005 expr = oberon_new_operator(OP_INTERSECTION, result, a, b);
2006 break;
2007 default:
2008 error = true;
2009 break;
2010 }
2011 }
2012 else if(result -> class == OBERON_TYPE_INTEGER
2013 || result -> class == OBERON_TYPE_REAL)
2014 {
2015 switch(token)
2016 {
2017 case PLUS:
2018 expr = oberon_new_operator(OP_ADD, result, a, b);
2019 break;
2020 case MINUS:
2021 expr = oberon_new_operator(OP_SUB, result, a, b);
2022 break;
2023 case STAR:
2024 expr = oberon_new_operator(OP_MUL, result, a, b);
2025 break;
2026 case MOD:
2027 expr = oberon_new_operator(OP_MOD, result, a, b);
2028 break;
2029 default:
2030 error = true;
2031 break;
2032 }
2033 }
2034 else
2035 {
2036 error = true;
2037 }
2038 }
2039
2040 if(error)
2041 {
2042 oberon_error(ctx, "invalid operation");
2043 }
2044
2045 return expr;
2046 }
2047
2048 #define ISMULOP(x) \
2049 ((x) >= STAR && (x) <= AND)
2050
2051 static oberon_expr_t *
2052 oberon_term_expr(oberon_context_t * ctx)
2053 {
2054 oberon_expr_t * expr;
2055
2056 expr = oberon_factor(ctx);
2057 while(ISMULOP(ctx -> token))
2058 {
2059 int token = ctx -> token;
2060 oberon_read_token(ctx);
2061
2062 oberon_expr_t * inter = oberon_factor(ctx);
2063 expr = oberon_make_bin_op(ctx, token, expr, inter);
2064 }
2065
2066 return expr;
2067 }
2068
2069 #define ISADDOP(x) \
2070 ((x) >= PLUS && (x) <= OR)
2071
2072 static oberon_expr_t *
2073 oberon_simple_expr(oberon_context_t * ctx)
2074 {
2075 oberon_expr_t * expr;
2076
2077 int minus = 0;
2078 if(ctx -> token == PLUS)
2079 {
2080 minus = 0;
2081 oberon_assert_token(ctx, PLUS);
2082 }
2083 else if(ctx -> token == MINUS)
2084 {
2085 minus = 1;
2086 oberon_assert_token(ctx, MINUS);
2087 }
2088
2089 expr = oberon_term_expr(ctx);
2090
2091 if(minus)
2092 {
2093 expr = oberon_make_unary_op(ctx, MINUS, expr);
2094 }
2095
2096 while(ISADDOP(ctx -> token))
2097 {
2098 int token = ctx -> token;
2099 oberon_read_token(ctx);
2100
2101 oberon_expr_t * inter = oberon_term_expr(ctx);
2102 expr = oberon_make_bin_op(ctx, token, expr, inter);
2103 }
2104
2105 return expr;
2106 }
2107
2108 #define ISRELATION(x) \
2109 ((x) >= EQUAL && (x) <= IS)
2110
2111 static oberon_expr_t *
2112 oberon_expr(oberon_context_t * ctx)
2113 {
2114 oberon_expr_t * expr;
2115
2116 expr = oberon_simple_expr(ctx);
2117 while(ISRELATION(ctx -> token))
2118 {
2119 int token = ctx -> token;
2120 oberon_read_token(ctx);
2121
2122 oberon_expr_t * inter = oberon_simple_expr(ctx);
2123 expr = oberon_make_bin_op(ctx, token, expr, inter);
2124 }
2125
2126 return expr;
2127 }
2128
2129 static oberon_item_t *
2130 oberon_const_expr(oberon_context_t * ctx)
2131 {
2132 oberon_expr_t * expr;
2133 expr = oberon_expr(ctx);
2134
2135 if(expr -> is_item == 0)
2136 {
2137 oberon_error(ctx, "const expression are required");
2138 }
2139
2140 switch(expr -> item.mode)
2141 {
2142 case MODE_INTEGER:
2143 case MODE_BOOLEAN:
2144 case MODE_NIL:
2145 case MODE_REAL:
2146 case MODE_CHAR:
2147 case MODE_STRING:
2148 case MODE_TYPE:
2149 /* accept */
2150 break;
2151 default:
2152 oberon_error(ctx, "const expression are required");
2153 break;
2154 }
2155
2156 return (oberon_item_t *) expr;
2157 }
2158
2159 // =======================================================================
2160 // PARSER
2161 // =======================================================================
2162
2163 static void oberon_decl_seq(oberon_context_t * ctx);
2164 static void oberon_statement_seq(oberon_context_t * ctx);
2165 static void oberon_initialize_decl(oberon_context_t * ctx);
2166
2167 static void
2168 oberon_expect_token(oberon_context_t * ctx, int token)
2169 {
2170 if(ctx -> token != token)
2171 {
2172 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
2173 }
2174 }
2175
2176 static void
2177 oberon_assert_token(oberon_context_t * ctx, int token)
2178 {
2179 oberon_expect_token(ctx, token);
2180 oberon_read_token(ctx);
2181 }
2182
2183 static char *
2184 oberon_assert_ident(oberon_context_t * ctx)
2185 {
2186 oberon_expect_token(ctx, IDENT);
2187 char * ident = ctx -> string;
2188 oberon_read_token(ctx);
2189 return ident;
2190 }
2191
2192 static void
2193 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
2194 {
2195 switch(ctx -> token)
2196 {
2197 case STAR:
2198 oberon_assert_token(ctx, STAR);
2199 *export = 1;
2200 *read_only = 0;
2201 break;
2202 case MINUS:
2203 oberon_assert_token(ctx, MINUS);
2204 *export = 1;
2205 *read_only = 1;
2206 break;
2207 default:
2208 *export = 0;
2209 *read_only = 0;
2210 break;
2211 }
2212 }
2213
2214 static oberon_object_t *
2215 oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
2216 {
2217 char * name;
2218 int export;
2219 int read_only;
2220 oberon_object_t * x;
2221
2222 name = oberon_assert_ident(ctx);
2223 oberon_def(ctx, &export, &read_only);
2224
2225 x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
2226 return x;
2227 }
2228
2229 static void
2230 oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
2231 {
2232 *num = 1;
2233 *list = oberon_ident_def(ctx, class, check_upscope);
2234 while(ctx -> token == COMMA)
2235 {
2236 oberon_assert_token(ctx, COMMA);
2237 oberon_ident_def(ctx, class, check_upscope);
2238 *num += 1;
2239 }
2240 }
2241
2242 static void
2243 oberon_var_decl(oberon_context_t * ctx)
2244 {
2245 int num;
2246 oberon_object_t * list;
2247 oberon_type_t * type;
2248 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2249
2250 oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
2251 oberon_assert_token(ctx, COLON);
2252 oberon_type(ctx, &type);
2253
2254 oberon_object_t * var = list;
2255 for(int i = 0; i < num; i++)
2256 {
2257 var -> type = type;
2258 var = var -> next;
2259 }
2260 }
2261
2262 static oberon_object_t *
2263 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
2264 {
2265 int class = OBERON_CLASS_PARAM;
2266 if(ctx -> token == VAR)
2267 {
2268 oberon_read_token(ctx);
2269 class = OBERON_CLASS_VAR_PARAM;
2270 }
2271
2272 int num;
2273 oberon_object_t * list;
2274 oberon_ident_list(ctx, class, false, &num, &list);
2275
2276 oberon_assert_token(ctx, COLON);
2277
2278 oberon_type_t * type;
2279 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2280 oberon_type(ctx, &type);
2281
2282 oberon_object_t * param = list;
2283 for(int i = 0; i < num; i++)
2284 {
2285 param -> type = type;
2286 param = param -> next;
2287 }
2288
2289 *num_decl += num;
2290 return list;
2291 }
2292
2293 #define ISFPSECTION \
2294 ((ctx -> token == VAR) || (ctx -> token == IDENT))
2295
2296 static void
2297 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
2298 {
2299 oberon_assert_token(ctx, LPAREN);
2300
2301 if(ISFPSECTION)
2302 {
2303 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
2304 while(ctx -> token == SEMICOLON)
2305 {
2306 oberon_assert_token(ctx, SEMICOLON);
2307 oberon_fp_section(ctx, &signature -> num_decl);
2308 }
2309 }
2310
2311 oberon_assert_token(ctx, RPAREN);
2312
2313 if(ctx -> token == COLON)
2314 {
2315 oberon_assert_token(ctx, COLON);
2316
2317 oberon_object_t * typeobj;
2318 typeobj = oberon_qualident(ctx, NULL, 1);
2319 if(typeobj -> class != OBERON_CLASS_TYPE)
2320 {
2321 oberon_error(ctx, "function result is not type");
2322 }
2323 signature -> base = typeobj -> type;
2324 }
2325 }
2326
2327 static void
2328 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
2329 {
2330 oberon_type_t * signature;
2331 signature = *type;
2332 signature -> class = OBERON_TYPE_PROCEDURE;
2333 signature -> num_decl = 0;
2334 signature -> base = ctx -> void_type;
2335 signature -> decl = NULL;
2336
2337 if(ctx -> token == LPAREN)
2338 {
2339 oberon_formal_pars(ctx, signature);
2340 }
2341 }
2342
2343 static void
2344 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
2345 {
2346 if(a -> num_decl != b -> num_decl)
2347 {
2348 oberon_error(ctx, "number parameters not matched");
2349 }
2350
2351 int num_param = a -> num_decl;
2352 oberon_object_t * param_a = a -> decl;
2353 oberon_object_t * param_b = b -> decl;
2354 for(int i = 0; i < num_param; i++)
2355 {
2356 if(strcmp(param_a -> name, param_b -> name) != 0)
2357 {
2358 oberon_error(ctx, "param %i name not matched", i + 1);
2359 }
2360
2361 if(param_a -> type != param_b -> type)
2362 {
2363 oberon_error(ctx, "param %i type not matched", i + 1);
2364 }
2365
2366 param_a = param_a -> next;
2367 param_b = param_b -> next;
2368 }
2369 }
2370
2371 static void
2372 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
2373 {
2374 oberon_object_t * proc = ctx -> decl -> parent;
2375 oberon_type_t * result_type = proc -> type -> base;
2376
2377 if(result_type -> class == OBERON_TYPE_VOID)
2378 {
2379 if(expr != NULL)
2380 {
2381 oberon_error(ctx, "procedure has no result type");
2382 }
2383 }
2384 else
2385 {
2386 if(expr == NULL)
2387 {
2388 oberon_error(ctx, "procedure requires expression on result");
2389 }
2390
2391 expr = oberon_autocast_to(ctx, expr, result_type);
2392 }
2393
2394 proc -> has_return = 1;
2395
2396 oberon_generate_return(ctx, expr);
2397 }
2398
2399 static void
2400 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
2401 {
2402 oberon_assert_token(ctx, SEMICOLON);
2403
2404 ctx -> decl = proc -> scope;
2405
2406 oberon_decl_seq(ctx);
2407
2408 oberon_generate_begin_proc(ctx, proc);
2409
2410 if(ctx -> token == BEGIN)
2411 {
2412 oberon_assert_token(ctx, BEGIN);
2413 oberon_statement_seq(ctx);
2414 }
2415
2416 oberon_assert_token(ctx, END);
2417 char * name = oberon_assert_ident(ctx);
2418 if(strcmp(name, proc -> name) != 0)
2419 {
2420 oberon_error(ctx, "procedure name not matched");
2421 }
2422
2423 if(proc -> type -> base -> class == OBERON_TYPE_VOID
2424 && proc -> has_return == 0)
2425 {
2426 oberon_make_return(ctx, NULL);
2427 }
2428
2429 if(proc -> has_return == 0)
2430 {
2431 oberon_error(ctx, "procedure requires return");
2432 }
2433
2434 oberon_generate_end_proc(ctx);
2435 oberon_close_scope(ctx -> decl);
2436 }
2437
2438 static void
2439 oberon_proc_decl(oberon_context_t * ctx)
2440 {
2441 oberon_assert_token(ctx, PROCEDURE);
2442
2443 int forward = 0;
2444 if(ctx -> token == UPARROW)
2445 {
2446 oberon_assert_token(ctx, UPARROW);
2447 forward = 1;
2448 }
2449
2450 char * name;
2451 int export;
2452 int read_only;
2453 name = oberon_assert_ident(ctx);
2454 oberon_def(ctx, &export, &read_only);
2455
2456 oberon_scope_t * proc_scope;
2457 proc_scope = oberon_open_scope(ctx);
2458 ctx -> decl -> local = 1;
2459
2460 oberon_type_t * signature;
2461 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
2462 oberon_opt_formal_pars(ctx, &signature);
2463
2464 oberon_initialize_decl(ctx);
2465 oberon_generator_init_type(ctx, signature);
2466 oberon_close_scope(ctx -> decl);
2467
2468 oberon_object_t * proc;
2469 proc = oberon_find_object(ctx -> decl, name, 0);
2470 if(proc != NULL)
2471 {
2472 if(proc -> class != OBERON_CLASS_PROC)
2473 {
2474 oberon_error(ctx, "mult definition");
2475 }
2476
2477 if(forward == 0)
2478 {
2479 if(proc -> linked)
2480 {
2481 oberon_error(ctx, "mult procedure definition");
2482 }
2483 }
2484
2485 if(proc -> export != export || proc -> read_only != read_only)
2486 {
2487 oberon_error(ctx, "export type not matched");
2488 }
2489
2490 oberon_compare_signatures(ctx, proc -> type, signature);
2491 }
2492 else
2493 {
2494 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
2495 proc -> type = signature;
2496 proc -> scope = proc_scope;
2497 oberon_generator_init_proc(ctx, proc);
2498 }
2499
2500 proc -> scope -> parent = proc;
2501
2502 if(forward == 0)
2503 {
2504 proc -> linked = 1;
2505 oberon_proc_decl_body(ctx, proc);
2506 }
2507 }
2508
2509 static void
2510 oberon_const_decl(oberon_context_t * ctx)
2511 {
2512 oberon_item_t * value;
2513 oberon_object_t * constant;
2514
2515 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
2516 oberon_assert_token(ctx, EQUAL);
2517 value = oberon_const_expr(ctx);
2518 constant -> value = value;
2519 }
2520
2521 static void
2522 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
2523 {
2524 if(size -> is_item == 0)
2525 {
2526 oberon_error(ctx, "requires constant");
2527 }
2528
2529 if(size -> item.mode != MODE_INTEGER)
2530 {
2531 oberon_error(ctx, "requires integer constant");
2532 }
2533
2534 oberon_type_t * arr;
2535 arr = *type;
2536 arr -> class = OBERON_TYPE_ARRAY;
2537 arr -> size = size -> item.integer;
2538 arr -> base = base;
2539 }
2540
2541 static void
2542 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2543 {
2544 char * name;
2545 oberon_object_t * to;
2546
2547 to = oberon_qualident(ctx, &name, 0);
2548
2549 //name = oberon_assert_ident(ctx);
2550 //to = oberon_find_object(ctx -> decl, name, 0);
2551
2552 if(to != NULL)
2553 {
2554 if(to -> class != OBERON_CLASS_TYPE)
2555 {
2556 oberon_error(ctx, "not a type");
2557 }
2558 }
2559 else
2560 {
2561 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2562 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2563 }
2564
2565 *type = to -> type;
2566 }
2567
2568 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2569
2570 /*
2571 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2572 */
2573
2574 static void
2575 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2576 {
2577 if(sizes == NULL)
2578 {
2579 *type = base;
2580 return;
2581 }
2582
2583 oberon_type_t * dim;
2584 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2585
2586 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2587
2588 oberon_make_array_type(ctx, sizes, dim, type);
2589 }
2590
2591 static void
2592 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2593 {
2594 type -> class = OBERON_TYPE_ARRAY;
2595 type -> size = 0;
2596 type -> base = base;
2597 }
2598
2599 static void
2600 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2601 {
2602 if(ctx -> token == IDENT)
2603 {
2604 int num;
2605 oberon_object_t * list;
2606 oberon_type_t * type;
2607 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2608
2609 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2610 oberon_assert_token(ctx, COLON);
2611
2612 oberon_scope_t * current = ctx -> decl;
2613 ctx -> decl = modscope;
2614 oberon_type(ctx, &type);
2615 ctx -> decl = current;
2616
2617 oberon_object_t * field = list;
2618 for(int i = 0; i < num; i++)
2619 {
2620 field -> type = type;
2621 field = field -> next;
2622 }
2623
2624 rec -> num_decl += num;
2625 }
2626 }
2627
2628 static void
2629 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2630 {
2631 oberon_scope_t * modscope = ctx -> mod -> decl;
2632 oberon_scope_t * oldscope = ctx -> decl;
2633 ctx -> decl = modscope;
2634
2635 if(ctx -> token == LPAREN)
2636 {
2637 oberon_assert_token(ctx, LPAREN);
2638
2639 oberon_object_t * typeobj;
2640 typeobj = oberon_qualident(ctx, NULL, true);
2641
2642 if(typeobj -> class != OBERON_CLASS_TYPE)
2643 {
2644 oberon_error(ctx, "base must be type");
2645 }
2646
2647 oberon_type_t * base = typeobj -> type;
2648 if(base -> class == OBERON_TYPE_POINTER)
2649 {
2650 base = base -> base;
2651 }
2652
2653 if(base -> class != OBERON_TYPE_RECORD)
2654 {
2655 oberon_error(ctx, "base must be record type");
2656 }
2657
2658 rec -> base = base;
2659 ctx -> decl = base -> scope;
2660
2661 oberon_assert_token(ctx, RPAREN);
2662 }
2663 else
2664 {
2665 ctx -> decl = NULL;
2666 }
2667
2668 oberon_scope_t * this_scope;
2669 this_scope = oberon_open_scope(ctx);
2670 this_scope -> local = true;
2671 this_scope -> parent = NULL;
2672 this_scope -> parent_type = rec;
2673
2674 oberon_field_list(ctx, rec, modscope);
2675 while(ctx -> token == SEMICOLON)
2676 {
2677 oberon_assert_token(ctx, SEMICOLON);
2678 oberon_field_list(ctx, rec, modscope);
2679 }
2680
2681 rec -> scope = this_scope;
2682 rec -> decl = this_scope -> list -> next;
2683 ctx -> decl = oldscope;
2684 }
2685
2686 static void
2687 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2688 {
2689 if(ctx -> token == IDENT)
2690 {
2691 oberon_qualident_type(ctx, type);
2692 }
2693 else if(ctx -> token == ARRAY)
2694 {
2695 oberon_assert_token(ctx, ARRAY);
2696
2697 int num_sizes = 0;
2698 oberon_expr_t * sizes;
2699
2700 if(ISEXPR(ctx -> token))
2701 {
2702 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2703 }
2704
2705 oberon_assert_token(ctx, OF);
2706
2707 oberon_type_t * base;
2708 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2709 oberon_type(ctx, &base);
2710
2711 if(num_sizes == 0)
2712 {
2713 oberon_make_open_array(ctx, base, *type);
2714 }
2715 else
2716 {
2717 oberon_make_multiarray(ctx, sizes, base, type);
2718 }
2719 }
2720 else if(ctx -> token == RECORD)
2721 {
2722 oberon_type_t * rec;
2723 rec = *type;
2724 rec -> class = OBERON_TYPE_RECORD;
2725 rec -> module = ctx -> mod;
2726
2727 oberon_assert_token(ctx, RECORD);
2728 oberon_type_record_body(ctx, rec);
2729 oberon_assert_token(ctx, END);
2730
2731 *type = rec;
2732 }
2733 else if(ctx -> token == POINTER)
2734 {
2735 oberon_assert_token(ctx, POINTER);
2736 oberon_assert_token(ctx, TO);
2737
2738 oberon_type_t * base;
2739 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2740 oberon_type(ctx, &base);
2741
2742 oberon_type_t * ptr;
2743 ptr = *type;
2744 ptr -> class = OBERON_TYPE_POINTER;
2745 ptr -> base = base;
2746 }
2747 else if(ctx -> token == PROCEDURE)
2748 {
2749 oberon_open_scope(ctx);
2750 oberon_assert_token(ctx, PROCEDURE);
2751 oberon_opt_formal_pars(ctx, type);
2752 oberon_close_scope(ctx -> decl);
2753 }
2754 else
2755 {
2756 oberon_error(ctx, "invalid type declaration");
2757 }
2758 }
2759
2760 static void
2761 oberon_type_decl(oberon_context_t * ctx)
2762 {
2763 char * name;
2764 oberon_object_t * newtype;
2765 oberon_type_t * type;
2766 int export;
2767 int read_only;
2768
2769 name = oberon_assert_ident(ctx);
2770 oberon_def(ctx, &export, &read_only);
2771
2772 newtype = oberon_find_object(ctx -> decl, name, 0);
2773 if(newtype == NULL)
2774 {
2775 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2776 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2777 assert(newtype -> type);
2778 }
2779 else
2780 {
2781 if(newtype -> class != OBERON_CLASS_TYPE)
2782 {
2783 oberon_error(ctx, "mult definition");
2784 }
2785
2786 if(newtype -> linked)
2787 {
2788 oberon_error(ctx, "mult definition - already linked");
2789 }
2790
2791 newtype -> export = export;
2792 newtype -> read_only = read_only;
2793 }
2794
2795 oberon_assert_token(ctx, EQUAL);
2796
2797 type = newtype -> type;
2798 oberon_type(ctx, &type);
2799
2800 if(type -> class == OBERON_TYPE_VOID)
2801 {
2802 oberon_error(ctx, "recursive alias declaration");
2803 }
2804
2805 newtype -> type = type;
2806 newtype -> linked = 1;
2807 }
2808
2809 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2810 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2811
2812 static void
2813 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2814 {
2815 if(type -> class != OBERON_TYPE_POINTER
2816 && type -> class != OBERON_TYPE_ARRAY)
2817 {
2818 return;
2819 }
2820
2821 if(type -> recursive)
2822 {
2823 oberon_error(ctx, "recursive pointer declaration");
2824 }
2825
2826 if(type -> class == OBERON_TYPE_POINTER
2827 && type -> base -> class == OBERON_TYPE_POINTER)
2828 {
2829 oberon_error(ctx, "attempt to make pointer to pointer");
2830 }
2831
2832 type -> recursive = 1;
2833
2834 oberon_prevent_recursive_pointer(ctx, type -> base);
2835
2836 type -> recursive = 0;
2837 }
2838
2839 static void
2840 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2841 {
2842 if(type -> class != OBERON_TYPE_RECORD)
2843 {
2844 return;
2845 }
2846
2847 if(type -> recursive)
2848 {
2849 oberon_error(ctx, "recursive record declaration");
2850 }
2851
2852 type -> recursive = 1;
2853
2854 int num_fields = type -> num_decl;
2855 oberon_object_t * field = type -> decl;
2856 for(int i = 0; i < num_fields; i++)
2857 {
2858 oberon_prevent_recursive_object(ctx, field);
2859 field = field -> next;
2860 }
2861
2862 type -> recursive = 0;
2863 }
2864 static void
2865 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2866 {
2867 if(type -> class != OBERON_TYPE_PROCEDURE)
2868 {
2869 return;
2870 }
2871
2872 if(type -> recursive)
2873 {
2874 oberon_error(ctx, "recursive procedure declaration");
2875 }
2876
2877 type -> recursive = 1;
2878
2879 int num_fields = type -> num_decl;
2880 oberon_object_t * field = type -> decl;
2881 for(int i = 0; i < num_fields; i++)
2882 {
2883 oberon_prevent_recursive_object(ctx, field);
2884 field = field -> next;
2885 }
2886
2887 type -> recursive = 0;
2888 }
2889
2890 static void
2891 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2892 {
2893 if(type -> class != OBERON_TYPE_ARRAY)
2894 {
2895 return;
2896 }
2897
2898 if(type -> recursive)
2899 {
2900 oberon_error(ctx, "recursive array declaration");
2901 }
2902
2903 type -> recursive = 1;
2904
2905 oberon_prevent_recursive_type(ctx, type -> base);
2906
2907 type -> recursive = 0;
2908 }
2909
2910 static void
2911 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2912 {
2913 if(type -> class == OBERON_TYPE_POINTER)
2914 {
2915 oberon_prevent_recursive_pointer(ctx, type);
2916 }
2917 else if(type -> class == OBERON_TYPE_RECORD)
2918 {
2919 oberon_prevent_recursive_record(ctx, type);
2920 }
2921 else if(type -> class == OBERON_TYPE_ARRAY)
2922 {
2923 oberon_prevent_recursive_array(ctx, type);
2924 }
2925 else if(type -> class == OBERON_TYPE_PROCEDURE)
2926 {
2927 oberon_prevent_recursive_procedure(ctx, type);
2928 }
2929 }
2930
2931 static void
2932 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2933 {
2934 switch(x -> class)
2935 {
2936 case OBERON_CLASS_VAR:
2937 case OBERON_CLASS_TYPE:
2938 case OBERON_CLASS_PARAM:
2939 case OBERON_CLASS_VAR_PARAM:
2940 case OBERON_CLASS_FIELD:
2941 oberon_prevent_recursive_type(ctx, x -> type);
2942 break;
2943 case OBERON_CLASS_CONST:
2944 case OBERON_CLASS_PROC:
2945 case OBERON_CLASS_MODULE:
2946 break;
2947 default:
2948 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2949 break;
2950 }
2951 }
2952
2953 static void
2954 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2955 {
2956 oberon_object_t * x = ctx -> decl -> list -> next;
2957
2958 while(x)
2959 {
2960 oberon_prevent_recursive_object(ctx, x);
2961 x = x -> next;
2962 }
2963 }
2964
2965 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2966 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2967
2968 static void
2969 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2970 {
2971 if(type -> class != OBERON_TYPE_RECORD)
2972 {
2973 return;
2974 }
2975
2976 int num_fields = type -> num_decl;
2977 oberon_object_t * field = type -> decl;
2978 for(int i = 0; i < num_fields; i++)
2979 {
2980 if(field -> type -> class == OBERON_TYPE_POINTER)
2981 {
2982 oberon_initialize_type(ctx, field -> type);
2983 }
2984
2985 oberon_initialize_object(ctx, field);
2986 field = field -> next;
2987 }
2988
2989 oberon_generator_init_record(ctx, type);
2990 }
2991
2992 static void
2993 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2994 {
2995 if(type -> class == OBERON_TYPE_VOID)
2996 {
2997 oberon_error(ctx, "undeclarated type");
2998 }
2999
3000 if(type -> initialized)
3001 {
3002 return;
3003 }
3004
3005 type -> initialized = 1;
3006
3007 if(type -> class == OBERON_TYPE_POINTER)
3008 {
3009 oberon_initialize_type(ctx, type -> base);
3010 oberon_generator_init_type(ctx, type);
3011 }
3012 else if(type -> class == OBERON_TYPE_ARRAY)
3013 {
3014 if(type -> size != 0)
3015 {
3016 if(type -> base -> class == OBERON_TYPE_ARRAY)
3017 {
3018 if(type -> base -> size == 0)
3019 {
3020 oberon_error(ctx, "open array not allowed as array element");
3021 }
3022 }
3023 }
3024
3025 oberon_initialize_type(ctx, type -> base);
3026 oberon_generator_init_type(ctx, type);
3027 }
3028 else if(type -> class == OBERON_TYPE_RECORD)
3029 {
3030 oberon_generator_init_type(ctx, type);
3031 oberon_initialize_record_fields(ctx, type);
3032 }
3033 else if(type -> class == OBERON_TYPE_PROCEDURE)
3034 {
3035 int num_fields = type -> num_decl;
3036 oberon_object_t * field = type -> decl;
3037 for(int i = 0; i < num_fields; i++)
3038 {
3039 oberon_initialize_object(ctx, field);
3040 field = field -> next;
3041 }
3042
3043 oberon_generator_init_type(ctx, type);
3044 }
3045 else
3046 {
3047 oberon_generator_init_type(ctx, type);
3048 }
3049 }
3050
3051 static void
3052 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
3053 {
3054 if(x -> initialized)
3055 {
3056 return;
3057 }
3058
3059 x -> initialized = 1;
3060
3061 switch(x -> class)
3062 {
3063 case OBERON_CLASS_TYPE:
3064 oberon_initialize_type(ctx, x -> type);
3065 break;
3066 case OBERON_CLASS_VAR:
3067 case OBERON_CLASS_FIELD:
3068 if(x -> type -> class == OBERON_TYPE_ARRAY)
3069 {
3070 if(x -> type -> size == 0)
3071 {
3072 oberon_error(ctx, "open array not allowed as variable or field");
3073 }
3074 }
3075 oberon_initialize_type(ctx, x -> type);
3076 oberon_generator_init_var(ctx, x);
3077 break;
3078 case OBERON_CLASS_PARAM:
3079 case OBERON_CLASS_VAR_PARAM:
3080 oberon_initialize_type(ctx, x -> type);
3081 oberon_generator_init_var(ctx, x);
3082 break;
3083 case OBERON_CLASS_CONST:
3084 case OBERON_CLASS_PROC:
3085 case OBERON_CLASS_MODULE:
3086 break;
3087 default:
3088 oberon_error(ctx, "oberon_initialize_object: wat");
3089 break;
3090 }
3091 }
3092
3093 static void
3094 oberon_initialize_decl(oberon_context_t * ctx)
3095 {
3096 oberon_object_t * x = ctx -> decl -> list;
3097
3098 while(x -> next)
3099 {
3100 oberon_initialize_object(ctx, x -> next);
3101 x = x -> next;
3102 }
3103 }
3104
3105 static void
3106 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
3107 {
3108 oberon_object_t * x = ctx -> decl -> list;
3109
3110 while(x -> next)
3111 {
3112 if(x -> next -> class == OBERON_CLASS_PROC)
3113 {
3114 if(x -> next -> linked == 0)
3115 {
3116 oberon_error(ctx, "unresolved forward declaration");
3117 }
3118 }
3119 x = x -> next;
3120 }
3121 }
3122
3123 static void
3124 oberon_decl_seq(oberon_context_t * ctx)
3125 {
3126 if(ctx -> token == CONST)
3127 {
3128 oberon_assert_token(ctx, CONST);
3129 while(ctx -> token == IDENT)
3130 {
3131 oberon_const_decl(ctx);
3132 oberon_assert_token(ctx, SEMICOLON);
3133 }
3134 }
3135
3136 if(ctx -> token == TYPE)
3137 {
3138 oberon_assert_token(ctx, TYPE);
3139 while(ctx -> token == IDENT)
3140 {
3141 oberon_type_decl(ctx);
3142 oberon_assert_token(ctx, SEMICOLON);
3143 }
3144 }
3145
3146 if(ctx -> token == VAR)
3147 {
3148 oberon_assert_token(ctx, VAR);
3149 while(ctx -> token == IDENT)
3150 {
3151 oberon_var_decl(ctx);
3152 oberon_assert_token(ctx, SEMICOLON);
3153 }
3154 }
3155
3156 oberon_prevent_recursive_decl(ctx);
3157 oberon_initialize_decl(ctx);
3158
3159 while(ctx -> token == PROCEDURE)
3160 {
3161 oberon_proc_decl(ctx);
3162 oberon_assert_token(ctx, SEMICOLON);
3163 }
3164
3165 oberon_prevent_undeclarated_procedures(ctx);
3166 }
3167
3168 static oberon_expr_t *
3169 oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type)
3170 {
3171 oberon_object_t * x;
3172 oberon_expr_t * expr;
3173
3174 x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false);
3175 x -> local = true;
3176 x -> type = type;
3177 oberon_generator_init_temp_var(ctx, x);
3178
3179 expr = oberon_new_item(MODE_VAR, type, false);
3180 expr -> item.var = x;
3181 return expr;
3182 }
3183
3184 static void
3185 oberon_statement_seq(oberon_context_t * ctx);
3186
3187 static void
3188 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
3189 {
3190 if(dst -> read_only)
3191 {
3192 oberon_error(ctx, "read-only destination");
3193 }
3194
3195 oberon_check_dst(ctx, dst);
3196 src = oberon_autocast_to(ctx, src, dst -> result);
3197 oberon_generate_assign(ctx, src, dst);
3198 }
3199
3200 static oberon_expr_t *
3201 oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val)
3202 {
3203 oberon_expr_t * e1;
3204 oberon_expr_t * e2;
3205 oberon_expr_t * cond;
3206 oberon_expr_t * cond2;
3207
3208 e1 = (oberon_expr_t *) oberon_const_expr(ctx);
3209 oberon_autocast_to(ctx, e1, val -> result);
3210
3211 e2 = NULL;
3212 if(ctx -> token == DOTDOT)
3213 {
3214 oberon_assert_token(ctx, DOTDOT);
3215 e2 = (oberon_expr_t *) oberon_const_expr(ctx);
3216 oberon_autocast_to(ctx, e2, val -> result);
3217 }
3218
3219 if(e2 == NULL)
3220 {
3221 /* val == e1 */
3222 cond = oberon_make_bin_op(ctx, EQUAL, val, e1);
3223 }
3224 else
3225 {
3226 /* val >= e1 && val <= e2 */
3227 cond = oberon_make_bin_op(ctx, GEQ, val, e1);
3228 cond2 = oberon_make_bin_op(ctx, LEQ, val, e2);
3229 cond = oberon_make_bin_op(ctx, AND, cond, cond2);
3230 }
3231
3232 return cond;
3233 }
3234
3235 static void
3236 oberon_case(oberon_context_t * ctx, oberon_expr_t * val, gen_label_t * end)
3237 {
3238 oberon_expr_t * cond;
3239 oberon_expr_t * cond2;
3240 gen_label_t * this_end;
3241
3242 if(ISEXPR(ctx -> token))
3243 {
3244 this_end = oberon_generator_reserve_label(ctx);
3245
3246 cond = oberon_case_labels(ctx, val);
3247 while(ctx -> token == COMMA)
3248 {
3249 oberon_assert_token(ctx, COMMA);
3250 /* cond || cond2 */
3251 cond2 = oberon_case_labels(ctx, val);
3252 cond = oberon_make_bin_op(ctx, OR, cond, cond2);
3253 }
3254 oberon_assert_token(ctx, COLON);
3255
3256 oberon_generate_branch(ctx, cond, false, this_end);
3257 oberon_statement_seq(ctx);
3258 oberon_generate_goto(ctx, end);
3259
3260 oberon_generate_label(ctx, this_end);
3261 }
3262 }
3263
3264 static void
3265 oberon_case_statement(oberon_context_t * ctx)
3266 {
3267 oberon_expr_t * val;
3268 oberon_expr_t * expr;
3269 gen_label_t * end;
3270
3271 end = oberon_generator_reserve_label(ctx);
3272
3273 oberon_assert_token(ctx, CASE);
3274 expr = oberon_expr(ctx);
3275 val = oberon_make_temp_var_item(ctx, expr -> result);
3276 oberon_assign(ctx, expr, val);
3277 oberon_assert_token(ctx, OF);
3278 oberon_case(ctx, val, end);
3279 while(ctx -> token == BAR)
3280 {
3281 oberon_assert_token(ctx, BAR);
3282 oberon_case(ctx, val, end);
3283 }
3284
3285 if(ctx -> token == ELSE)
3286 {
3287 oberon_assert_token(ctx, ELSE);
3288 oberon_statement_seq(ctx);
3289 }
3290
3291 oberon_generate_label(ctx, end);
3292 oberon_assert_token(ctx, END);
3293 }
3294
3295 static void
3296 oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end)
3297 {
3298 oberon_expr_t * val;
3299 oberon_expr_t * var;
3300 oberon_expr_t * type;
3301 oberon_expr_t * cond;
3302 oberon_expr_t * cast;
3303 oberon_type_t * old_type;
3304 gen_var_t * old_var;
3305 gen_label_t * this_end;
3306
3307 this_end = oberon_generator_reserve_label(ctx);
3308
3309 var = oberon_qualident_expr(ctx);
3310 oberon_assert_token(ctx, COLON);
3311 type = oberon_qualident_expr(ctx);
3312 cond = oberon_make_bin_op(ctx, IS, var, type);
3313
3314 oberon_assert_token(ctx, DO);
3315 oberon_generate_branch(ctx, cond, false, this_end);
3316
3317 /* Сохраняем ссылку во временной переменной */
3318 val = oberon_make_temp_var_item(ctx, type -> result);
3319 cast = oberno_make_record_cast(ctx, var, type -> result);
3320 oberon_assign(ctx, cast, val);
3321 /* Подменяем тип у оригинальной переменной */
3322 old_type = var -> item.var -> type;
3323 var -> item.var -> type = type -> result;
3324 /* Подменяем ссылку на переменную */
3325 old_var = var -> item.var -> gen_var;
3326 var -> item.var -> gen_var = val -> item.var -> gen_var;
3327
3328 oberon_statement_seq(ctx);
3329 oberon_generate_goto(ctx, end);
3330 oberon_generate_label(ctx, this_end);
3331
3332 /* Возвращаем исходное состояние */
3333 var -> item.var -> gen_var = old_var;
3334 var -> item.var -> type = old_type;
3335 }
3336
3337 static void
3338 oberon_with_statement(oberon_context_t * ctx)
3339 {
3340 gen_label_t * end;
3341 end = oberon_generator_reserve_label(ctx);
3342
3343 oberon_assert_token(ctx, WITH);
3344 oberon_with_guard_do(ctx, end);
3345 while(ctx -> token == BAR)
3346 {
3347 oberon_assert_token(ctx, BAR);
3348 oberon_with_guard_do(ctx, end);
3349 }
3350
3351 if(ctx -> token == ELSE)
3352 {
3353 oberon_assert_token(ctx, ELSE);
3354 oberon_statement_seq(ctx);
3355 }
3356
3357 oberon_generate_label(ctx, end);
3358 oberon_assert_token(ctx, END);
3359 }
3360
3361 static void
3362 oberon_statement(oberon_context_t * ctx)
3363 {
3364 oberon_expr_t * item1;
3365 oberon_expr_t * item2;
3366
3367 if(ctx -> token == IDENT)
3368 {
3369 item1 = oberon_designator(ctx);
3370 if(ctx -> token == ASSIGN)
3371 {
3372 oberon_assert_token(ctx, ASSIGN);
3373 item2 = oberon_expr(ctx);
3374 oberon_assign(ctx, item2, item1);
3375 }
3376 else
3377 {
3378 oberon_opt_proc_parens(ctx, item1);
3379 }
3380 }
3381 else if(ctx -> token == IF)
3382 {
3383 gen_label_t * end;
3384 gen_label_t * els;
3385 oberon_expr_t * cond;
3386
3387 els = oberon_generator_reserve_label(ctx);
3388 end = oberon_generator_reserve_label(ctx);
3389
3390 oberon_assert_token(ctx, IF);
3391 cond = oberon_expr(ctx);
3392 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3393 {
3394 oberon_error(ctx, "condition must be boolean");
3395 }
3396 oberon_assert_token(ctx, THEN);
3397 oberon_generate_branch(ctx, cond, false, els);
3398 oberon_statement_seq(ctx);
3399 oberon_generate_goto(ctx, end);
3400 oberon_generate_label(ctx, els);
3401
3402 while(ctx -> token == ELSIF)
3403 {
3404 els = oberon_generator_reserve_label(ctx);
3405
3406 oberon_assert_token(ctx, ELSIF);
3407 cond = oberon_expr(ctx);
3408 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3409 {
3410 oberon_error(ctx, "condition must be boolean");
3411 }
3412 oberon_assert_token(ctx, THEN);
3413 oberon_generate_branch(ctx, cond, false, els);
3414 oberon_statement_seq(ctx);
3415 oberon_generate_goto(ctx, end);
3416 oberon_generate_label(ctx, els);
3417 }
3418
3419 if(ctx -> token == ELSE)
3420 {
3421 oberon_assert_token(ctx, ELSE);
3422 oberon_statement_seq(ctx);
3423 }
3424
3425 oberon_generate_label(ctx, end);
3426 oberon_assert_token(ctx, END);
3427 }
3428 else if(ctx -> token == WHILE)
3429 {
3430 gen_label_t * begin;
3431 gen_label_t * end;
3432 oberon_expr_t * cond;
3433
3434 begin = oberon_generator_reserve_label(ctx);
3435 end = oberon_generator_reserve_label(ctx);
3436
3437 oberon_assert_token(ctx, WHILE);
3438 oberon_generate_label(ctx, begin);
3439 cond = oberon_expr(ctx);
3440 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3441 {
3442 oberon_error(ctx, "condition must be boolean");
3443 }
3444 oberon_generate_branch(ctx, cond, false, end);
3445
3446 oberon_assert_token(ctx, DO);
3447 oberon_statement_seq(ctx);
3448 oberon_generate_goto(ctx, begin);
3449
3450 oberon_assert_token(ctx, END);
3451 oberon_generate_label(ctx, end);
3452 }
3453 else if(ctx -> token == REPEAT)
3454 {
3455 gen_label_t * begin;
3456 oberon_expr_t * cond;
3457
3458 begin = oberon_generator_reserve_label(ctx);
3459 oberon_generate_label(ctx, begin);
3460 oberon_assert_token(ctx, REPEAT);
3461
3462 oberon_statement_seq(ctx);
3463
3464 oberon_assert_token(ctx, UNTIL);
3465
3466 cond = oberon_expr(ctx);
3467 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3468 {
3469 oberon_error(ctx, "condition must be boolean");
3470 }
3471
3472 oberon_generate_branch(ctx, cond, true, begin);
3473 }
3474 else if(ctx -> token == FOR)
3475 {
3476 oberon_expr_t * from;
3477 oberon_expr_t * index;
3478 oberon_expr_t * to;
3479 oberon_expr_t * bound;
3480 oberon_expr_t * by;
3481 oberon_expr_t * cond;
3482 oberon_expr_t * count;
3483 gen_label_t * begin;
3484 gen_label_t * end;
3485 char * iname;
3486 int op;
3487
3488 begin = oberon_generator_reserve_label(ctx);
3489 end = oberon_generator_reserve_label(ctx);
3490
3491 oberon_assert_token(ctx, FOR);
3492 iname = oberon_assert_ident(ctx);
3493 index = oberon_ident_item(ctx, iname);
3494 oberon_assert_token(ctx, ASSIGN);
3495 from = oberon_expr(ctx);
3496 oberon_assign(ctx, from, index);
3497 oberon_assert_token(ctx, TO);
3498 bound = oberon_make_temp_var_item(ctx, index -> result);
3499 to = oberon_expr(ctx);
3500 oberon_assign(ctx, to, bound);
3501 if(ctx -> token == BY)
3502 {
3503 oberon_assert_token(ctx, BY);
3504 by = (oberon_expr_t *) oberon_const_expr(ctx);
3505 }
3506 else
3507 {
3508 by = oberon_integer_item(ctx, 1);
3509 }
3510
3511 if(by -> result -> class != OBERON_TYPE_INTEGER)
3512 {
3513 oberon_error(ctx, "must be integer");
3514 }
3515
3516 if(by -> item.integer > 0)
3517 {
3518 op = LEQ;
3519 }
3520 else if(by -> item.integer < 0)
3521 {
3522 op = GEQ;
3523 }
3524 else
3525 {
3526 oberon_error(ctx, "zero step not allowed");
3527 }
3528
3529 oberon_assert_token(ctx, DO);
3530 oberon_generate_label(ctx, begin);
3531 cond = oberon_make_bin_op(ctx, op, index, bound);
3532 oberon_generate_branch(ctx, cond, false, end);
3533 oberon_statement_seq(ctx);
3534 count = oberon_make_bin_op(ctx, PLUS, index, by);
3535 oberon_assign(ctx, count, index);
3536 oberon_generate_goto(ctx, begin);
3537 oberon_generate_label(ctx, end);
3538 oberon_assert_token(ctx, END);
3539 }
3540 else if(ctx -> token == LOOP)
3541 {
3542 gen_label_t * begin;
3543 gen_label_t * end;
3544
3545 begin = oberon_generator_reserve_label(ctx);
3546 end = oberon_generator_reserve_label(ctx);
3547
3548 oberon_open_scope(ctx);
3549 oberon_assert_token(ctx, LOOP);
3550 oberon_generate_label(ctx, begin);
3551 ctx -> decl -> exit_label = end;
3552 oberon_statement_seq(ctx);
3553 oberon_generate_goto(ctx, begin);
3554 oberon_generate_label(ctx, end);
3555 oberon_assert_token(ctx, END);
3556 oberon_close_scope(ctx -> decl);
3557 }
3558 else if(ctx -> token == EXIT)
3559 {
3560 oberon_assert_token(ctx, EXIT);
3561 if(ctx -> decl -> exit_label == NULL)
3562 {
3563 oberon_error(ctx, "not in LOOP-END");
3564 }
3565 oberon_generate_goto(ctx, ctx -> decl -> exit_label);
3566 }
3567 else if(ctx -> token == CASE)
3568 {
3569 oberon_case_statement(ctx);
3570 }
3571 else if(ctx -> token == WITH)
3572 {
3573 oberon_with_statement(ctx);
3574 }
3575 else if(ctx -> token == RETURN)
3576 {
3577 oberon_assert_token(ctx, RETURN);
3578 if(ISEXPR(ctx -> token))
3579 {
3580 oberon_expr_t * expr;
3581 expr = oberon_expr(ctx);
3582 oberon_make_return(ctx, expr);
3583 }
3584 else
3585 {
3586 oberon_make_return(ctx, NULL);
3587 }
3588 }
3589 }
3590
3591 static void
3592 oberon_statement_seq(oberon_context_t * ctx)
3593 {
3594 oberon_statement(ctx);
3595 while(ctx -> token == SEMICOLON)
3596 {
3597 oberon_assert_token(ctx, SEMICOLON);
3598 oberon_statement(ctx);
3599 }
3600 }
3601
3602 static void
3603 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
3604 {
3605 oberon_module_t * m = ctx -> module_list;
3606 while(m && strcmp(m -> name, name) != 0)
3607 {
3608 m = m -> next;
3609 }
3610
3611 if(m == NULL)
3612 {
3613 const char * code;
3614 code = ctx -> import_module(name);
3615 if(code == NULL)
3616 {
3617 oberon_error(ctx, "no such module");
3618 }
3619
3620 m = oberon_compile_module(ctx, code);
3621 assert(m);
3622 }
3623
3624 if(m -> ready == 0)
3625 {
3626 oberon_error(ctx, "cyclic module import");
3627 }
3628
3629 oberon_object_t * ident;
3630 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
3631 ident -> module = m;
3632 }
3633
3634 static void
3635 oberon_import_decl(oberon_context_t * ctx)
3636 {
3637 char * alias;
3638 char * name;
3639
3640 alias = name = oberon_assert_ident(ctx);
3641 if(ctx -> token == ASSIGN)
3642 {
3643 oberon_assert_token(ctx, ASSIGN);
3644 name = oberon_assert_ident(ctx);
3645 }
3646
3647 oberon_import_module(ctx, alias, name);
3648 }
3649
3650 static void
3651 oberon_import_list(oberon_context_t * ctx)
3652 {
3653 oberon_assert_token(ctx, IMPORT);
3654
3655 oberon_import_decl(ctx);
3656 while(ctx -> token == COMMA)
3657 {
3658 oberon_assert_token(ctx, COMMA);
3659 oberon_import_decl(ctx);
3660 }
3661
3662 oberon_assert_token(ctx, SEMICOLON);
3663 }
3664
3665 static void
3666 oberon_parse_module(oberon_context_t * ctx)
3667 {
3668 char * name1;
3669 char * name2;
3670 oberon_read_token(ctx);
3671
3672 oberon_assert_token(ctx, MODULE);
3673 name1 = oberon_assert_ident(ctx);
3674 oberon_assert_token(ctx, SEMICOLON);
3675 ctx -> mod -> name = name1;
3676
3677 oberon_generator_init_module(ctx, ctx -> mod);
3678
3679 if(ctx -> token == IMPORT)
3680 {
3681 oberon_import_list(ctx);
3682 }
3683
3684 oberon_decl_seq(ctx);
3685
3686 oberon_generate_begin_module(ctx);
3687 if(ctx -> token == BEGIN)
3688 {
3689 oberon_assert_token(ctx, BEGIN);
3690 oberon_statement_seq(ctx);
3691 }
3692 oberon_generate_end_module(ctx);
3693
3694 oberon_assert_token(ctx, END);
3695 name2 = oberon_assert_ident(ctx);
3696 oberon_assert_token(ctx, DOT);
3697
3698 if(strcmp(name1, name2) != 0)
3699 {
3700 oberon_error(ctx, "module name not matched");
3701 }
3702
3703 oberon_generator_fini_module(ctx -> mod);
3704 }
3705
3706 // =======================================================================
3707 // LIBRARY
3708 // =======================================================================
3709
3710 static void
3711 register_default_types(oberon_context_t * ctx)
3712 {
3713 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
3714 oberon_generator_init_type(ctx, ctx -> void_type);
3715
3716 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
3717 ctx -> void_ptr_type -> base = ctx -> void_type;
3718 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
3719
3720 ctx -> string_type = oberon_new_type_string(1);
3721 oberon_generator_init_type(ctx, ctx -> string_type);
3722
3723 ctx -> bool_type = oberon_new_type_boolean();
3724 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
3725
3726 ctx -> byte_type = oberon_new_type_integer(1);
3727 oberon_define_type(ctx -> world_scope, "BYTE", ctx -> byte_type, 1);
3728
3729 ctx -> shortint_type = oberon_new_type_integer(2);
3730 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> shortint_type, 1);
3731
3732 ctx -> int_type = oberon_new_type_integer(4);
3733 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
3734
3735 ctx -> longint_type = oberon_new_type_integer(8);
3736 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> longint_type, 1);
3737
3738 ctx -> real_type = oberon_new_type_real(4);
3739 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
3740
3741 ctx -> longreal_type = oberon_new_type_real(8);
3742 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
3743
3744 ctx -> char_type = oberon_new_type_char(1);
3745 oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1);
3746
3747 ctx -> set_type = oberon_new_type_set(4);
3748 oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1);
3749 }
3750
3751 static void
3752 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
3753 {
3754 oberon_object_t * proc;
3755 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
3756 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
3757 proc -> type -> sysproc = true;
3758 proc -> type -> genfunc = f;
3759 proc -> type -> genproc = p;
3760 }
3761
3762 static oberon_expr_t *
3763 oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3764 {
3765 if(num_args < 1)
3766 {
3767 oberon_error(ctx, "too few arguments");
3768 }
3769
3770 if(num_args > 1)
3771 {
3772 oberon_error(ctx, "too mach arguments");
3773 }
3774
3775 oberon_expr_t * arg;
3776 arg = list_args;
3777
3778 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3779 {
3780 oberon_error(ctx, "MIN accept only type");
3781 }
3782
3783 oberon_expr_t * expr;
3784 int bits = arg -> result -> size * 8;
3785 switch(arg -> result -> class)
3786 {
3787 case OBERON_TYPE_INTEGER:
3788 expr = oberon_integer_item(ctx, -powl(2, bits - 1));
3789 break;
3790 case OBERON_TYPE_SET:
3791 expr = oberon_integer_item(ctx, 0);
3792 break;
3793 default:
3794 oberon_error(ctx, "allowed only basic types");
3795 break;
3796 }
3797
3798 return expr;
3799 }
3800
3801 static oberon_expr_t *
3802 oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3803 {
3804 if(num_args < 1)
3805 {
3806 oberon_error(ctx, "too few arguments");
3807 }
3808
3809 if(num_args > 1)
3810 {
3811 oberon_error(ctx, "too mach arguments");
3812 }
3813
3814 oberon_expr_t * arg;
3815 arg = list_args;
3816
3817 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3818 {
3819 oberon_error(ctx, "MAX accept only type");
3820 }
3821
3822 oberon_expr_t * expr;
3823 int bits = arg -> result -> size * 8;
3824 switch(arg -> result -> class)
3825 {
3826 case OBERON_TYPE_INTEGER:
3827 expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1);
3828 break;
3829 case OBERON_TYPE_SET:
3830 expr = oberon_integer_item(ctx, bits);
3831 break;
3832 default:
3833 oberon_error(ctx, "allowed only basic types");
3834 break;
3835 }
3836
3837 return expr;
3838 }
3839
3840 static oberon_expr_t *
3841 oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3842 {
3843 if(num_args < 1)
3844 {
3845 oberon_error(ctx, "too few arguments");
3846 }
3847
3848 if(num_args > 1)
3849 {
3850 oberon_error(ctx, "too mach arguments");
3851 }
3852
3853 oberon_expr_t * arg;
3854 arg = list_args;
3855
3856 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3857 {
3858 oberon_error(ctx, "SIZE accept only type");
3859 }
3860
3861 int size;
3862 oberon_expr_t * expr;
3863 oberon_type_t * type = arg -> result;
3864 switch(type -> class)
3865 {
3866 case OBERON_TYPE_INTEGER:
3867 case OBERON_TYPE_BOOLEAN:
3868 case OBERON_TYPE_REAL:
3869 case OBERON_TYPE_CHAR:
3870 case OBERON_TYPE_SET:
3871 size = type -> size;
3872 break;
3873 default:
3874 oberon_error(ctx, "TODO SIZE");
3875 break;
3876 }
3877
3878 expr = oberon_integer_item(ctx, size);
3879 return expr;
3880 }
3881
3882 static oberon_expr_t *
3883 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3884 {
3885 if(num_args < 1)
3886 {
3887 oberon_error(ctx, "too few arguments");
3888 }
3889
3890 if(num_args > 1)
3891 {
3892 oberon_error(ctx, "too mach arguments");
3893 }
3894
3895 oberon_expr_t * arg;
3896 arg = list_args;
3897 oberon_check_src(ctx, arg);
3898
3899 oberon_type_t * result_type;
3900 result_type = arg -> result;
3901
3902 if(result_type -> class != OBERON_TYPE_INTEGER)
3903 {
3904 oberon_error(ctx, "ABS accepts only integers");
3905 }
3906
3907 oberon_expr_t * expr;
3908 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
3909 return expr;
3910 }
3911
3912 static void
3913 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3914 {
3915 if(num_args < 1)
3916 {
3917 oberon_error(ctx, "too few arguments");
3918 }
3919
3920
3921 oberon_expr_t * dst;
3922 dst = list_args;
3923 oberon_check_dst(ctx, dst);
3924
3925 oberon_type_t * type;
3926 type = dst -> result;
3927
3928 if(type -> class != OBERON_TYPE_POINTER)
3929 {
3930 oberon_error(ctx, "not a pointer");
3931 }
3932
3933 type = type -> base;
3934
3935 oberon_expr_t * src;
3936 src = oberon_new_item(MODE_NEW, dst -> result, 0);
3937 src -> item.num_args = 0;
3938 src -> item.args = NULL;
3939
3940 int max_args = 1;
3941 if(type -> class == OBERON_TYPE_ARRAY)
3942 {
3943 if(type -> size == 0)
3944 {
3945 oberon_type_t * x = type;
3946 while(x -> class == OBERON_TYPE_ARRAY)
3947 {
3948 if(x -> size == 0)
3949 {
3950 max_args += 1;
3951 }
3952 x = x -> base;
3953 }
3954 }
3955
3956 if(num_args < max_args)
3957 {
3958 oberon_error(ctx, "too few arguments");
3959 }
3960
3961 if(num_args > max_args)
3962 {
3963 oberon_error(ctx, "too mach arguments");
3964 }
3965
3966 int num_sizes = max_args - 1;
3967 oberon_expr_t * size_list = list_args -> next;
3968
3969 oberon_expr_t * arg = size_list;
3970 for(int i = 0; i < max_args - 1; i++)
3971 {
3972 oberon_check_src(ctx, arg);
3973 if(arg -> result -> class != OBERON_TYPE_INTEGER)
3974 {
3975 oberon_error(ctx, "size must be integer");
3976 }
3977 arg = arg -> next;
3978 }
3979
3980 src -> item.num_args = num_sizes;
3981 src -> item.args = size_list;
3982 }
3983 else if(type -> class != OBERON_TYPE_RECORD)
3984 {
3985 oberon_error(ctx, "oberon_make_new_call: wat");
3986 }
3987
3988 if(num_args > max_args)
3989 {
3990 oberon_error(ctx, "too mach arguments");
3991 }
3992
3993 oberon_assign(ctx, src, dst);
3994 }
3995
3996 oberon_context_t *
3997 oberon_create_context(ModuleImportCallback import_module)
3998 {
3999 oberon_context_t * ctx = calloc(1, sizeof *ctx);
4000
4001 oberon_scope_t * world_scope;
4002 world_scope = oberon_open_scope(ctx);
4003 ctx -> world_scope = world_scope;
4004
4005 ctx -> import_module = import_module;
4006
4007 oberon_generator_init_context(ctx);
4008
4009 register_default_types(ctx);
4010
4011 /* Functions */
4012 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
4013 oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL);
4014 oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
4015 oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
4016
4017 /* Procedures */
4018 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
4019
4020 return ctx;
4021 }
4022
4023 void
4024 oberon_destroy_context(oberon_context_t * ctx)
4025 {
4026 oberon_generator_destroy_context(ctx);
4027 free(ctx);
4028 }
4029
4030 oberon_module_t *
4031 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
4032 {
4033 const char * code = ctx -> code;
4034 int code_index = ctx -> code_index;
4035 char c = ctx -> c;
4036 int token = ctx -> token;
4037 char * string = ctx -> string;
4038 int integer = ctx -> integer;
4039 int real = ctx -> real;
4040 bool longmode = ctx -> longmode;
4041 oberon_scope_t * decl = ctx -> decl;
4042 oberon_module_t * mod = ctx -> mod;
4043
4044 oberon_scope_t * module_scope;
4045 module_scope = oberon_open_scope(ctx);
4046
4047 oberon_module_t * module;
4048 module = calloc(1, sizeof *module);
4049 module -> decl = module_scope;
4050 module -> next = ctx -> module_list;
4051
4052 ctx -> mod = module;
4053 ctx -> module_list = module;
4054
4055 oberon_init_scaner(ctx, newcode);
4056 oberon_parse_module(ctx);
4057
4058 module -> ready = 1;
4059
4060 ctx -> code = code;
4061 ctx -> code_index = code_index;
4062 ctx -> c = c;
4063 ctx -> token = token;
4064 ctx -> string = string;
4065 ctx -> integer = integer;
4066 ctx -> real = real;
4067 ctx -> longmode = longmode;
4068 ctx -> decl = decl;
4069 ctx -> mod = mod;
4070
4071 return module;
4072 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024