DEADSOFTWARE

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


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