DEADSOFTWARE
GIT / REPO / FRED-BOY

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