DEADSOFTWARE

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


e95a9bef396271f68b2dff5a6af06147cc530c09
[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
9 #include "../include/oberon.h"
10
11 #include "oberon-internals.h"
12 #include "generator.h"
13
14 enum {
15 EOF_ = 0,
16 IDENT,
17 MODULE,
18 SEMICOLON,
19 END,
20 DOT,
21 VAR,
22 COLON,
23 BEGIN,
24 ASSIGN,
25 INTEGER,
26 TRUE,
27 FALSE,
28 LPAREN,
29 RPAREN,
30 EQUAL,
31 NEQ,
32 LESS,
33 LEQ,
34 GREAT,
35 GEQ,
36 IN,
37 IS,
38 PLUS,
39 MINUS,
40 OR,
41 STAR,
42 SLASH,
43 DIV,
44 MOD,
45 AND,
46 NOT,
47 PROCEDURE,
48 COMMA,
49 RETURN,
50 CONST,
51 TYPE,
52 ARRAY,
53 OF,
54 LBRACE,
55 RBRACE,
56 RECORD,
57 POINTER,
58 TO,
59 UPARROW,
60 NIL,
61 IMPORT,
62 REAL,
63 CHAR,
64 STRING,
65 IF,
66 THEN,
67 ELSE,
68 ELSIF,
69 WHILE,
70 DO,
71 REPEAT,
72 UNTIL,
73 FOR,
74 BY,
75 LOOP,
76 EXIT
77 };
78
79 // =======================================================================
80 // UTILS
81 // =======================================================================
82
83 static void
84 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
85 {
86 va_list ptr;
87 va_start(ptr, fmt);
88 fprintf(stderr, "error: ");
89 vfprintf(stderr, fmt, ptr);
90 fprintf(stderr, "\n");
91 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
92 fprintf(stderr, " c = %c\n", ctx -> c);
93 fprintf(stderr, " token = %i\n", ctx -> token);
94 va_end(ptr);
95 exit(1);
96 }
97
98 static oberon_type_t *
99 oberon_new_type_ptr(int class)
100 {
101 oberon_type_t * x = malloc(sizeof *x);
102 memset(x, 0, sizeof *x);
103 x -> class = class;
104 return x;
105 }
106
107 static oberon_type_t *
108 oberon_new_type_integer(int size)
109 {
110 oberon_type_t * x;
111 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
112 x -> size = size;
113 return x;
114 }
115
116 static oberon_type_t *
117 oberon_new_type_boolean()
118 {
119 oberon_type_t * x;
120 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
121 return x;
122 }
123
124 static oberon_type_t *
125 oberon_new_type_real(int size)
126 {
127 oberon_type_t * x;
128 x = oberon_new_type_ptr(OBERON_TYPE_REAL);
129 x -> size = size;
130 return x;
131 }
132
133 static oberon_type_t *
134 oberon_new_type_char(int size)
135 {
136 oberon_type_t * x;
137 x = oberon_new_type_ptr(OBERON_TYPE_CHAR);
138 x -> size = size;
139 return x;
140 }
141
142 static oberon_type_t *
143 oberon_new_type_string(int size)
144 {
145 oberon_type_t * x;
146 x = oberon_new_type_ptr(OBERON_TYPE_STRING);
147 x -> size = size;
148 return x;
149 }
150
151 // =======================================================================
152 // TABLE
153 // =======================================================================
154
155 static oberon_scope_t *
156 oberon_open_scope(oberon_context_t * ctx)
157 {
158 oberon_scope_t * scope = calloc(1, sizeof *scope);
159 oberon_object_t * list = calloc(1, sizeof *list);
160
161 scope -> ctx = ctx;
162 scope -> list = list;
163 scope -> up = ctx -> decl;
164
165 if(scope -> up)
166 {
167 scope -> local = scope -> up -> local;
168 scope -> parent = scope -> up -> parent;
169 scope -> parent_type = scope -> up -> parent_type;
170 scope -> exit_label = scope -> up -> exit_label;
171 }
172
173 ctx -> decl = scope;
174 return scope;
175 }
176
177 static void
178 oberon_close_scope(oberon_scope_t * scope)
179 {
180 oberon_context_t * ctx = scope -> ctx;
181 ctx -> decl = scope -> up;
182 }
183
184 static oberon_object_t *
185 oberon_find_object_in_list(oberon_object_t * list, char * name)
186 {
187 oberon_object_t * x = list;
188 while(x -> next && strcmp(x -> next -> name, name) != 0)
189 {
190 x = x -> next;
191 }
192 return x -> next;
193 }
194
195 static oberon_object_t *
196 oberon_find_object(oberon_scope_t * scope, char * name, bool check_it)
197 {
198 oberon_object_t * result = NULL;
199
200 oberon_scope_t * s = scope;
201 while(result == NULL && s != NULL)
202 {
203 result = oberon_find_object_in_list(s -> list, name);
204 s = s -> up;
205 }
206
207 if(check_it && result == NULL)
208 {
209 oberon_error(scope -> ctx, "undefined ident %s", name);
210 }
211
212 return result;
213 }
214
215 static oberon_object_t *
216 oberon_create_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only)
217 {
218 oberon_object_t * newvar = malloc(sizeof *newvar);
219 memset(newvar, 0, sizeof *newvar);
220 newvar -> name = name;
221 newvar -> class = class;
222 newvar -> export = export;
223 newvar -> read_only = read_only;
224 newvar -> local = scope -> local;
225 newvar -> parent = scope -> parent;
226 newvar -> parent_type = scope -> parent_type;
227 newvar -> module = scope -> ctx -> mod;
228 return newvar;
229 }
230
231 static oberon_object_t *
232 oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only, bool check_upscope)
233 {
234 if(check_upscope)
235 {
236 if(oberon_find_object(scope -> up, name, false))
237 {
238 oberon_error(scope -> ctx, "already defined");
239 }
240 }
241
242 oberon_object_t * x = scope -> list;
243 while(x -> next && strcmp(x -> next -> name, name) != 0)
244 {
245 x = x -> next;
246 }
247
248 if(x -> next)
249 {
250 oberon_error(scope -> ctx, "already defined");
251 }
252
253 oberon_object_t * newvar;
254 newvar = oberon_create_object(scope, name, class, export, read_only);
255 x -> next = newvar;
256
257 return newvar;
258 }
259
260 static oberon_object_t *
261 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export)
262 {
263 oberon_object_t * id;
264 id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, false, false);
265 id -> type = type;
266 oberon_generator_init_type(scope -> ctx, type);
267 return id;
268 }
269
270 // =======================================================================
271 // SCANER
272 // =======================================================================
273
274 static void
275 oberon_get_char(oberon_context_t * ctx)
276 {
277 if(ctx -> code[ctx -> code_index])
278 {
279 ctx -> code_index += 1;
280 ctx -> c = ctx -> code[ctx -> code_index];
281 }
282 }
283
284 static void
285 oberon_init_scaner(oberon_context_t * ctx, const char * code)
286 {
287 ctx -> code = code;
288 ctx -> code_index = 0;
289 ctx -> c = ctx -> code[ctx -> code_index];
290 }
291
292 static void
293 oberon_read_ident(oberon_context_t * ctx)
294 {
295 int len = 0;
296 int i = ctx -> code_index;
297
298 int c = ctx -> code[i];
299 while(isalnum(c))
300 {
301 i += 1;
302 len += 1;
303 c = ctx -> code[i];
304 }
305
306 char * ident = malloc(len + 1);
307 memcpy(ident, &ctx->code[ctx->code_index], len);
308 ident[len] = 0;
309
310 ctx -> code_index = i;
311 ctx -> c = ctx -> code[i];
312 ctx -> string = ident;
313 ctx -> token = IDENT;
314
315 if(strcmp(ident, "MODULE") == 0)
316 {
317 ctx -> token = MODULE;
318 }
319 else if(strcmp(ident, "END") == 0)
320 {
321 ctx -> token = END;
322 }
323 else if(strcmp(ident, "VAR") == 0)
324 {
325 ctx -> token = VAR;
326 }
327 else if(strcmp(ident, "BEGIN") == 0)
328 {
329 ctx -> token = BEGIN;
330 }
331 else if(strcmp(ident, "TRUE") == 0)
332 {
333 ctx -> token = TRUE;
334 }
335 else if(strcmp(ident, "FALSE") == 0)
336 {
337 ctx -> token = FALSE;
338 }
339 else if(strcmp(ident, "OR") == 0)
340 {
341 ctx -> token = OR;
342 }
343 else if(strcmp(ident, "DIV") == 0)
344 {
345 ctx -> token = DIV;
346 }
347 else if(strcmp(ident, "MOD") == 0)
348 {
349 ctx -> token = MOD;
350 }
351 else if(strcmp(ident, "PROCEDURE") == 0)
352 {
353 ctx -> token = PROCEDURE;
354 }
355 else if(strcmp(ident, "RETURN") == 0)
356 {
357 ctx -> token = RETURN;
358 }
359 else if(strcmp(ident, "CONST") == 0)
360 {
361 ctx -> token = CONST;
362 }
363 else if(strcmp(ident, "TYPE") == 0)
364 {
365 ctx -> token = TYPE;
366 }
367 else if(strcmp(ident, "ARRAY") == 0)
368 {
369 ctx -> token = ARRAY;
370 }
371 else if(strcmp(ident, "OF") == 0)
372 {
373 ctx -> token = OF;
374 }
375 else if(strcmp(ident, "RECORD") == 0)
376 {
377 ctx -> token = RECORD;
378 }
379 else if(strcmp(ident, "POINTER") == 0)
380 {
381 ctx -> token = POINTER;
382 }
383 else if(strcmp(ident, "TO") == 0)
384 {
385 ctx -> token = TO;
386 }
387 else if(strcmp(ident, "NIL") == 0)
388 {
389 ctx -> token = NIL;
390 }
391 else if(strcmp(ident, "IMPORT") == 0)
392 {
393 ctx -> token = IMPORT;
394 }
395 else if(strcmp(ident, "IN") == 0)
396 {
397 ctx -> token = IN;
398 }
399 else if(strcmp(ident, "IS") == 0)
400 {
401 ctx -> token = IS;
402 }
403 else if(strcmp(ident, "IF") == 0)
404 {
405 ctx -> token = IF;
406 }
407 else if(strcmp(ident, "THEN") == 0)
408 {
409 ctx -> token = THEN;
410 }
411 else if(strcmp(ident, "ELSE") == 0)
412 {
413 ctx -> token = ELSE;
414 }
415 else if(strcmp(ident, "ELSIF") == 0)
416 {
417 ctx -> token = ELSIF;
418 }
419 else if(strcmp(ident, "WHILE") == 0)
420 {
421 ctx -> token = WHILE;
422 }
423 else if(strcmp(ident, "DO") == 0)
424 {
425 ctx -> token = DO;
426 }
427 else if(strcmp(ident, "REPEAT") == 0)
428 {
429 ctx -> token = REPEAT;
430 }
431 else if(strcmp(ident, "UNTIL") == 0)
432 {
433 ctx -> token = UNTIL;
434 }
435 else if(strcmp(ident, "FOR") == 0)
436 {
437 ctx -> token = FOR;
438 }
439 else if(strcmp(ident, "BY") == 0)
440 {
441 ctx -> token = BY;
442 }
443 else if(strcmp(ident, "LOOP") == 0)
444 {
445 ctx -> token = LOOP;
446 }
447 else if(strcmp(ident, "EXIT") == 0)
448 {
449 ctx -> token = EXIT;
450 }
451 }
452
453 static void
454 oberon_read_number(oberon_context_t * ctx)
455 {
456 long integer;
457 double real;
458 char * ident;
459 int start_i;
460 int exp_i;
461 int end_i;
462
463 /*
464 * mode = 0 == DEC
465 * mode = 1 == HEX
466 * mode = 2 == REAL
467 * mode = 3 == LONGREAL
468 * mode = 4 == CHAR
469 */
470 int mode = 0;
471 start_i = ctx -> code_index;
472
473 while(isdigit(ctx -> c))
474 {
475 oberon_get_char(ctx);
476 }
477
478 end_i = ctx -> code_index;
479
480 if(isxdigit(ctx -> c))
481 {
482 mode = 1;
483 while(isxdigit(ctx -> c))
484 {
485 oberon_get_char(ctx);
486 }
487
488 end_i = ctx -> code_index;
489
490 if(ctx -> c == 'H')
491 {
492 mode = 1;
493 oberon_get_char(ctx);
494 }
495 else if(ctx -> c == 'X')
496 {
497 mode = 4;
498 oberon_get_char(ctx);
499 }
500 else
501 {
502 oberon_error(ctx, "invalid hex number");
503 }
504 }
505 else if(ctx -> c == '.')
506 {
507 mode = 2;
508 oberon_get_char(ctx);
509
510 while(isdigit(ctx -> c))
511 {
512 oberon_get_char(ctx);
513 }
514
515 if(ctx -> c == 'E' || ctx -> c == 'D')
516 {
517 exp_i = ctx -> code_index;
518
519 if(ctx -> c == 'D')
520 {
521 mode = 3;
522 }
523
524 oberon_get_char(ctx);
525
526 if(ctx -> c == '+' || ctx -> c == '-')
527 {
528 oberon_get_char(ctx);
529 }
530
531 while(isdigit(ctx -> c))
532 {
533 oberon_get_char(ctx);
534 }
535
536 }
537
538 end_i = ctx -> code_index;
539 }
540
541 if(mode == 0)
542 {
543 if(ctx -> c == 'H')
544 {
545 mode = 1;
546 oberon_get_char(ctx);
547 }
548 else if(ctx -> c == 'X')
549 {
550 mode = 4;
551 oberon_get_char(ctx);
552 }
553 }
554
555 int len = end_i - start_i;
556 ident = malloc(len + 1);
557 memcpy(ident, &ctx -> code[start_i], len);
558 ident[len] = 0;
559
560 ctx -> longmode = false;
561 if(mode == 3)
562 {
563 int i = exp_i - start_i;
564 ident[i] = 'E';
565 ctx -> longmode = true;
566 }
567
568 switch(mode)
569 {
570 case 0:
571 integer = atol(ident);
572 real = integer;
573 ctx -> token = INTEGER;
574 break;
575 case 1:
576 sscanf(ident, "%lx", &integer);
577 real = integer;
578 ctx -> token = INTEGER;
579 break;
580 case 2:
581 case 3:
582 sscanf(ident, "%lf", &real);
583 ctx -> token = REAL;
584 break;
585 case 4:
586 sscanf(ident, "%lx", &integer);
587 real = integer;
588 ctx -> token = CHAR;
589 break;
590 default:
591 oberon_error(ctx, "oberon_read_number: wat");
592 break;
593 }
594
595 ctx -> string = ident;
596 ctx -> integer = integer;
597 ctx -> real = real;
598 }
599
600 static void
601 oberon_skip_space(oberon_context_t * ctx)
602 {
603 while(isspace(ctx -> c))
604 {
605 oberon_get_char(ctx);
606 }
607 }
608
609 static void
610 oberon_read_comment(oberon_context_t * ctx)
611 {
612 int nesting = 1;
613 while(nesting >= 1)
614 {
615 if(ctx -> c == '(')
616 {
617 oberon_get_char(ctx);
618 if(ctx -> c == '*')
619 {
620 oberon_get_char(ctx);
621 nesting += 1;
622 }
623 }
624 else if(ctx -> c == '*')
625 {
626 oberon_get_char(ctx);
627 if(ctx -> c == ')')
628 {
629 oberon_get_char(ctx);
630 nesting -= 1;
631 }
632 }
633 else if(ctx -> c == 0)
634 {
635 oberon_error(ctx, "unterminated comment");
636 }
637 else
638 {
639 oberon_get_char(ctx);
640 }
641 }
642 }
643
644 static void oberon_read_string(oberon_context_t * ctx)
645 {
646 int c = ctx -> c;
647 oberon_get_char(ctx);
648
649 int start = ctx -> code_index;
650
651 while(ctx -> c != 0 && ctx -> c != c)
652 {
653 oberon_get_char(ctx);
654 }
655
656 if(ctx -> c == 0)
657 {
658 oberon_error(ctx, "unterminated string");
659 }
660
661 int end = ctx -> code_index;
662
663 oberon_get_char(ctx);
664
665 char * string = calloc(1, end - start + 1);
666 strncpy(string, &ctx -> code[start], end - start);
667
668 ctx -> token = STRING;
669 ctx -> string = string;
670
671 printf("oberon_read_string: string ((%s))\n", string);
672 }
673
674 static void oberon_read_token(oberon_context_t * ctx);
675
676 static void
677 oberon_read_symbol(oberon_context_t * ctx)
678 {
679 int c = ctx -> c;
680 switch(c)
681 {
682 case 0:
683 ctx -> token = EOF_;
684 break;
685 case ';':
686 ctx -> token = SEMICOLON;
687 oberon_get_char(ctx);
688 break;
689 case ':':
690 ctx -> token = COLON;
691 oberon_get_char(ctx);
692 if(ctx -> c == '=')
693 {
694 ctx -> token = ASSIGN;
695 oberon_get_char(ctx);
696 }
697 break;
698 case '.':
699 ctx -> token = DOT;
700 oberon_get_char(ctx);
701 break;
702 case '(':
703 ctx -> token = LPAREN;
704 oberon_get_char(ctx);
705 if(ctx -> c == '*')
706 {
707 oberon_get_char(ctx);
708 oberon_read_comment(ctx);
709 oberon_read_token(ctx);
710 }
711 break;
712 case ')':
713 ctx -> token = RPAREN;
714 oberon_get_char(ctx);
715 break;
716 case '=':
717 ctx -> token = EQUAL;
718 oberon_get_char(ctx);
719 break;
720 case '#':
721 ctx -> token = NEQ;
722 oberon_get_char(ctx);
723 break;
724 case '<':
725 ctx -> token = LESS;
726 oberon_get_char(ctx);
727 if(ctx -> c == '=')
728 {
729 ctx -> token = LEQ;
730 oberon_get_char(ctx);
731 }
732 break;
733 case '>':
734 ctx -> token = GREAT;
735 oberon_get_char(ctx);
736 if(ctx -> c == '=')
737 {
738 ctx -> token = GEQ;
739 oberon_get_char(ctx);
740 }
741 break;
742 case '+':
743 ctx -> token = PLUS;
744 oberon_get_char(ctx);
745 break;
746 case '-':
747 ctx -> token = MINUS;
748 oberon_get_char(ctx);
749 break;
750 case '*':
751 ctx -> token = STAR;
752 oberon_get_char(ctx);
753 if(ctx -> c == ')')
754 {
755 oberon_get_char(ctx);
756 oberon_error(ctx, "unstarted comment");
757 }
758 break;
759 case '/':
760 ctx -> token = SLASH;
761 oberon_get_char(ctx);
762 break;
763 case '&':
764 ctx -> token = AND;
765 oberon_get_char(ctx);
766 break;
767 case '~':
768 ctx -> token = NOT;
769 oberon_get_char(ctx);
770 break;
771 case ',':
772 ctx -> token = COMMA;
773 oberon_get_char(ctx);
774 break;
775 case '[':
776 ctx -> token = LBRACE;
777 oberon_get_char(ctx);
778 break;
779 case ']':
780 ctx -> token = RBRACE;
781 oberon_get_char(ctx);
782 break;
783 case '^':
784 ctx -> token = UPARROW;
785 oberon_get_char(ctx);
786 break;
787 case '"':
788 oberon_read_string(ctx);
789 break;
790 case '\'':
791 oberon_read_string(ctx);
792 break;
793 default:
794 oberon_error(ctx, "invalid char %c", ctx -> c);
795 break;
796 }
797 }
798
799 static void
800 oberon_read_token(oberon_context_t * ctx)
801 {
802 oberon_skip_space(ctx);
803
804 int c = ctx -> c;
805 if(isalpha(c))
806 {
807 oberon_read_ident(ctx);
808 }
809 else if(isdigit(c))
810 {
811 oberon_read_number(ctx);
812 }
813 else
814 {
815 oberon_read_symbol(ctx);
816 }
817 }
818
819 // =======================================================================
820 // EXPRESSION
821 // =======================================================================
822
823 static void oberon_expect_token(oberon_context_t * ctx, int token);
824 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
825 static void oberon_assert_token(oberon_context_t * ctx, int token);
826 static char * oberon_assert_ident(oberon_context_t * ctx);
827 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
828 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
829 static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr);
830
831 static oberon_expr_t *
832 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
833 {
834 oberon_oper_t * operator;
835 operator = malloc(sizeof *operator);
836 memset(operator, 0, sizeof *operator);
837
838 operator -> is_item = 0;
839 operator -> result = result;
840 operator -> read_only = 1;
841 operator -> op = op;
842 operator -> left = left;
843 operator -> right = right;
844
845 return (oberon_expr_t *) operator;
846 }
847
848 static oberon_expr_t *
849 oberon_new_item(int mode, oberon_type_t * result, int read_only)
850 {
851 oberon_item_t * item;
852 item = malloc(sizeof *item);
853 memset(item, 0, sizeof *item);
854
855 item -> is_item = 1;
856 item -> result = result;
857 item -> read_only = read_only;
858 item -> mode = mode;
859
860 return (oberon_expr_t *)item;
861 }
862
863 static oberon_expr_t *
864 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
865 {
866 oberon_expr_t * expr;
867 oberon_type_t * result;
868
869 result = a -> result;
870
871 if(token == MINUS)
872 {
873 if(result -> class != OBERON_TYPE_INTEGER)
874 {
875 oberon_error(ctx, "incompatible operator type");
876 }
877
878 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
879 }
880 else if(token == NOT)
881 {
882 if(result -> class != OBERON_TYPE_BOOLEAN)
883 {
884 oberon_error(ctx, "incompatible operator type");
885 }
886
887 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
888 }
889 else
890 {
891 oberon_error(ctx, "oberon_make_unary_op: wat");
892 }
893
894 return expr;
895 }
896
897 static void
898 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
899 {
900 oberon_expr_t * last;
901
902 *num_expr = 1;
903 if(const_expr)
904 {
905 *first = last = (oberon_expr_t *) oberon_const_expr(ctx);
906 }
907 else
908 {
909 *first = last = oberon_expr(ctx);
910 }
911 while(ctx -> token == COMMA)
912 {
913 oberon_assert_token(ctx, COMMA);
914 oberon_expr_t * current;
915
916 if(const_expr)
917 {
918 current = (oberon_expr_t *) oberon_const_expr(ctx);
919 }
920 else
921 {
922 current = oberon_expr(ctx);
923 }
924
925 last -> next = current;
926 last = current;
927 *num_expr += 1;
928 }
929 }
930
931 static oberon_expr_t *
932 oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
933 {
934 return oberon_new_operator(OP_CAST, pref, expr, NULL);
935 }
936
937 static oberon_expr_t *
938 oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec)
939 {
940 oberon_type_t * from = expr -> result;
941 oberon_type_t * to = rec;
942
943 printf("oberno_make_record_cast: from class %i to class %i\n", from -> class, to -> class);
944
945 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
946 {
947 printf("oberno_make_record_cast: pointers\n");
948 from = from -> base;
949 to = to -> base;
950 }
951
952 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
953 {
954 oberon_error(ctx, "must be record type");
955 }
956
957 return oberon_cast_expr(ctx, expr, rec);
958 }
959
960 static oberon_type_t *
961 oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
962 {
963 oberon_type_t * result;
964 if(a -> class == OBERON_TYPE_REAL && b -> class == OBERON_TYPE_INTEGER)
965 {
966 result = a;
967 }
968 else if(b -> class == OBERON_TYPE_REAL && a -> class == OBERON_TYPE_INTEGER)
969 {
970 result = b;
971 }
972 else if(a -> class != b -> class)
973 {
974 oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types");
975 }
976 else if(a -> size > b -> size)
977 {
978 result = a;
979 }
980 else
981 {
982 result = b;
983 }
984
985 return result;
986 }
987
988 static void
989 oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to)
990 {
991 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
992 {
993 from = from -> base;
994 to = to -> base;
995 }
996
997 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
998 {
999 oberon_error(ctx, "not a record");
1000 }
1001
1002 oberon_type_t * t = from;
1003 while(t != NULL && t != to)
1004 {
1005 t = t -> base;
1006 }
1007
1008 if(t == NULL)
1009 {
1010 oberon_error(ctx, "incompatible record types");
1011 }
1012 }
1013
1014 static oberon_expr_t *
1015 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
1016 {
1017 // Допускается:
1018 // Если классы типов равны
1019 // Если INTEGER переводится в REAL
1020 // Есди STRING переводится в ARRAY OF CHAR
1021
1022 bool error = false;
1023 if(pref -> class != expr -> result -> class)
1024 {
1025 printf("expr class %i\n", expr -> result -> class);
1026 printf("pref class %i\n", pref -> class);
1027
1028 if(expr -> result -> class == OBERON_TYPE_STRING)
1029 {
1030 if(pref -> class == OBERON_TYPE_ARRAY)
1031 {
1032 if(pref -> base -> class != OBERON_TYPE_CHAR)
1033 {
1034 error = true;
1035 }
1036 }
1037 else
1038 {
1039 error = true;
1040 }
1041 }
1042 else if(expr -> result -> class == OBERON_TYPE_INTEGER)
1043 {
1044 if(pref -> class != OBERON_TYPE_REAL)
1045 {
1046 error = true;
1047 }
1048 }
1049 else
1050 {
1051 error = true;
1052 }
1053 }
1054
1055 if(error)
1056 {
1057 oberon_error(ctx, "oberon_autocast_to: incompatible types");
1058 }
1059
1060 if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL)
1061 {
1062 if(expr -> result -> size > pref -> size)
1063 {
1064 oberon_error(ctx, "incompatible size");
1065 }
1066 else
1067 {
1068 expr = oberon_cast_expr(ctx, expr, pref);
1069 }
1070 }
1071 else if(pref -> class == OBERON_TYPE_RECORD)
1072 {
1073 oberon_check_record_compatibility(ctx, expr -> result, pref);
1074 expr = oberno_make_record_cast(ctx, expr, pref);
1075 }
1076 else if(pref -> class == OBERON_TYPE_POINTER)
1077 {
1078 assert(pref -> base);
1079 if(expr -> result -> base -> class == OBERON_TYPE_RECORD)
1080 {
1081 oberon_check_record_compatibility(ctx, expr -> result, pref);
1082 expr = oberno_make_record_cast(ctx, expr, pref);
1083 }
1084 else if(expr -> result -> base != pref -> base)
1085 {
1086 if(expr -> result -> base -> class != OBERON_TYPE_VOID)
1087 {
1088 oberon_error(ctx, "incompatible pointer types");
1089 }
1090 }
1091 }
1092
1093 return expr;
1094 }
1095
1096 static void
1097 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb)
1098 {
1099 oberon_type_t * a = (*ea) -> result;
1100 oberon_type_t * b = (*eb) -> result;
1101 oberon_type_t * preq = oberon_get_equal_expr_type(ctx, a, b);
1102 *ea = oberon_autocast_to(ctx, *ea, preq);
1103 *eb = oberon_autocast_to(ctx, *eb, preq);
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 if(arg -> read_only)
1136 {
1137 oberon_error(ctx, "assign to read-only var");
1138 }
1139 }
1140
1141 casted[i] = oberon_autocast_to(ctx, arg, param -> type);
1142 arg = arg -> next;
1143 param = param -> next;
1144 }
1145
1146 /* Создаём новый список выражений */
1147 if(num_args > 0)
1148 {
1149 arg = casted[0];
1150 for(int i = 0; i < num_args - 1; i++)
1151 {
1152 casted[i] -> next = casted[i + 1];
1153 }
1154 desig -> args = arg;
1155 }
1156 }
1157
1158 static oberon_expr_t *
1159 oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1160 {
1161 oberon_type_t * signature = item -> result;
1162 if(signature -> class != OBERON_TYPE_PROCEDURE)
1163 {
1164 oberon_error(ctx, "not a procedure");
1165 }
1166
1167 oberon_expr_t * call;
1168
1169 if(signature -> sysproc)
1170 {
1171 if(signature -> genfunc == NULL)
1172 {
1173 oberon_error(ctx, "not a function-procedure");
1174 }
1175
1176 call = signature -> genfunc(ctx, num_args, list_args);
1177 }
1178 else
1179 {
1180 if(signature -> base -> class == OBERON_TYPE_VOID)
1181 {
1182 oberon_error(ctx, "attempt to call procedure in expression");
1183 }
1184
1185 call = oberon_new_item(MODE_CALL, signature -> base, true);
1186 call -> item.parent = item;
1187 call -> item.num_args = num_args;
1188 call -> item.args = list_args;
1189 oberon_autocast_call(ctx, (oberon_item_t *) call);
1190 }
1191
1192 return call;
1193 }
1194
1195 static void
1196 oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1197 {
1198 oberon_type_t * signature = item -> result;
1199 if(signature -> class != OBERON_TYPE_PROCEDURE)
1200 {
1201 oberon_error(ctx, "not a procedure");
1202 }
1203
1204 oberon_expr_t * call;
1205
1206 if(signature -> sysproc)
1207 {
1208 if(signature -> genproc == NULL)
1209 {
1210 oberon_error(ctx, "not a procedure");
1211 }
1212
1213 signature -> genproc(ctx, num_args, list_args);
1214 }
1215 else
1216 {
1217 if(signature -> base -> class != OBERON_TYPE_VOID)
1218 {
1219 oberon_error(ctx, "attempt to call function as non-typed procedure");
1220 }
1221
1222 call = oberon_new_item(MODE_CALL, signature -> base, true);
1223 call -> item.parent = item;
1224 call -> item.num_args = num_args;
1225 call -> item.args = list_args;
1226 oberon_autocast_call(ctx, (oberon_item_t *) call);
1227 oberon_generate_call_proc(ctx, call);
1228 }
1229 }
1230
1231 /*
1232 static void
1233 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
1234 {
1235 switch(proc -> class)
1236 {
1237 case OBERON_CLASS_PROC:
1238 if(proc -> class != OBERON_CLASS_PROC)
1239 {
1240 oberon_error(ctx, "not a procedure");
1241 }
1242 break;
1243 case OBERON_CLASS_VAR:
1244 case OBERON_CLASS_VAR_PARAM:
1245 case OBERON_CLASS_PARAM:
1246 if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
1247 {
1248 oberon_error(ctx, "not a procedure");
1249 }
1250 break;
1251 default:
1252 oberon_error(ctx, "not a procedure");
1253 break;
1254 }
1255
1256 if(proc -> sysproc)
1257 {
1258 if(proc -> genproc == NULL)
1259 {
1260 oberon_error(ctx, "requres non-typed procedure");
1261 }
1262
1263 proc -> genproc(ctx, num_args, list_args);
1264 }
1265 else
1266 {
1267 if(proc -> type -> base -> class != OBERON_TYPE_VOID)
1268 {
1269 oberon_error(ctx, "attempt to call function as non-typed procedure");
1270 }
1271
1272 oberon_expr_t * call;
1273 call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
1274 call -> item.var = proc;
1275 call -> item.num_args = num_args;
1276 call -> item.args = list_args;
1277 oberon_autocast_call(ctx, call);
1278 oberon_generate_call_proc(ctx, call);
1279 }
1280 }
1281 */
1282
1283 #define ISEXPR(x) \
1284 (((x) == PLUS) \
1285 || ((x) == MINUS) \
1286 || ((x) == IDENT) \
1287 || ((x) == INTEGER) \
1288 || ((x) == REAL) \
1289 || ((x) == CHAR) \
1290 || ((x) == STRING) \
1291 || ((x) == NIL) \
1292 || ((x) == LPAREN) \
1293 || ((x) == NOT) \
1294 || ((x) == TRUE) \
1295 || ((x) == FALSE))
1296
1297 static oberon_expr_t *
1298 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
1299 {
1300 printf("oberno_make_dereferencing\n");
1301 if(expr -> result -> class != OBERON_TYPE_POINTER)
1302 {
1303 oberon_error(ctx, "not a pointer");
1304 }
1305
1306 assert(expr -> is_item);
1307
1308 oberon_expr_t * selector;
1309 selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
1310 selector -> item.parent = (oberon_item_t *) expr;
1311
1312 return selector;
1313 }
1314
1315 static oberon_expr_t *
1316 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
1317 {
1318 if(desig -> result -> class == OBERON_TYPE_POINTER)
1319 {
1320 desig = oberno_make_dereferencing(ctx, desig);
1321 }
1322
1323 assert(desig -> is_item);
1324
1325 if(desig -> result -> class != OBERON_TYPE_ARRAY)
1326 {
1327 oberon_error(ctx, "not array");
1328 }
1329
1330 oberon_type_t * base;
1331 base = desig -> result -> base;
1332
1333 if(index -> result -> class != OBERON_TYPE_INTEGER)
1334 {
1335 oberon_error(ctx, "index must be integer");
1336 }
1337
1338 // Статическая проверка границ массива
1339 if(desig -> result -> size != 0)
1340 {
1341 if(index -> is_item)
1342 {
1343 if(index -> item.mode == MODE_INTEGER)
1344 {
1345 int arr_size = desig -> result -> size;
1346 int index_int = index -> item.integer;
1347 if(index_int < 0 || index_int > arr_size - 1)
1348 {
1349 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
1350 }
1351 }
1352 }
1353 }
1354
1355 oberon_expr_t * selector;
1356 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
1357 selector -> item.parent = (oberon_item_t *) desig;
1358 selector -> item.num_args = 1;
1359 selector -> item.args = index;
1360
1361 return selector;
1362 }
1363
1364 static oberon_expr_t *
1365 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
1366 {
1367 if(expr -> result -> class == OBERON_TYPE_POINTER)
1368 {
1369 expr = oberno_make_dereferencing(ctx, expr);
1370 }
1371
1372 assert(expr -> is_item);
1373
1374 if(expr -> result -> class != OBERON_TYPE_RECORD)
1375 {
1376 oberon_error(ctx, "not record");
1377 }
1378
1379 oberon_type_t * rec = expr -> result;
1380
1381 oberon_object_t * field;
1382 field = oberon_find_object(rec -> scope, name, true);
1383
1384 if(field -> export == 0)
1385 {
1386 if(field -> module != ctx -> mod)
1387 {
1388 oberon_error(ctx, "field not exported");
1389 }
1390 }
1391
1392 int read_only = 0;
1393 if(field -> read_only)
1394 {
1395 if(field -> module != ctx -> mod)
1396 {
1397 read_only = 1;
1398 }
1399 }
1400
1401 oberon_expr_t * selector;
1402 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
1403 selector -> item.var = field;
1404 selector -> item.parent = (oberon_item_t *) expr;
1405
1406 return selector;
1407 }
1408
1409 #define ISSELECTOR(x) \
1410 (((x) == LBRACE) \
1411 || ((x) == DOT) \
1412 || ((x) == UPARROW) \
1413 || ((x) == LPAREN))
1414
1415 static oberon_object_t *
1416 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1417 {
1418 char * name;
1419 oberon_object_t * x;
1420
1421 name = oberon_assert_ident(ctx);
1422 x = oberon_find_object(ctx -> decl, name, check);
1423
1424 if(x != NULL)
1425 {
1426 if(x -> class == OBERON_CLASS_MODULE)
1427 {
1428 oberon_assert_token(ctx, DOT);
1429 name = oberon_assert_ident(ctx);
1430 /* Наличие объектов в левых модулях всегда проверяется */
1431 x = oberon_find_object(x -> module -> decl, name, 1);
1432
1433 if(x -> export == 0)
1434 {
1435 oberon_error(ctx, "not exported");
1436 }
1437 }
1438 }
1439
1440 if(xname)
1441 {
1442 *xname = name;
1443 }
1444
1445 return x;
1446 }
1447
1448 static oberon_expr_t *
1449 oberon_ident_item(oberon_context_t * ctx, char * name)
1450 {
1451 bool read_only;
1452 oberon_object_t * x;
1453 oberon_expr_t * expr;
1454
1455 x = oberon_find_object(ctx -> decl, name, true);
1456
1457 read_only = false;
1458 if(x -> class == OBERON_CLASS_CONST || x -> class == OBERON_CLASS_PROC)
1459 {
1460 read_only = true;
1461 }
1462
1463 expr = oberon_new_item(MODE_VAR, x -> type, read_only);
1464 expr -> item.var = x;
1465 return expr;
1466 }
1467
1468 static oberon_expr_t *
1469 oberon_designator(oberon_context_t * ctx)
1470 {
1471 char * name;
1472 oberon_object_t * var;
1473 oberon_expr_t * expr;
1474
1475 var = oberon_qualident(ctx, NULL, 1);
1476
1477 int read_only = 0;
1478 if(var -> read_only)
1479 {
1480 if(var -> module != ctx -> mod)
1481 {
1482 read_only = 1;
1483 }
1484 }
1485
1486 switch(var -> class)
1487 {
1488 case OBERON_CLASS_CONST:
1489 // TODO copy value
1490 expr = (oberon_expr_t *) var -> value;
1491 break;
1492 case OBERON_CLASS_VAR:
1493 case OBERON_CLASS_VAR_PARAM:
1494 case OBERON_CLASS_PARAM:
1495 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1496 break;
1497 case OBERON_CLASS_PROC:
1498 expr = oberon_new_item(MODE_VAR, var -> type, true);
1499 break;
1500 default:
1501 oberon_error(ctx, "invalid designator");
1502 break;
1503 }
1504 expr -> item.var = var;
1505
1506 while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
1507 {
1508 switch(ctx -> token)
1509 {
1510 case DOT:
1511 oberon_assert_token(ctx, DOT);
1512 name = oberon_assert_ident(ctx);
1513 expr = oberon_make_record_selector(ctx, expr, name);
1514 break;
1515 case LBRACE:
1516 oberon_assert_token(ctx, LBRACE);
1517 int num_indexes = 0;
1518 oberon_expr_t * indexes = NULL;
1519 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1520 oberon_assert_token(ctx, RBRACE);
1521
1522 for(int i = 0; i < num_indexes; i++)
1523 {
1524 expr = oberon_make_array_selector(ctx, expr, indexes);
1525 indexes = indexes -> next;
1526 }
1527 break;
1528 case UPARROW:
1529 oberon_assert_token(ctx, UPARROW);
1530 expr = oberno_make_dereferencing(ctx, expr);
1531 break;
1532 case LPAREN:
1533 oberon_assert_token(ctx, LPAREN);
1534 oberon_object_t * objtype = oberon_qualident(ctx, NULL, 1);
1535 if(objtype -> class != OBERON_CLASS_TYPE)
1536 {
1537 oberon_error(ctx, "must be type");
1538 }
1539 oberon_assert_token(ctx, RPAREN);
1540 expr = oberno_make_record_cast(ctx, expr, objtype -> type);
1541 break;
1542 default:
1543 oberon_error(ctx, "oberon_designator: wat");
1544 break;
1545 }
1546 }
1547
1548 return expr;
1549 }
1550
1551 static oberon_expr_t *
1552 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1553 {
1554 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1555 if(ctx -> token == LPAREN)
1556 {
1557 oberon_assert_token(ctx, LPAREN);
1558
1559 int num_args = 0;
1560 oberon_expr_t * arguments = NULL;
1561
1562 if(ISEXPR(ctx -> token))
1563 {
1564 oberon_expr_list(ctx, &num_args, &arguments, 0);
1565 }
1566
1567 assert(expr -> is_item == 1);
1568 expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
1569
1570 oberon_assert_token(ctx, RPAREN);
1571 }
1572
1573 return expr;
1574 }
1575
1576 static void
1577 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1578 {
1579 assert(expr -> is_item);
1580
1581 int num_args = 0;
1582 oberon_expr_t * arguments = NULL;
1583
1584 if(ctx -> token == LPAREN)
1585 {
1586 oberon_assert_token(ctx, LPAREN);
1587
1588 if(ISEXPR(ctx -> token))
1589 {
1590 oberon_expr_list(ctx, &num_args, &arguments, 0);
1591 }
1592
1593 oberon_assert_token(ctx, RPAREN);
1594 }
1595
1596 /* Вызов происходит даже без скобок */
1597 oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
1598 }
1599
1600 static oberon_type_t *
1601 oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i)
1602 {
1603 if(i >= -128 && i <= 127)
1604 {
1605 return ctx -> byte_type;
1606 }
1607 else if(i >= -32768 && i <= 32767)
1608 {
1609 return ctx -> shortint_type;
1610 }
1611 else if(i >= -2147483648 && i <= 2147483647)
1612 {
1613 return ctx -> int_type;
1614 }
1615 else
1616 {
1617 return ctx -> longint_type;
1618 }
1619 }
1620
1621 static oberon_expr_t *
1622 oberon_integer_item(oberon_context_t * ctx, int64_t i)
1623 {
1624 oberon_expr_t * expr;
1625 oberon_type_t * result;
1626 result = oberon_get_type_of_int_value(ctx, i);
1627 expr = oberon_new_item(MODE_INTEGER, result, true);
1628 expr -> item.integer = i;
1629 return expr;
1630 }
1631
1632 static oberon_expr_t *
1633 oberon_factor(oberon_context_t * ctx)
1634 {
1635 oberon_expr_t * expr;
1636 oberon_type_t * result;
1637
1638 switch(ctx -> token)
1639 {
1640 case IDENT:
1641 expr = oberon_designator(ctx);
1642 expr = oberon_opt_func_parens(ctx, expr);
1643 break;
1644 case INTEGER:
1645 expr = oberon_integer_item(ctx, ctx -> integer);
1646 oberon_assert_token(ctx, INTEGER);
1647 break;
1648 case CHAR:
1649 result = ctx -> char_type;
1650 expr = oberon_new_item(MODE_CHAR, result, true);
1651 expr -> item.integer = ctx -> integer;
1652 oberon_assert_token(ctx, CHAR);
1653 break;
1654 case STRING:
1655 result = ctx -> string_type;
1656 expr = oberon_new_item(MODE_STRING, result, true);
1657 expr -> item.string = ctx -> string;
1658 oberon_assert_token(ctx, STRING);
1659 break;
1660 case REAL:
1661 result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type);
1662 expr = oberon_new_item(MODE_REAL, result, 1);
1663 expr -> item.real = ctx -> real;
1664 oberon_assert_token(ctx, REAL);
1665 break;
1666 case TRUE:
1667 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1668 expr -> item.boolean = true;
1669 oberon_assert_token(ctx, TRUE);
1670 break;
1671 case FALSE:
1672 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1673 expr -> item.boolean = false;
1674 oberon_assert_token(ctx, FALSE);
1675 break;
1676 case LPAREN:
1677 oberon_assert_token(ctx, LPAREN);
1678 expr = oberon_expr(ctx);
1679 oberon_assert_token(ctx, RPAREN);
1680 break;
1681 case NOT:
1682 oberon_assert_token(ctx, NOT);
1683 expr = oberon_factor(ctx);
1684 expr = oberon_make_unary_op(ctx, NOT, expr);
1685 break;
1686 case NIL:
1687 oberon_assert_token(ctx, NIL);
1688 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, true);
1689 break;
1690 default:
1691 oberon_error(ctx, "invalid expression");
1692 }
1693
1694 return expr;
1695 }
1696
1697 #define ITMAKESBOOLEAN(x) \
1698 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1699
1700 #define ITUSEONLYINTEGER(x) \
1701 ((x) >= LESS && (x) <= GEQ)
1702
1703 #define ITUSEONLYBOOLEAN(x) \
1704 (((x) == OR) || ((x) == AND))
1705
1706 static void
1707 oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e)
1708 {
1709 oberon_expr_t * expr = *e;
1710 if(expr -> result -> class == OBERON_TYPE_INTEGER)
1711 {
1712 if(expr -> result -> size <= ctx -> real_type -> size)
1713 {
1714 *e = oberon_cast_expr(ctx, expr, ctx -> real_type);
1715 }
1716 else
1717 {
1718 *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type);
1719 }
1720 }
1721 else if(expr -> result -> class != OBERON_TYPE_REAL)
1722 {
1723 oberon_error(ctx, "required numeric type");
1724 }
1725 }
1726
1727 static oberon_expr_t *
1728 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1729 {
1730 oberon_expr_t * expr;
1731 oberon_type_t * result;
1732
1733 if(ITMAKESBOOLEAN(token))
1734 {
1735 if(ITUSEONLYINTEGER(token))
1736 {
1737 if(a -> result -> class == OBERON_TYPE_INTEGER
1738 || b -> result -> class == OBERON_TYPE_INTEGER
1739 || a -> result -> class == OBERON_TYPE_REAL
1740 || b -> result -> class == OBERON_TYPE_REAL)
1741 {
1742 // accept
1743 }
1744 else
1745 {
1746 oberon_error(ctx, "used only with numeric types");
1747 }
1748 }
1749 else if(ITUSEONLYBOOLEAN(token))
1750 {
1751 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1752 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1753 {
1754 oberon_error(ctx, "used only with boolean type");
1755 }
1756 }
1757
1758 oberon_autocast_binary_op(ctx, &a, &b);
1759 result = ctx -> bool_type;
1760
1761 if(token == EQUAL)
1762 {
1763 expr = oberon_new_operator(OP_EQ, result, a, b);
1764 }
1765 else if(token == NEQ)
1766 {
1767 expr = oberon_new_operator(OP_NEQ, result, a, b);
1768 }
1769 else if(token == LESS)
1770 {
1771 expr = oberon_new_operator(OP_LSS, result, a, b);
1772 }
1773 else if(token == LEQ)
1774 {
1775 expr = oberon_new_operator(OP_LEQ, result, a, b);
1776 }
1777 else if(token == GREAT)
1778 {
1779 expr = oberon_new_operator(OP_GRT, result, a, b);
1780 }
1781 else if(token == GEQ)
1782 {
1783 expr = oberon_new_operator(OP_GEQ, result, a, b);
1784 }
1785 else if(token == OR)
1786 {
1787 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1788 }
1789 else if(token == AND)
1790 {
1791 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1792 }
1793 else
1794 {
1795 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1796 }
1797 }
1798 else if(token == SLASH)
1799 {
1800 oberon_autocast_to_real(ctx, &a);
1801 oberon_autocast_to_real(ctx, &b);
1802 oberon_autocast_binary_op(ctx, &a, &b);
1803 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1804 }
1805 else if(token == DIV)
1806 {
1807 if(a -> result -> class != OBERON_TYPE_INTEGER
1808 || b -> result -> class != OBERON_TYPE_INTEGER)
1809 {
1810 oberon_error(ctx, "operator DIV requires integer type");
1811 }
1812
1813 oberon_autocast_binary_op(ctx, &a, &b);
1814 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
1815 }
1816 else
1817 {
1818 oberon_autocast_binary_op(ctx, &a, &b);
1819
1820 if(token == PLUS)
1821 {
1822 expr = oberon_new_operator(OP_ADD, a -> result, a, b);
1823 }
1824 else if(token == MINUS)
1825 {
1826 expr = oberon_new_operator(OP_SUB, a -> result, a, b);
1827 }
1828 else if(token == STAR)
1829 {
1830 expr = oberon_new_operator(OP_MUL, a -> result, a, b);
1831 }
1832 else if(token == MOD)
1833 {
1834 expr = oberon_new_operator(OP_MOD, a -> result, a, b);
1835 }
1836 else
1837 {
1838 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1839 }
1840 }
1841
1842 return expr;
1843 }
1844
1845 #define ISMULOP(x) \
1846 ((x) >= STAR && (x) <= AND)
1847
1848 static oberon_expr_t *
1849 oberon_term_expr(oberon_context_t * ctx)
1850 {
1851 oberon_expr_t * expr;
1852
1853 expr = oberon_factor(ctx);
1854 while(ISMULOP(ctx -> token))
1855 {
1856 int token = ctx -> token;
1857 oberon_read_token(ctx);
1858
1859 oberon_expr_t * inter = oberon_factor(ctx);
1860 expr = oberon_make_bin_op(ctx, token, expr, inter);
1861 }
1862
1863 return expr;
1864 }
1865
1866 #define ISADDOP(x) \
1867 ((x) >= PLUS && (x) <= OR)
1868
1869 static oberon_expr_t *
1870 oberon_simple_expr(oberon_context_t * ctx)
1871 {
1872 oberon_expr_t * expr;
1873
1874 int minus = 0;
1875 if(ctx -> token == PLUS)
1876 {
1877 minus = 0;
1878 oberon_assert_token(ctx, PLUS);
1879 }
1880 else if(ctx -> token == MINUS)
1881 {
1882 minus = 1;
1883 oberon_assert_token(ctx, MINUS);
1884 }
1885
1886 expr = oberon_term_expr(ctx);
1887
1888 if(minus)
1889 {
1890 expr = oberon_make_unary_op(ctx, MINUS, expr);
1891 }
1892
1893 while(ISADDOP(ctx -> token))
1894 {
1895 int token = ctx -> token;
1896 oberon_read_token(ctx);
1897
1898 oberon_expr_t * inter = oberon_term_expr(ctx);
1899 expr = oberon_make_bin_op(ctx, token, expr, inter);
1900 }
1901
1902 return expr;
1903 }
1904
1905 #define ISRELATION(x) \
1906 ((x) >= EQUAL && (x) <= IS)
1907
1908 static oberon_expr_t *
1909 oberon_expr(oberon_context_t * ctx)
1910 {
1911 oberon_expr_t * expr;
1912
1913 expr = oberon_simple_expr(ctx);
1914 while(ISRELATION(ctx -> token))
1915 {
1916 int token = ctx -> token;
1917 oberon_read_token(ctx);
1918
1919 oberon_expr_t * inter = oberon_simple_expr(ctx);
1920 expr = oberon_make_bin_op(ctx, token, expr, inter);
1921 }
1922
1923 return expr;
1924 }
1925
1926 static oberon_item_t *
1927 oberon_const_expr(oberon_context_t * ctx)
1928 {
1929 oberon_expr_t * expr;
1930 expr = oberon_expr(ctx);
1931
1932 if(expr -> is_item == 0)
1933 {
1934 oberon_error(ctx, "const expression are required");
1935 }
1936
1937 switch(expr -> item.mode)
1938 {
1939 case MODE_INTEGER:
1940 case MODE_BOOLEAN:
1941 case MODE_NIL:
1942 case MODE_REAL:
1943 case MODE_CHAR:
1944 case MODE_STRING:
1945 /* accept */
1946 break;
1947 default:
1948 oberon_error(ctx, "const expression are required");
1949 break;
1950 }
1951
1952 return (oberon_item_t *) expr;
1953 }
1954
1955 // =======================================================================
1956 // PARSER
1957 // =======================================================================
1958
1959 static void oberon_decl_seq(oberon_context_t * ctx);
1960 static void oberon_statement_seq(oberon_context_t * ctx);
1961 static void oberon_initialize_decl(oberon_context_t * ctx);
1962
1963 static void
1964 oberon_expect_token(oberon_context_t * ctx, int token)
1965 {
1966 if(ctx -> token != token)
1967 {
1968 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1969 }
1970 }
1971
1972 static void
1973 oberon_assert_token(oberon_context_t * ctx, int token)
1974 {
1975 oberon_expect_token(ctx, token);
1976 oberon_read_token(ctx);
1977 }
1978
1979 static char *
1980 oberon_assert_ident(oberon_context_t * ctx)
1981 {
1982 oberon_expect_token(ctx, IDENT);
1983 char * ident = ctx -> string;
1984 oberon_read_token(ctx);
1985 return ident;
1986 }
1987
1988 static void
1989 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
1990 {
1991 switch(ctx -> token)
1992 {
1993 case STAR:
1994 oberon_assert_token(ctx, STAR);
1995 *export = 1;
1996 *read_only = 0;
1997 break;
1998 case MINUS:
1999 oberon_assert_token(ctx, MINUS);
2000 *export = 1;
2001 *read_only = 1;
2002 break;
2003 default:
2004 *export = 0;
2005 *read_only = 0;
2006 break;
2007 }
2008 }
2009
2010 static oberon_object_t *
2011 oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
2012 {
2013 char * name;
2014 int export;
2015 int read_only;
2016 oberon_object_t * x;
2017
2018 name = oberon_assert_ident(ctx);
2019 oberon_def(ctx, &export, &read_only);
2020
2021 x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
2022 return x;
2023 }
2024
2025 static void
2026 oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
2027 {
2028 *num = 1;
2029 *list = oberon_ident_def(ctx, class, check_upscope);
2030 while(ctx -> token == COMMA)
2031 {
2032 oberon_assert_token(ctx, COMMA);
2033 oberon_ident_def(ctx, class, check_upscope);
2034 *num += 1;
2035 }
2036 }
2037
2038 static void
2039 oberon_var_decl(oberon_context_t * ctx)
2040 {
2041 int num;
2042 oberon_object_t * list;
2043 oberon_type_t * type;
2044 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2045
2046 oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
2047 oberon_assert_token(ctx, COLON);
2048 oberon_type(ctx, &type);
2049
2050 oberon_object_t * var = list;
2051 for(int i = 0; i < num; i++)
2052 {
2053 var -> type = type;
2054 var = var -> next;
2055 }
2056 }
2057
2058 static oberon_object_t *
2059 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
2060 {
2061 int class = OBERON_CLASS_PARAM;
2062 if(ctx -> token == VAR)
2063 {
2064 oberon_read_token(ctx);
2065 class = OBERON_CLASS_VAR_PARAM;
2066 }
2067
2068 int num;
2069 oberon_object_t * list;
2070 oberon_ident_list(ctx, class, false, &num, &list);
2071
2072 oberon_assert_token(ctx, COLON);
2073
2074 oberon_type_t * type;
2075 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2076 oberon_type(ctx, &type);
2077
2078 oberon_object_t * param = list;
2079 for(int i = 0; i < num; i++)
2080 {
2081 param -> type = type;
2082 param = param -> next;
2083 }
2084
2085 *num_decl += num;
2086 return list;
2087 }
2088
2089 #define ISFPSECTION \
2090 ((ctx -> token == VAR) || (ctx -> token == IDENT))
2091
2092 static void
2093 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
2094 {
2095 oberon_assert_token(ctx, LPAREN);
2096
2097 if(ISFPSECTION)
2098 {
2099 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
2100 while(ctx -> token == SEMICOLON)
2101 {
2102 oberon_assert_token(ctx, SEMICOLON);
2103 oberon_fp_section(ctx, &signature -> num_decl);
2104 }
2105 }
2106
2107 oberon_assert_token(ctx, RPAREN);
2108
2109 if(ctx -> token == COLON)
2110 {
2111 oberon_assert_token(ctx, COLON);
2112
2113 oberon_object_t * typeobj;
2114 typeobj = oberon_qualident(ctx, NULL, 1);
2115 if(typeobj -> class != OBERON_CLASS_TYPE)
2116 {
2117 oberon_error(ctx, "function result is not type");
2118 }
2119 signature -> base = typeobj -> type;
2120 }
2121 }
2122
2123 static void
2124 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
2125 {
2126 oberon_type_t * signature;
2127 signature = *type;
2128 signature -> class = OBERON_TYPE_PROCEDURE;
2129 signature -> num_decl = 0;
2130 signature -> base = ctx -> void_type;
2131 signature -> decl = NULL;
2132
2133 if(ctx -> token == LPAREN)
2134 {
2135 oberon_formal_pars(ctx, signature);
2136 }
2137 }
2138
2139 static void
2140 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
2141 {
2142 if(a -> num_decl != b -> num_decl)
2143 {
2144 oberon_error(ctx, "number parameters not matched");
2145 }
2146
2147 int num_param = a -> num_decl;
2148 oberon_object_t * param_a = a -> decl;
2149 oberon_object_t * param_b = b -> decl;
2150 for(int i = 0; i < num_param; i++)
2151 {
2152 if(strcmp(param_a -> name, param_b -> name) != 0)
2153 {
2154 oberon_error(ctx, "param %i name not matched", i + 1);
2155 }
2156
2157 if(param_a -> type != param_b -> type)
2158 {
2159 oberon_error(ctx, "param %i type not matched", i + 1);
2160 }
2161
2162 param_a = param_a -> next;
2163 param_b = param_b -> next;
2164 }
2165 }
2166
2167 static void
2168 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
2169 {
2170 oberon_object_t * proc = ctx -> decl -> parent;
2171 oberon_type_t * result_type = proc -> type -> base;
2172
2173 if(result_type -> class == OBERON_TYPE_VOID)
2174 {
2175 if(expr != NULL)
2176 {
2177 oberon_error(ctx, "procedure has no result type");
2178 }
2179 }
2180 else
2181 {
2182 if(expr == NULL)
2183 {
2184 oberon_error(ctx, "procedure requires expression on result");
2185 }
2186
2187 expr = oberon_autocast_to(ctx, expr, result_type);
2188 }
2189
2190 proc -> has_return = 1;
2191
2192 oberon_generate_return(ctx, expr);
2193 }
2194
2195 static void
2196 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
2197 {
2198 oberon_assert_token(ctx, SEMICOLON);
2199
2200 ctx -> decl = proc -> scope;
2201
2202 oberon_decl_seq(ctx);
2203
2204 oberon_generate_begin_proc(ctx, proc);
2205
2206 if(ctx -> token == BEGIN)
2207 {
2208 oberon_assert_token(ctx, BEGIN);
2209 oberon_statement_seq(ctx);
2210 }
2211
2212 oberon_assert_token(ctx, END);
2213 char * name = oberon_assert_ident(ctx);
2214 if(strcmp(name, proc -> name) != 0)
2215 {
2216 oberon_error(ctx, "procedure name not matched");
2217 }
2218
2219 if(proc -> type -> base -> class == OBERON_TYPE_VOID
2220 && proc -> has_return == 0)
2221 {
2222 oberon_make_return(ctx, NULL);
2223 }
2224
2225 if(proc -> has_return == 0)
2226 {
2227 oberon_error(ctx, "procedure requires return");
2228 }
2229
2230 oberon_generate_end_proc(ctx);
2231 oberon_close_scope(ctx -> decl);
2232 }
2233
2234 static void
2235 oberon_proc_decl(oberon_context_t * ctx)
2236 {
2237 oberon_assert_token(ctx, PROCEDURE);
2238
2239 int forward = 0;
2240 if(ctx -> token == UPARROW)
2241 {
2242 oberon_assert_token(ctx, UPARROW);
2243 forward = 1;
2244 }
2245
2246 char * name;
2247 int export;
2248 int read_only;
2249 name = oberon_assert_ident(ctx);
2250 oberon_def(ctx, &export, &read_only);
2251
2252 oberon_scope_t * proc_scope;
2253 proc_scope = oberon_open_scope(ctx);
2254 ctx -> decl -> local = 1;
2255
2256 oberon_type_t * signature;
2257 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
2258 oberon_opt_formal_pars(ctx, &signature);
2259
2260 oberon_initialize_decl(ctx);
2261 oberon_generator_init_type(ctx, signature);
2262 oberon_close_scope(ctx -> decl);
2263
2264 oberon_object_t * proc;
2265 proc = oberon_find_object(ctx -> decl, name, 0);
2266 if(proc != NULL)
2267 {
2268 if(proc -> class != OBERON_CLASS_PROC)
2269 {
2270 oberon_error(ctx, "mult definition");
2271 }
2272
2273 if(forward == 0)
2274 {
2275 if(proc -> linked)
2276 {
2277 oberon_error(ctx, "mult procedure definition");
2278 }
2279 }
2280
2281 if(proc -> export != export || proc -> read_only != read_only)
2282 {
2283 oberon_error(ctx, "export type not matched");
2284 }
2285
2286 oberon_compare_signatures(ctx, proc -> type, signature);
2287 }
2288 else
2289 {
2290 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
2291 proc -> type = signature;
2292 proc -> scope = proc_scope;
2293 oberon_generator_init_proc(ctx, proc);
2294 }
2295
2296 proc -> scope -> parent = proc;
2297
2298 if(forward == 0)
2299 {
2300 proc -> linked = 1;
2301 oberon_proc_decl_body(ctx, proc);
2302 }
2303 }
2304
2305 static void
2306 oberon_const_decl(oberon_context_t * ctx)
2307 {
2308 oberon_item_t * value;
2309 oberon_object_t * constant;
2310
2311 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
2312 oberon_assert_token(ctx, EQUAL);
2313 value = oberon_const_expr(ctx);
2314 constant -> value = value;
2315 }
2316
2317 static void
2318 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
2319 {
2320 if(size -> is_item == 0)
2321 {
2322 oberon_error(ctx, "requires constant");
2323 }
2324
2325 if(size -> item.mode != MODE_INTEGER)
2326 {
2327 oberon_error(ctx, "requires integer constant");
2328 }
2329
2330 oberon_type_t * arr;
2331 arr = *type;
2332 arr -> class = OBERON_TYPE_ARRAY;
2333 arr -> size = size -> item.integer;
2334 arr -> base = base;
2335 }
2336
2337 static void
2338 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2339 {
2340 char * name;
2341 oberon_object_t * to;
2342
2343 to = oberon_qualident(ctx, &name, 0);
2344
2345 //name = oberon_assert_ident(ctx);
2346 //to = oberon_find_object(ctx -> decl, name, 0);
2347
2348 if(to != NULL)
2349 {
2350 if(to -> class != OBERON_CLASS_TYPE)
2351 {
2352 oberon_error(ctx, "not a type");
2353 }
2354 }
2355 else
2356 {
2357 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2358 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2359 }
2360
2361 *type = to -> type;
2362 }
2363
2364 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2365
2366 /*
2367 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2368 */
2369
2370 static void
2371 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2372 {
2373 if(sizes == NULL)
2374 {
2375 *type = base;
2376 return;
2377 }
2378
2379 oberon_type_t * dim;
2380 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2381
2382 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2383
2384 oberon_make_array_type(ctx, sizes, dim, type);
2385 }
2386
2387 static void
2388 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2389 {
2390 type -> class = OBERON_TYPE_ARRAY;
2391 type -> size = 0;
2392 type -> base = base;
2393 }
2394
2395 static void
2396 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2397 {
2398 if(ctx -> token == IDENT)
2399 {
2400 int num;
2401 oberon_object_t * list;
2402 oberon_type_t * type;
2403 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2404
2405 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2406 oberon_assert_token(ctx, COLON);
2407
2408 oberon_scope_t * current = ctx -> decl;
2409 ctx -> decl = modscope;
2410 oberon_type(ctx, &type);
2411 ctx -> decl = current;
2412
2413 oberon_object_t * field = list;
2414 for(int i = 0; i < num; i++)
2415 {
2416 field -> type = type;
2417 field = field -> next;
2418 }
2419
2420 rec -> num_decl += num;
2421 }
2422 }
2423
2424 static void
2425 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2426 {
2427 oberon_scope_t * modscope = ctx -> mod -> decl;
2428 oberon_scope_t * oldscope = ctx -> decl;
2429 ctx -> decl = modscope;
2430
2431 if(ctx -> token == LPAREN)
2432 {
2433 oberon_assert_token(ctx, LPAREN);
2434
2435 oberon_object_t * typeobj;
2436 typeobj = oberon_qualident(ctx, NULL, true);
2437
2438 if(typeobj -> class != OBERON_CLASS_TYPE)
2439 {
2440 oberon_error(ctx, "base must be type");
2441 }
2442
2443 oberon_type_t * base = typeobj -> type;
2444 if(base -> class == OBERON_TYPE_POINTER)
2445 {
2446 base = base -> base;
2447 }
2448
2449 if(base -> class != OBERON_TYPE_RECORD)
2450 {
2451 oberon_error(ctx, "base must be record type");
2452 }
2453
2454 rec -> base = base;
2455 ctx -> decl = base -> scope;
2456
2457 oberon_assert_token(ctx, RPAREN);
2458 }
2459 else
2460 {
2461 ctx -> decl = NULL;
2462 }
2463
2464 oberon_scope_t * this_scope;
2465 this_scope = oberon_open_scope(ctx);
2466 this_scope -> local = true;
2467 this_scope -> parent = NULL;
2468 this_scope -> parent_type = rec;
2469
2470 oberon_field_list(ctx, rec, modscope);
2471 while(ctx -> token == SEMICOLON)
2472 {
2473 oberon_assert_token(ctx, SEMICOLON);
2474 oberon_field_list(ctx, rec, modscope);
2475 }
2476
2477 rec -> scope = this_scope;
2478 rec -> decl = this_scope -> list -> next;
2479 ctx -> decl = oldscope;
2480 }
2481
2482 static void
2483 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2484 {
2485 if(ctx -> token == IDENT)
2486 {
2487 oberon_qualident_type(ctx, type);
2488 }
2489 else if(ctx -> token == ARRAY)
2490 {
2491 oberon_assert_token(ctx, ARRAY);
2492
2493 int num_sizes = 0;
2494 oberon_expr_t * sizes;
2495
2496 if(ISEXPR(ctx -> token))
2497 {
2498 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2499 }
2500
2501 oberon_assert_token(ctx, OF);
2502
2503 oberon_type_t * base;
2504 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2505 oberon_type(ctx, &base);
2506
2507 if(num_sizes == 0)
2508 {
2509 oberon_make_open_array(ctx, base, *type);
2510 }
2511 else
2512 {
2513 oberon_make_multiarray(ctx, sizes, base, type);
2514 }
2515 }
2516 else if(ctx -> token == RECORD)
2517 {
2518 oberon_type_t * rec;
2519 rec = *type;
2520 rec -> class = OBERON_TYPE_RECORD;
2521 rec -> module = ctx -> mod;
2522
2523 oberon_assert_token(ctx, RECORD);
2524 oberon_type_record_body(ctx, rec);
2525 oberon_assert_token(ctx, END);
2526
2527 *type = rec;
2528 }
2529 else if(ctx -> token == POINTER)
2530 {
2531 oberon_assert_token(ctx, POINTER);
2532 oberon_assert_token(ctx, TO);
2533
2534 oberon_type_t * base;
2535 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2536 oberon_type(ctx, &base);
2537
2538 oberon_type_t * ptr;
2539 ptr = *type;
2540 ptr -> class = OBERON_TYPE_POINTER;
2541 ptr -> base = base;
2542 }
2543 else if(ctx -> token == PROCEDURE)
2544 {
2545 oberon_open_scope(ctx);
2546 oberon_assert_token(ctx, PROCEDURE);
2547 oberon_opt_formal_pars(ctx, type);
2548 oberon_close_scope(ctx -> decl);
2549 }
2550 else
2551 {
2552 oberon_error(ctx, "invalid type declaration");
2553 }
2554 }
2555
2556 static void
2557 oberon_type_decl(oberon_context_t * ctx)
2558 {
2559 char * name;
2560 oberon_object_t * newtype;
2561 oberon_type_t * type;
2562 int export;
2563 int read_only;
2564
2565 name = oberon_assert_ident(ctx);
2566 oberon_def(ctx, &export, &read_only);
2567
2568 newtype = oberon_find_object(ctx -> decl, name, 0);
2569 if(newtype == NULL)
2570 {
2571 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2572 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2573 assert(newtype -> type);
2574 }
2575 else
2576 {
2577 if(newtype -> class != OBERON_CLASS_TYPE)
2578 {
2579 oberon_error(ctx, "mult definition");
2580 }
2581
2582 if(newtype -> linked)
2583 {
2584 oberon_error(ctx, "mult definition - already linked");
2585 }
2586
2587 newtype -> export = export;
2588 newtype -> read_only = read_only;
2589 }
2590
2591 oberon_assert_token(ctx, EQUAL);
2592
2593 type = newtype -> type;
2594 oberon_type(ctx, &type);
2595
2596 if(type -> class == OBERON_TYPE_VOID)
2597 {
2598 oberon_error(ctx, "recursive alias declaration");
2599 }
2600
2601 newtype -> type = type;
2602 newtype -> linked = 1;
2603 }
2604
2605 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2606 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2607
2608 static void
2609 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2610 {
2611 if(type -> class != OBERON_TYPE_POINTER
2612 && type -> class != OBERON_TYPE_ARRAY)
2613 {
2614 return;
2615 }
2616
2617 if(type -> recursive)
2618 {
2619 oberon_error(ctx, "recursive pointer declaration");
2620 }
2621
2622 if(type -> class == OBERON_TYPE_POINTER
2623 && type -> base -> class == OBERON_TYPE_POINTER)
2624 {
2625 oberon_error(ctx, "attempt to make pointer to pointer");
2626 }
2627
2628 type -> recursive = 1;
2629
2630 oberon_prevent_recursive_pointer(ctx, type -> base);
2631
2632 type -> recursive = 0;
2633 }
2634
2635 static void
2636 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2637 {
2638 if(type -> class != OBERON_TYPE_RECORD)
2639 {
2640 return;
2641 }
2642
2643 if(type -> recursive)
2644 {
2645 oberon_error(ctx, "recursive record declaration");
2646 }
2647
2648 type -> recursive = 1;
2649
2650 int num_fields = type -> num_decl;
2651 oberon_object_t * field = type -> decl;
2652 for(int i = 0; i < num_fields; i++)
2653 {
2654 oberon_prevent_recursive_object(ctx, field);
2655 field = field -> next;
2656 }
2657
2658 type -> recursive = 0;
2659 }
2660 static void
2661 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2662 {
2663 if(type -> class != OBERON_TYPE_PROCEDURE)
2664 {
2665 return;
2666 }
2667
2668 if(type -> recursive)
2669 {
2670 oberon_error(ctx, "recursive procedure declaration");
2671 }
2672
2673 type -> recursive = 1;
2674
2675 int num_fields = type -> num_decl;
2676 oberon_object_t * field = type -> decl;
2677 for(int i = 0; i < num_fields; i++)
2678 {
2679 oberon_prevent_recursive_object(ctx, field);
2680 field = field -> next;
2681 }
2682
2683 type -> recursive = 0;
2684 }
2685
2686 static void
2687 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2688 {
2689 if(type -> class != OBERON_TYPE_ARRAY)
2690 {
2691 return;
2692 }
2693
2694 if(type -> recursive)
2695 {
2696 oberon_error(ctx, "recursive array declaration");
2697 }
2698
2699 type -> recursive = 1;
2700
2701 oberon_prevent_recursive_type(ctx, type -> base);
2702
2703 type -> recursive = 0;
2704 }
2705
2706 static void
2707 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2708 {
2709 if(type -> class == OBERON_TYPE_POINTER)
2710 {
2711 oberon_prevent_recursive_pointer(ctx, type);
2712 }
2713 else if(type -> class == OBERON_TYPE_RECORD)
2714 {
2715 oberon_prevent_recursive_record(ctx, type);
2716 }
2717 else if(type -> class == OBERON_TYPE_ARRAY)
2718 {
2719 oberon_prevent_recursive_array(ctx, type);
2720 }
2721 else if(type -> class == OBERON_TYPE_PROCEDURE)
2722 {
2723 oberon_prevent_recursive_procedure(ctx, type);
2724 }
2725 }
2726
2727 static void
2728 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2729 {
2730 switch(x -> class)
2731 {
2732 case OBERON_CLASS_VAR:
2733 case OBERON_CLASS_TYPE:
2734 case OBERON_CLASS_PARAM:
2735 case OBERON_CLASS_VAR_PARAM:
2736 case OBERON_CLASS_FIELD:
2737 oberon_prevent_recursive_type(ctx, x -> type);
2738 break;
2739 case OBERON_CLASS_CONST:
2740 case OBERON_CLASS_PROC:
2741 case OBERON_CLASS_MODULE:
2742 break;
2743 default:
2744 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2745 break;
2746 }
2747 }
2748
2749 static void
2750 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2751 {
2752 oberon_object_t * x = ctx -> decl -> list -> next;
2753
2754 while(x)
2755 {
2756 oberon_prevent_recursive_object(ctx, x);
2757 x = x -> next;
2758 }
2759 }
2760
2761 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2762 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2763
2764 static void
2765 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2766 {
2767 if(type -> class != OBERON_TYPE_RECORD)
2768 {
2769 return;
2770 }
2771
2772 int num_fields = type -> num_decl;
2773 oberon_object_t * field = type -> decl;
2774 for(int i = 0; i < num_fields; i++)
2775 {
2776 if(field -> type -> class == OBERON_TYPE_POINTER)
2777 {
2778 oberon_initialize_type(ctx, field -> type);
2779 }
2780
2781 oberon_initialize_object(ctx, field);
2782 field = field -> next;
2783 }
2784
2785 oberon_generator_init_record(ctx, type);
2786 }
2787
2788 static void
2789 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2790 {
2791 if(type -> class == OBERON_TYPE_VOID)
2792 {
2793 oberon_error(ctx, "undeclarated type");
2794 }
2795
2796 if(type -> initialized)
2797 {
2798 return;
2799 }
2800
2801 type -> initialized = 1;
2802
2803 if(type -> class == OBERON_TYPE_POINTER)
2804 {
2805 oberon_initialize_type(ctx, type -> base);
2806 oberon_generator_init_type(ctx, type);
2807 }
2808 else if(type -> class == OBERON_TYPE_ARRAY)
2809 {
2810 if(type -> size != 0)
2811 {
2812 if(type -> base -> class == OBERON_TYPE_ARRAY)
2813 {
2814 if(type -> base -> size == 0)
2815 {
2816 oberon_error(ctx, "open array not allowed as array element");
2817 }
2818 }
2819 }
2820
2821 oberon_initialize_type(ctx, type -> base);
2822 oberon_generator_init_type(ctx, type);
2823 }
2824 else if(type -> class == OBERON_TYPE_RECORD)
2825 {
2826 oberon_generator_init_type(ctx, type);
2827 oberon_initialize_record_fields(ctx, type);
2828 }
2829 else if(type -> class == OBERON_TYPE_PROCEDURE)
2830 {
2831 int num_fields = type -> num_decl;
2832 oberon_object_t * field = type -> decl;
2833 for(int i = 0; i < num_fields; i++)
2834 {
2835 oberon_initialize_object(ctx, field);
2836 field = field -> next;
2837 }
2838
2839 oberon_generator_init_type(ctx, type);
2840 }
2841 else
2842 {
2843 oberon_generator_init_type(ctx, type);
2844 }
2845 }
2846
2847 static void
2848 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2849 {
2850 if(x -> initialized)
2851 {
2852 return;
2853 }
2854
2855 x -> initialized = 1;
2856
2857 switch(x -> class)
2858 {
2859 case OBERON_CLASS_TYPE:
2860 oberon_initialize_type(ctx, x -> type);
2861 break;
2862 case OBERON_CLASS_VAR:
2863 case OBERON_CLASS_FIELD:
2864 if(x -> type -> class == OBERON_TYPE_ARRAY)
2865 {
2866 if(x -> type -> size == 0)
2867 {
2868 oberon_error(ctx, "open array not allowed as variable or field");
2869 }
2870 }
2871 oberon_initialize_type(ctx, x -> type);
2872 oberon_generator_init_var(ctx, x);
2873 break;
2874 case OBERON_CLASS_PARAM:
2875 case OBERON_CLASS_VAR_PARAM:
2876 oberon_initialize_type(ctx, x -> type);
2877 oberon_generator_init_var(ctx, x);
2878 break;
2879 case OBERON_CLASS_CONST:
2880 case OBERON_CLASS_PROC:
2881 case OBERON_CLASS_MODULE:
2882 break;
2883 default:
2884 oberon_error(ctx, "oberon_initialize_object: wat");
2885 break;
2886 }
2887 }
2888
2889 static void
2890 oberon_initialize_decl(oberon_context_t * ctx)
2891 {
2892 oberon_object_t * x = ctx -> decl -> list;
2893
2894 while(x -> next)
2895 {
2896 oberon_initialize_object(ctx, x -> next);
2897 x = x -> next;
2898 }
2899 }
2900
2901 static void
2902 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2903 {
2904 oberon_object_t * x = ctx -> decl -> list;
2905
2906 while(x -> next)
2907 {
2908 if(x -> next -> class == OBERON_CLASS_PROC)
2909 {
2910 if(x -> next -> linked == 0)
2911 {
2912 oberon_error(ctx, "unresolved forward declaration");
2913 }
2914 }
2915 x = x -> next;
2916 }
2917 }
2918
2919 static void
2920 oberon_decl_seq(oberon_context_t * ctx)
2921 {
2922 if(ctx -> token == CONST)
2923 {
2924 oberon_assert_token(ctx, CONST);
2925 while(ctx -> token == IDENT)
2926 {
2927 oberon_const_decl(ctx);
2928 oberon_assert_token(ctx, SEMICOLON);
2929 }
2930 }
2931
2932 if(ctx -> token == TYPE)
2933 {
2934 oberon_assert_token(ctx, TYPE);
2935 while(ctx -> token == IDENT)
2936 {
2937 oberon_type_decl(ctx);
2938 oberon_assert_token(ctx, SEMICOLON);
2939 }
2940 }
2941
2942 if(ctx -> token == VAR)
2943 {
2944 oberon_assert_token(ctx, VAR);
2945 while(ctx -> token == IDENT)
2946 {
2947 oberon_var_decl(ctx);
2948 oberon_assert_token(ctx, SEMICOLON);
2949 }
2950 }
2951
2952 oberon_prevent_recursive_decl(ctx);
2953 oberon_initialize_decl(ctx);
2954
2955 while(ctx -> token == PROCEDURE)
2956 {
2957 oberon_proc_decl(ctx);
2958 oberon_assert_token(ctx, SEMICOLON);
2959 }
2960
2961 oberon_prevent_undeclarated_procedures(ctx);
2962 }
2963
2964 static oberon_expr_t *
2965 oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type)
2966 {
2967 oberon_object_t * x;
2968 oberon_expr_t * expr;
2969
2970 x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false);
2971 x -> local = true;
2972 x -> type = type;
2973 oberon_generator_init_temp_var(ctx, x);
2974
2975 expr = oberon_new_item(MODE_VAR, type, false);
2976 expr -> item.var = x;
2977 return expr;
2978 }
2979
2980 static void
2981 oberon_statement_seq(oberon_context_t * ctx);
2982
2983 static void
2984 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2985 {
2986 if(dst -> read_only)
2987 {
2988 oberon_error(ctx, "read-only destination");
2989 }
2990
2991 src = oberon_autocast_to(ctx, src, dst -> result);
2992 oberon_generate_assign(ctx, src, dst);
2993 }
2994
2995 static void
2996 oberon_statement(oberon_context_t * ctx)
2997 {
2998 oberon_expr_t * item1;
2999 oberon_expr_t * item2;
3000
3001 if(ctx -> token == IDENT)
3002 {
3003 item1 = oberon_designator(ctx);
3004 if(ctx -> token == ASSIGN)
3005 {
3006 oberon_assert_token(ctx, ASSIGN);
3007 item2 = oberon_expr(ctx);
3008 oberon_assign(ctx, item2, item1);
3009 }
3010 else
3011 {
3012 oberon_opt_proc_parens(ctx, item1);
3013 }
3014 }
3015 else if(ctx -> token == IF)
3016 {
3017 gen_label_t * end;
3018 gen_label_t * els;
3019 oberon_expr_t * cond;
3020
3021 els = oberon_generator_reserve_label(ctx);
3022 end = oberon_generator_reserve_label(ctx);
3023
3024 oberon_assert_token(ctx, IF);
3025 cond = oberon_expr(ctx);
3026 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3027 {
3028 oberon_error(ctx, "condition must be boolean");
3029 }
3030 oberon_assert_token(ctx, THEN);
3031 oberon_generate_branch(ctx, cond, false, els);
3032 oberon_statement_seq(ctx);
3033 oberon_generate_goto(ctx, end);
3034 oberon_generate_label(ctx, els);
3035
3036 while(ctx -> token == ELSIF)
3037 {
3038 els = oberon_generator_reserve_label(ctx);
3039
3040 oberon_assert_token(ctx, ELSIF);
3041 cond = oberon_expr(ctx);
3042 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3043 {
3044 oberon_error(ctx, "condition must be boolean");
3045 }
3046 oberon_assert_token(ctx, THEN);
3047 oberon_generate_branch(ctx, cond, false, els);
3048 oberon_statement_seq(ctx);
3049 oberon_generate_goto(ctx, end);
3050 oberon_generate_label(ctx, els);
3051 }
3052
3053 if(ctx -> token == ELSE)
3054 {
3055 oberon_assert_token(ctx, ELSE);
3056 oberon_statement_seq(ctx);
3057 }
3058
3059 oberon_generate_label(ctx, end);
3060 oberon_assert_token(ctx, END);
3061 }
3062 else if(ctx -> token == WHILE)
3063 {
3064 gen_label_t * begin;
3065 gen_label_t * end;
3066 oberon_expr_t * cond;
3067
3068 begin = oberon_generator_reserve_label(ctx);
3069 end = oberon_generator_reserve_label(ctx);
3070
3071 oberon_assert_token(ctx, WHILE);
3072 oberon_generate_label(ctx, begin);
3073 cond = oberon_expr(ctx);
3074 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3075 {
3076 oberon_error(ctx, "condition must be boolean");
3077 }
3078 oberon_generate_branch(ctx, cond, false, end);
3079
3080 oberon_assert_token(ctx, DO);
3081 oberon_statement_seq(ctx);
3082 oberon_generate_goto(ctx, begin);
3083
3084 oberon_assert_token(ctx, END);
3085 oberon_generate_label(ctx, end);
3086 }
3087 else if(ctx -> token == REPEAT)
3088 {
3089 gen_label_t * begin;
3090 oberon_expr_t * cond;
3091
3092 begin = oberon_generator_reserve_label(ctx);
3093 oberon_generate_label(ctx, begin);
3094 oberon_assert_token(ctx, REPEAT);
3095
3096 oberon_statement_seq(ctx);
3097
3098 oberon_assert_token(ctx, UNTIL);
3099
3100 cond = oberon_expr(ctx);
3101 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3102 {
3103 oberon_error(ctx, "condition must be boolean");
3104 }
3105
3106 oberon_generate_branch(ctx, cond, true, begin);
3107 }
3108 else if(ctx -> token == FOR)
3109 {
3110 oberon_expr_t * from;
3111 oberon_expr_t * index;
3112 oberon_expr_t * to;
3113 oberon_expr_t * bound;
3114 oberon_expr_t * by;
3115 oberon_expr_t * cond;
3116 oberon_expr_t * count;
3117 gen_label_t * begin;
3118 gen_label_t * end;
3119 char * iname;
3120 int op;
3121
3122 begin = oberon_generator_reserve_label(ctx);
3123 end = oberon_generator_reserve_label(ctx);
3124
3125 oberon_assert_token(ctx, FOR);
3126 iname = oberon_assert_ident(ctx);
3127 index = oberon_ident_item(ctx, iname);
3128 oberon_assert_token(ctx, ASSIGN);
3129 from = oberon_expr(ctx);
3130 oberon_assign(ctx, from, index);
3131 oberon_assert_token(ctx, TO);
3132 bound = oberon_make_temp_var_item(ctx, index -> result);
3133 to = oberon_expr(ctx);
3134 oberon_assign(ctx, to, bound);
3135 if(ctx -> token == BY)
3136 {
3137 oberon_assert_token(ctx, BY);
3138 by = (oberon_expr_t *) oberon_const_expr(ctx);
3139 }
3140 else
3141 {
3142 by = oberon_integer_item(ctx, 1);
3143 }
3144
3145 if(by -> result -> class != OBERON_TYPE_INTEGER)
3146 {
3147 oberon_error(ctx, "must be integer");
3148 }
3149
3150 if(by -> item.integer > 0)
3151 {
3152 op = LEQ;
3153 }
3154 else if(by -> item.integer < 0)
3155 {
3156 op = GEQ;
3157 }
3158 else
3159 {
3160 oberon_error(ctx, "zero step not allowed");
3161 }
3162
3163 oberon_assert_token(ctx, DO);
3164 oberon_generate_label(ctx, begin);
3165 cond = oberon_make_bin_op(ctx, op, index, bound);
3166 oberon_generate_branch(ctx, cond, false, end);
3167 oberon_statement_seq(ctx);
3168 count = oberon_make_bin_op(ctx, PLUS, index, by);
3169 oberon_assign(ctx, count, index);
3170 oberon_generate_goto(ctx, begin);
3171 oberon_generate_label(ctx, end);
3172 oberon_assert_token(ctx, END);
3173 }
3174 else if(ctx -> token == LOOP)
3175 {
3176 gen_label_t * begin;
3177 gen_label_t * end;
3178
3179 begin = oberon_generator_reserve_label(ctx);
3180 end = oberon_generator_reserve_label(ctx);
3181
3182 oberon_open_scope(ctx);
3183 oberon_assert_token(ctx, LOOP);
3184 oberon_generate_label(ctx, begin);
3185 ctx -> decl -> exit_label = end;
3186 oberon_statement_seq(ctx);
3187 oberon_generate_goto(ctx, begin);
3188 oberon_generate_label(ctx, end);
3189 oberon_assert_token(ctx, END);
3190 oberon_close_scope(ctx -> decl);
3191 }
3192 else if(ctx -> token == EXIT)
3193 {
3194 oberon_assert_token(ctx, EXIT);
3195 if(ctx -> decl -> exit_label == NULL)
3196 {
3197 oberon_error(ctx, "not in LOOP-END");
3198 }
3199 oberon_generate_goto(ctx, ctx -> decl -> exit_label);
3200 }
3201 else if(ctx -> token == RETURN)
3202 {
3203 oberon_assert_token(ctx, RETURN);
3204 if(ISEXPR(ctx -> token))
3205 {
3206 oberon_expr_t * expr;
3207 expr = oberon_expr(ctx);
3208 oberon_make_return(ctx, expr);
3209 }
3210 else
3211 {
3212 oberon_make_return(ctx, NULL);
3213 }
3214 }
3215 }
3216
3217 static void
3218 oberon_statement_seq(oberon_context_t * ctx)
3219 {
3220 oberon_statement(ctx);
3221 while(ctx -> token == SEMICOLON)
3222 {
3223 oberon_assert_token(ctx, SEMICOLON);
3224 oberon_statement(ctx);
3225 }
3226 }
3227
3228 static void
3229 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
3230 {
3231 oberon_module_t * m = ctx -> module_list;
3232 while(m && strcmp(m -> name, name) != 0)
3233 {
3234 m = m -> next;
3235 }
3236
3237 if(m == NULL)
3238 {
3239 const char * code;
3240 code = ctx -> import_module(name);
3241 if(code == NULL)
3242 {
3243 oberon_error(ctx, "no such module");
3244 }
3245
3246 m = oberon_compile_module(ctx, code);
3247 assert(m);
3248 }
3249
3250 if(m -> ready == 0)
3251 {
3252 oberon_error(ctx, "cyclic module import");
3253 }
3254
3255 oberon_object_t * ident;
3256 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
3257 ident -> module = m;
3258 }
3259
3260 static void
3261 oberon_import_decl(oberon_context_t * ctx)
3262 {
3263 char * alias;
3264 char * name;
3265
3266 alias = name = oberon_assert_ident(ctx);
3267 if(ctx -> token == ASSIGN)
3268 {
3269 oberon_assert_token(ctx, ASSIGN);
3270 name = oberon_assert_ident(ctx);
3271 }
3272
3273 oberon_import_module(ctx, alias, name);
3274 }
3275
3276 static void
3277 oberon_import_list(oberon_context_t * ctx)
3278 {
3279 oberon_assert_token(ctx, IMPORT);
3280
3281 oberon_import_decl(ctx);
3282 while(ctx -> token == COMMA)
3283 {
3284 oberon_assert_token(ctx, COMMA);
3285 oberon_import_decl(ctx);
3286 }
3287
3288 oberon_assert_token(ctx, SEMICOLON);
3289 }
3290
3291 static void
3292 oberon_parse_module(oberon_context_t * ctx)
3293 {
3294 char * name1;
3295 char * name2;
3296 oberon_read_token(ctx);
3297
3298 oberon_assert_token(ctx, MODULE);
3299 name1 = oberon_assert_ident(ctx);
3300 oberon_assert_token(ctx, SEMICOLON);
3301 ctx -> mod -> name = name1;
3302
3303 oberon_generator_init_module(ctx, ctx -> mod);
3304
3305 if(ctx -> token == IMPORT)
3306 {
3307 oberon_import_list(ctx);
3308 }
3309
3310 oberon_decl_seq(ctx);
3311
3312 oberon_generate_begin_module(ctx);
3313 if(ctx -> token == BEGIN)
3314 {
3315 oberon_assert_token(ctx, BEGIN);
3316 oberon_statement_seq(ctx);
3317 }
3318 oberon_generate_end_module(ctx);
3319
3320 oberon_assert_token(ctx, END);
3321 name2 = oberon_assert_ident(ctx);
3322 oberon_assert_token(ctx, DOT);
3323
3324 if(strcmp(name1, name2) != 0)
3325 {
3326 oberon_error(ctx, "module name not matched");
3327 }
3328
3329 oberon_generator_fini_module(ctx -> mod);
3330 }
3331
3332 // =======================================================================
3333 // LIBRARY
3334 // =======================================================================
3335
3336 static void
3337 register_default_types(oberon_context_t * ctx)
3338 {
3339 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
3340 oberon_generator_init_type(ctx, ctx -> void_type);
3341
3342 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
3343 ctx -> void_ptr_type -> base = ctx -> void_type;
3344 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
3345
3346 ctx -> string_type = oberon_new_type_string(1);
3347 oberon_generator_init_type(ctx, ctx -> string_type);
3348
3349 ctx -> bool_type = oberon_new_type_boolean();
3350 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
3351
3352 ctx -> byte_type = oberon_new_type_integer(1);
3353 oberon_define_type(ctx -> world_scope, "BYTE", ctx -> byte_type, 1);
3354
3355 ctx -> shortint_type = oberon_new_type_integer(2);
3356 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> shortint_type, 1);
3357
3358 ctx -> int_type = oberon_new_type_integer(4);
3359 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
3360
3361 ctx -> longint_type = oberon_new_type_integer(8);
3362 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> longint_type, 1);
3363
3364 ctx -> real_type = oberon_new_type_real(4);
3365 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
3366
3367 ctx -> longreal_type = oberon_new_type_real(8);
3368 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
3369
3370 ctx -> char_type = oberon_new_type_char(1);
3371 oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1);
3372 }
3373
3374 static void
3375 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
3376 {
3377 oberon_object_t * proc;
3378 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
3379 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
3380 proc -> type -> sysproc = true;
3381 proc -> type -> genfunc = f;
3382 proc -> type -> genproc = p;
3383 }
3384
3385 static oberon_expr_t *
3386 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3387 {
3388 if(num_args < 1)
3389 {
3390 oberon_error(ctx, "too few arguments");
3391 }
3392
3393 if(num_args > 1)
3394 {
3395 oberon_error(ctx, "too mach arguments");
3396 }
3397
3398 oberon_expr_t * arg;
3399 arg = list_args;
3400
3401 oberon_type_t * result_type;
3402 result_type = arg -> result;
3403
3404 if(result_type -> class != OBERON_TYPE_INTEGER)
3405 {
3406 oberon_error(ctx, "ABS accepts only integers");
3407 }
3408
3409
3410 oberon_expr_t * expr;
3411 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
3412 return expr;
3413 }
3414
3415 static void
3416 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3417 {
3418 if(num_args < 1)
3419 {
3420 oberon_error(ctx, "too few arguments");
3421 }
3422
3423 oberon_expr_t * dst;
3424 dst = list_args;
3425
3426 oberon_type_t * type;
3427 type = dst -> result;
3428
3429 if(type -> class != OBERON_TYPE_POINTER)
3430 {
3431 oberon_error(ctx, "not a pointer");
3432 }
3433
3434 type = type -> base;
3435
3436 oberon_expr_t * src;
3437 src = oberon_new_item(MODE_NEW, dst -> result, 0);
3438 src -> item.num_args = 0;
3439 src -> item.args = NULL;
3440
3441 int max_args = 1;
3442 if(type -> class == OBERON_TYPE_ARRAY)
3443 {
3444 if(type -> size == 0)
3445 {
3446 oberon_type_t * x = type;
3447 while(x -> class == OBERON_TYPE_ARRAY)
3448 {
3449 if(x -> size == 0)
3450 {
3451 max_args += 1;
3452 }
3453 x = x -> base;
3454 }
3455 }
3456
3457 if(num_args < max_args)
3458 {
3459 oberon_error(ctx, "too few arguments");
3460 }
3461
3462 if(num_args > max_args)
3463 {
3464 oberon_error(ctx, "too mach arguments");
3465 }
3466
3467 int num_sizes = max_args - 1;
3468 oberon_expr_t * size_list = list_args -> next;
3469
3470 oberon_expr_t * arg = size_list;
3471 for(int i = 0; i < max_args - 1; i++)
3472 {
3473 if(arg -> result -> class != OBERON_TYPE_INTEGER)
3474 {
3475 oberon_error(ctx, "size must be integer");
3476 }
3477 arg = arg -> next;
3478 }
3479
3480 src -> item.num_args = num_sizes;
3481 src -> item.args = size_list;
3482 }
3483 else if(type -> class != OBERON_TYPE_RECORD)
3484 {
3485 oberon_error(ctx, "oberon_make_new_call: wat");
3486 }
3487
3488 if(num_args > max_args)
3489 {
3490 oberon_error(ctx, "too mach arguments");
3491 }
3492
3493 oberon_assign(ctx, src, dst);
3494 }
3495
3496 oberon_context_t *
3497 oberon_create_context(ModuleImportCallback import_module)
3498 {
3499 oberon_context_t * ctx = calloc(1, sizeof *ctx);
3500
3501 oberon_scope_t * world_scope;
3502 world_scope = oberon_open_scope(ctx);
3503 ctx -> world_scope = world_scope;
3504
3505 ctx -> import_module = import_module;
3506
3507 oberon_generator_init_context(ctx);
3508
3509 register_default_types(ctx);
3510 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
3511 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
3512
3513 return ctx;
3514 }
3515
3516 void
3517 oberon_destroy_context(oberon_context_t * ctx)
3518 {
3519 oberon_generator_destroy_context(ctx);
3520 free(ctx);
3521 }
3522
3523 oberon_module_t *
3524 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
3525 {
3526 const char * code = ctx -> code;
3527 int code_index = ctx -> code_index;
3528 char c = ctx -> c;
3529 int token = ctx -> token;
3530 char * string = ctx -> string;
3531 int integer = ctx -> integer;
3532 int real = ctx -> real;
3533 bool longmode = ctx -> longmode;
3534 oberon_scope_t * decl = ctx -> decl;
3535 oberon_module_t * mod = ctx -> mod;
3536
3537 oberon_scope_t * module_scope;
3538 module_scope = oberon_open_scope(ctx);
3539
3540 oberon_module_t * module;
3541 module = calloc(1, sizeof *module);
3542 module -> decl = module_scope;
3543 module -> next = ctx -> module_list;
3544
3545 ctx -> mod = module;
3546 ctx -> module_list = module;
3547
3548 oberon_init_scaner(ctx, newcode);
3549 oberon_parse_module(ctx);
3550
3551 module -> ready = 1;
3552
3553 ctx -> code = code;
3554 ctx -> code_index = code_index;
3555 ctx -> c = c;
3556 ctx -> token = token;
3557 ctx -> string = string;
3558 ctx -> integer = integer;
3559 ctx -> real = real;
3560 ctx -> longmode = longmode;
3561 ctx -> decl = decl;
3562 ctx -> mod = mod;
3563
3564 return module;
3565 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024