DEADSOFTWARE

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


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