DEADSOFTWARE

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