DEADSOFTWARE

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


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