DEADSOFTWARE

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