DEADSOFTWARE

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