DEADSOFTWARE

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