DEADSOFTWARE
GIT / REPO / FRED-BOY

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