DEADSOFTWARE

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