DEADSOFTWARE

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


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