DEADSOFTWARE

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