DEADSOFTWARE

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