DEADSOFTWARE

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


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