DEADSOFTWARE

GIT / REPO / FRED-BOY
Projects / dsw-obn.git / blob
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
Поправлены повторные опережающие объявления процедур, добавлено именование генерируем...
[dsw-obn.git] / 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
8 #include "oberon.h"
9 #include "generator.h"
10
11 enum {
12 EOF_ = 0,
13 IDENT,
14 MODULE,
15 SEMICOLON,
16 END,
17 DOT,
18 VAR,
19 COLON,
20 BEGIN,
21 ASSIGN,
22 INTEGER,
23 TRUE,
24 FALSE,
25 LPAREN,
26 RPAREN,
27 EQUAL,
28 NEQ,
29 LESS,
30 LEQ,
31 GREAT,
32 GEQ,
33 PLUS,
34 MINUS,
35 OR,
36 STAR,
37 SLASH,
38 DIV,
39 MOD,
40 AND,
41 NOT,
42 PROCEDURE,
43 COMMA,
44 RETURN,
45 CONST,
46 TYPE,
47 ARRAY,
48 OF,
49 LBRACE,
50 RBRACE,
51 RECORD,
52 POINTER,
53 TO,
54 UPARROW,
55 NIL
56 };
57
58 // =======================================================================
59 // UTILS
60 // =======================================================================
61
62 void
63 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
64 {
65 va_list ptr;
66 va_start(ptr, fmt);
67 fprintf(stderr, "error: ");
68 vfprintf(stderr, fmt, ptr);
69 fprintf(stderr, "\n");
70 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
71 fprintf(stderr, " c = %c\n", ctx -> c);
72 fprintf(stderr, " token = %i\n", ctx -> token);
73 va_end(ptr);
74 exit(1);
75 }
76
77 static oberon_type_t *
78 oberon_new_type_ptr(int class)
79 {
80 oberon_type_t * x = malloc(sizeof *x);
81 memset(x, 0, sizeof *x);
82 x -> class = class;
83 return x;
84 }
85
86 static oberon_type_t *
87 oberon_new_type_integer(int size)
88 {
89 oberon_type_t * x;
90 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
91 x -> size = size;
92 return x;
93 }
94
95 static oberon_type_t *
96 oberon_new_type_boolean(int size)
97 {
98 oberon_type_t * x;
99 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
100 x -> size = size;
101 return x;
102 }
103
104 // =======================================================================
105 // TABLE
106 // =======================================================================
107
108 static oberon_scope_t *
109 oberon_open_scope(oberon_context_t * ctx)
110 {
111 oberon_scope_t * scope = malloc(sizeof *scope);
112 memset(scope, 0, sizeof *scope);
113
114 oberon_object_t * list = malloc(sizeof *list);
115 memset(list, 0, sizeof *list);
116
117 scope -> ctx = ctx;
118 scope -> list = list;
119 scope -> up = ctx -> decl;
120
121 if(scope -> up)
122 {
123 scope -> parent = scope -> up -> parent;
124 scope -> local = scope -> up -> local;
125 }
126
127 ctx -> decl = scope;
128 return scope;
129 }
130
131 static void
132 oberon_close_scope(oberon_scope_t * scope)
133 {
134 oberon_context_t * ctx = scope -> ctx;
135 ctx -> decl = scope -> up;
136 }
137
138 static oberon_object_t *
139 oberon_define_object(oberon_scope_t * scope, char * name, int class)
140 {
141 oberon_object_t * x = scope -> list;
142 while(x -> next && strcmp(x -> next -> name, name) != 0)
143 {
144 x = x -> next;
145 }
146
147 if(x -> next)
148 {
149 oberon_error(scope -> ctx, "already defined");
150 }
151
152 oberon_object_t * newvar = malloc(sizeof *newvar);
153 memset(newvar, 0, sizeof *newvar);
154 newvar -> name = name;
155 newvar -> class = class;
156 newvar -> local = scope -> local;
157 newvar -> parent = scope -> parent;
158
159 x -> next = newvar;
160
161 return newvar;
162 }
163
164 static void
165 oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char * name, oberon_type_t * type)
166 {
167 // TODO check base fields
168
169 oberon_object_t * x = rec -> decl;
170 while(x -> next && strcmp(x -> next -> name, name) != 0)
171 {
172 x = x -> next;
173 }
174
175 if(x -> next)
176 {
177 oberon_error(ctx, "multiple definition");
178 }
179
180 oberon_object_t * field = malloc(sizeof *field);
181 memset(field, 0, sizeof *field);
182 field -> name = name;
183 field -> class = OBERON_CLASS_FIELD;
184 field -> type = type;
185 field -> local = 1;
186 field -> parent = NULL;
187
188 rec -> num_decl += 1;
189 x -> next = field;
190 }
191
192 static oberon_object_t *
193 oberon_find_object_in_list(oberon_object_t * list, char * name)
194 {
195 oberon_object_t * x = list;
196 while(x -> next && strcmp(x -> next -> name, name) != 0)
197 {
198 x = x -> next;
199 }
200 return x -> next;
201 }
202
203 static oberon_object_t *
204 oberon_find_object(oberon_scope_t * scope, char * name, int check_it)
205 {
206 oberon_object_t * result = NULL;
207
208 oberon_scope_t * s = scope;
209 while(result == NULL && s != NULL)
210 {
211 result = oberon_find_object_in_list(s -> list, name);
212 s = s -> up;
213 }
214
215 if(check_it && result == NULL)
216 {
217 oberon_error(scope -> ctx, "undefined ident %s", name);
218 }
219
220 return result;
221 }
222
223 static oberon_object_t *
224 oberon_find_field(oberon_context_t * ctx, oberon_type_t * rec, char * name)
225 {
226 oberon_object_t * x = rec -> decl;
227 for(int i = 0; i < rec -> num_decl; i++)
228 {
229 if(strcmp(x -> name, name) == 0)
230 {
231 return x;
232 }
233 x = x -> next;
234 }
235
236 oberon_error(ctx, "field not defined");
237
238 return NULL;
239 }
240
241 static oberon_object_t *
242 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type)
243 {
244 oberon_object_t * id;
245 id = oberon_define_object(scope, name, OBERON_CLASS_TYPE);
246 id -> type = type;
247 oberon_generator_init_type(scope -> ctx, type);
248 return id;
249 }
250
251 /*
252 static oberon_type_t *
253 oberon_find_type(oberon_scope_t * scope, char * name)
254 {
255 oberon_object_t * x = oberon_find_object(scope, name);
256 if(x -> class != OBERON_CLASS_TYPE)
257 {
258 oberon_error(scope -> ctx, "%s not a type", name);
259 }
260
261 return x -> type;
262 }
263 */
264
265 static oberon_object_t *
266 oberon_define_var(oberon_scope_t * scope, int class, char * name, oberon_type_t * type)
267 {
268 oberon_object_t * var;
269 var = oberon_define_object(scope, name, class);
270 var -> type = type;
271 return var;
272 }
273
274 /*
275 static oberon_object_t *
276 oberon_find_var(oberon_scope_t * scope, char * name)
277 {
278 oberon_object_t * x = oberon_find_object(scope, name);
279
280 if(x -> class != OBERON_CLASS_VAR)
281 {
282 oberon_error(scope -> ctx, "%s not a var", name);
283 }
284
285 return x;
286 }
287 */
288
289 /*
290 static oberon_object_t *
291 oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signature)
292 {
293 oberon_object_t * proc;
294 proc = oberon_define_object(scope, name, OBERON_CLASS_PROC);
295 proc -> type = signature;
296 return proc;
297 }
298 */
299
300 // =======================================================================
301 // SCANER
302 // =======================================================================
303
304 static void
305 oberon_get_char(oberon_context_t * ctx)
306 {
307 ctx -> code_index += 1;
308 ctx -> c = ctx -> code[ctx -> code_index];
309 }
310
311 static void
312 oberon_init_scaner(oberon_context_t * ctx, const char * code)
313 {
314 ctx -> code = code;
315 ctx -> code_index = 0;
316 ctx -> c = ctx -> code[ctx -> code_index];
317 }
318
319 static void
320 oberon_read_ident(oberon_context_t * ctx)
321 {
322 int len = 0;
323 int i = ctx -> code_index;
324
325 int c = ctx -> code[i];
326 while(isalnum(c))
327 {
328 i += 1;
329 len += 1;
330 c = ctx -> code[i];
331 }
332
333 char * ident = malloc(len + 1);
334 memcpy(ident, &ctx->code[ctx->code_index], len);
335 ident[len] = 0;
336
337 ctx -> code_index = i;
338 ctx -> c = ctx -> code[i];
339 ctx -> string = ident;
340 ctx -> token = IDENT;
341
342 if(strcmp(ident, "MODULE") == 0)
343 {
344 ctx -> token = MODULE;
345 }
346 else if(strcmp(ident, "END") == 0)
347 {
348 ctx -> token = END;
349 }
350 else if(strcmp(ident, "VAR") == 0)
351 {
352 ctx -> token = VAR;
353 }
354 else if(strcmp(ident, "BEGIN") == 0)
355 {
356 ctx -> token = BEGIN;
357 }
358 else if(strcmp(ident, "TRUE") == 0)
359 {
360 ctx -> token = TRUE;
361 }
362 else if(strcmp(ident, "FALSE") == 0)
363 {
364 ctx -> token = FALSE;
365 }
366 else if(strcmp(ident, "OR") == 0)
367 {
368 ctx -> token = OR;
369 }
370 else if(strcmp(ident, "DIV") == 0)
371 {
372 ctx -> token = DIV;
373 }
374 else if(strcmp(ident, "MOD") == 0)
375 {
376 ctx -> token = MOD;
377 }
378 else if(strcmp(ident, "PROCEDURE") == 0)
379 {
380 ctx -> token = PROCEDURE;
381 }
382 else if(strcmp(ident, "RETURN") == 0)
383 {
384 ctx -> token = RETURN;
385 }
386 else if(strcmp(ident, "CONST") == 0)
387 {
388 ctx -> token = CONST;
389 }
390 else if(strcmp(ident, "TYPE") == 0)
391 {
392 ctx -> token = TYPE;
393 }
394 else if(strcmp(ident, "ARRAY") == 0)
395 {
396 ctx -> token = ARRAY;
397 }
398 else if(strcmp(ident, "OF") == 0)
399 {
400 ctx -> token = OF;
401 }
402 else if(strcmp(ident, "RECORD") == 0)
403 {
404 ctx -> token = RECORD;
405 }
406 else if(strcmp(ident, "POINTER") == 0)
407 {
408 ctx -> token = POINTER;
409 }
410 else if(strcmp(ident, "TO") == 0)
411 {
412 ctx -> token = TO;
413 }
414 else if(strcmp(ident, "NIL") == 0)
415 {
416 ctx -> token = NIL;
417 }
418 }
419
420 static void
421 oberon_read_integer(oberon_context_t * ctx)
422 {
423 int len = 0;
424 int i = ctx -> code_index;
425
426 int c = ctx -> code[i];
427 while(isdigit(c))
428 {
429 i += 1;
430 len += 1;
431 c = ctx -> code[i];
432 }
433
434 char * ident = malloc(len + 2);
435 memcpy(ident, &ctx->code[ctx->code_index], len);
436 ident[len + 1] = 0;
437
438 ctx -> code_index = i;
439 ctx -> c = ctx -> code[i];
440 ctx -> string = ident;
441 ctx -> integer = atoi(ident);
442 ctx -> token = INTEGER;
443 }
444
445 static void
446 oberon_skip_space(oberon_context_t * ctx)
447 {
448 while(isspace(ctx -> c))
449 {
450 oberon_get_char(ctx);
451 }
452 }
453
454 static void
455 oberon_read_symbol(oberon_context_t * ctx)
456 {
457 int c = ctx -> c;
458 switch(c)
459 {
460 case 0:
461 ctx -> token = EOF_;
462 break;
463 case ';':
464 ctx -> token = SEMICOLON;
465 oberon_get_char(ctx);
466 break;
467 case ':':
468 ctx -> token = COLON;
469 oberon_get_char(ctx);
470 if(ctx -> c == '=')
471 {
472 ctx -> token = ASSIGN;
473 oberon_get_char(ctx);
474 }
475 break;
476 case '.':
477 ctx -> token = DOT;
478 oberon_get_char(ctx);
479 break;
480 case '(':
481 ctx -> token = LPAREN;
482 oberon_get_char(ctx);
483 break;
484 case ')':
485 ctx -> token = RPAREN;
486 oberon_get_char(ctx);
487 break;
488 case '=':
489 ctx -> token = EQUAL;
490 oberon_get_char(ctx);
491 break;
492 case '#':
493 ctx -> token = NEQ;
494 oberon_get_char(ctx);
495 break;
496 case '<':
497 ctx -> token = LESS;
498 oberon_get_char(ctx);
499 if(ctx -> c == '=')
500 {
501 ctx -> token = LEQ;
502 oberon_get_char(ctx);
503 }
504 break;
505 case '>':
506 ctx -> token = GREAT;
507 oberon_get_char(ctx);
508 if(ctx -> c == '=')
509 {
510 ctx -> token = GEQ;
511 oberon_get_char(ctx);
512 }
513 break;
514 case '+':
515 ctx -> token = PLUS;
516 oberon_get_char(ctx);
517 break;
518 case '-':
519 ctx -> token = MINUS;
520 oberon_get_char(ctx);
521 break;
522 case '*':
523 ctx -> token = STAR;
524 oberon_get_char(ctx);
525 break;
526 case '/':
527 ctx -> token = SLASH;
528 oberon_get_char(ctx);
529 break;
530 case '&':
531 ctx -> token = AND;
532 oberon_get_char(ctx);
533 break;
534 case '~':
535 ctx -> token = NOT;
536 oberon_get_char(ctx);
537 break;
538 case ',':
539 ctx -> token = COMMA;
540 oberon_get_char(ctx);
541 break;
542 case '[':
543 ctx -> token = LBRACE;
544 oberon_get_char(ctx);
545 break;
546 case ']':
547 ctx -> token = RBRACE;
548 oberon_get_char(ctx);
549 break;
550 case '^':
551 ctx -> token = UPARROW;
552 oberon_get_char(ctx);
553 break;
554 default:
555 oberon_error(ctx, "invalid char");
556 break;
557 }
558 }
559
560 static void
561 oberon_read_token(oberon_context_t * ctx)
562 {
563 oberon_skip_space(ctx);
564
565 int c = ctx -> c;
566 if(isalpha(c))
567 {
568 oberon_read_ident(ctx);
569 }
570 else if(isdigit(c))
571 {
572 oberon_read_integer(ctx);
573 }
574 else
575 {
576 oberon_read_symbol(ctx);
577 }
578 }
579
580 // =======================================================================
581 // EXPRESSION
582 // =======================================================================
583
584 static void oberon_expect_token(oberon_context_t * ctx, int token);
585 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
586 static void oberon_assert_token(oberon_context_t * ctx, int token);
587 static char * oberon_assert_ident(oberon_context_t * ctx);
588 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
589 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
590
591 static oberon_expr_t *
592 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
593 {
594 oberon_oper_t * operator;
595 operator = malloc(sizeof *operator);
596 memset(operator, 0, sizeof *operator);
597
598 operator -> is_item = 0;
599 operator -> result = result;
600 operator -> op = op;
601 operator -> left = left;
602 operator -> right = right;
603
604 return (oberon_expr_t *) operator;
605 }
606
607 static oberon_expr_t *
608 oberon_new_item(int mode, oberon_type_t * result)
609 {
610 oberon_item_t * item;
611 item = malloc(sizeof *item);
612 memset(item, 0, sizeof *item);
613
614 item -> is_item = 1;
615 item -> result = result;
616 item -> mode = mode;
617
618 return (oberon_expr_t *)item;
619 }
620
621 static oberon_expr_t *
622 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
623 {
624 oberon_expr_t * expr;
625 oberon_type_t * result;
626
627 result = a -> result;
628
629 if(token == MINUS)
630 {
631 if(result -> class != OBERON_TYPE_INTEGER)
632 {
633 oberon_error(ctx, "incompatible operator type");
634 }
635
636 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
637 }
638 else if(token == NOT)
639 {
640 if(result -> class != OBERON_TYPE_BOOLEAN)
641 {
642 oberon_error(ctx, "incompatible operator type");
643 }
644
645 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
646 }
647 else
648 {
649 oberon_error(ctx, "oberon_make_unary_op: wat");
650 }
651
652 return expr;
653 }
654
655 static void
656 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
657 {
658 oberon_expr_t * last;
659
660 *num_expr = 1;
661 *first = last = oberon_expr(ctx);
662 while(ctx -> token == COMMA)
663 {
664 oberon_assert_token(ctx, COMMA);
665 oberon_expr_t * current;
666
667 if(const_expr)
668 {
669 current = (oberon_expr_t *) oberon_const_expr(ctx);
670 }
671 else
672 {
673 current = oberon_expr(ctx);
674 }
675
676 last -> next = current;
677 last = current;
678 *num_expr += 1;
679 }
680 }
681
682 static oberon_expr_t *
683 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
684 {
685 if(pref -> class != expr -> result -> class)
686 {
687 oberon_error(ctx, "incompatible types");
688 }
689
690 if(pref -> class == OBERON_TYPE_INTEGER)
691 {
692 if(expr -> result -> class > pref -> class)
693 {
694 oberon_error(ctx, "incompatible size");
695 }
696 }
697 else if(pref -> class == OBERON_TYPE_RECORD)
698 {
699 if(expr -> result != pref)
700 {
701 printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
702 oberon_error(ctx, "incompatible record types");
703 }
704 }
705 else if(pref -> class == OBERON_TYPE_POINTER)
706 {
707 if(expr -> result -> base != pref -> base)
708 {
709 if(expr -> result -> base -> class != OBERON_TYPE_VOID)
710 {
711 oberon_error(ctx, "incompatible pointer types");
712 }
713 }
714 }
715
716 // TODO cast
717
718 return expr;
719 }
720
721 static void
722 oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
723 {
724 if(desig -> is_item == 0)
725 {
726 oberon_error(ctx, "expected item");
727 }
728
729 if(desig -> item.mode != MODE_CALL)
730 {
731 oberon_error(ctx, "expected mode CALL");
732 }
733
734 if(desig -> item.var -> class != OBERON_CLASS_PROC)
735 {
736 oberon_error(ctx, "only procedures can be called");
737 }
738
739 oberon_type_t * fn = desig -> item.var -> type;
740 int num_args = desig -> item.num_args;
741 int num_decl = fn -> num_decl;
742
743 if(num_args < num_decl)
744 {
745 oberon_error(ctx, "too few arguments");
746 }
747 else if(num_args > num_decl)
748 {
749 oberon_error(ctx, "too many arguments");
750 }
751
752 oberon_expr_t * arg = desig -> item.args;
753 oberon_object_t * param = fn -> decl;
754 for(int i = 0; i < num_args; i++)
755 {
756 if(param -> class == OBERON_CLASS_VAR_PARAM)
757 {
758 if(arg -> is_item)
759 {
760 switch(arg -> item.mode)
761 {
762 case MODE_VAR:
763 case MODE_INDEX:
764 case MODE_FIELD:
765 // Допустимо разыменование?
766 //case MODE_DEREF:
767 break;
768 default:
769 oberon_error(ctx, "var-parameter accept only variables");
770 break;
771 }
772 }
773 }
774 oberon_autocast_to(ctx, arg, param -> type);
775 arg = arg -> next;
776 param = param -> next;
777 }
778 }
779
780 #define ISEXPR(x) \
781 (((x) == PLUS) \
782 || ((x) == MINUS) \
783 || ((x) == IDENT) \
784 || ((x) == INTEGER) \
785 || ((x) == LPAREN) \
786 || ((x) == NOT) \
787 || ((x) == TRUE) \
788 || ((x) == FALSE))
789
790 static oberon_expr_t *
791 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
792 {
793 if(expr -> result -> class != OBERON_TYPE_POINTER)
794 {
795 oberon_error(ctx, "not a pointer");
796 }
797
798 assert(expr -> is_item);
799
800 oberon_expr_t * selector;
801 selector = oberon_new_item(MODE_DEREF, expr -> result -> base);
802 selector -> item.parent = (oberon_item_t *) expr;
803
804 return selector;
805 }
806
807 static oberon_expr_t *
808 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
809 {
810 if(desig -> result -> class == OBERON_TYPE_POINTER)
811 {
812 desig = oberno_make_dereferencing(ctx, desig);
813 }
814
815 assert(desig -> is_item);
816
817 if(desig -> result -> class != OBERON_TYPE_ARRAY)
818 {
819 oberon_error(ctx, "not array");
820 }
821
822 oberon_type_t * base;
823 base = desig -> result -> base;
824
825 if(index -> result -> class != OBERON_TYPE_INTEGER)
826 {
827 oberon_error(ctx, "index must be integer");
828 }
829
830 // Статическая проверка границ массива
831 if(index -> is_item)
832 {
833 if(index -> item.mode == MODE_INTEGER)
834 {
835 int arr_size = desig -> result -> size;
836 int index_int = index -> item.integer;
837 if(index_int < 0 || index_int > arr_size - 1)
838 {
839 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
840 }
841 }
842 }
843
844 oberon_expr_t * selector;
845 selector = oberon_new_item(MODE_INDEX, base);
846 selector -> item.parent = (oberon_item_t *) desig;
847 selector -> item.num_args = 1;
848 selector -> item.args = index;
849
850 return selector;
851 }
852
853 static oberon_expr_t *
854 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
855 {
856 if(expr -> result -> class == OBERON_TYPE_POINTER)
857 {
858 expr = oberno_make_dereferencing(ctx, expr);
859 }
860
861 assert(expr -> is_item == 1);
862
863 if(expr -> result -> class != OBERON_TYPE_RECORD)
864 {
865 oberon_error(ctx, "not record");
866 }
867
868 oberon_type_t * rec = expr -> result;
869
870 oberon_object_t * field;
871 field = oberon_find_field(ctx, rec, name);
872
873 oberon_expr_t * selector;
874 selector = oberon_new_item(MODE_FIELD, field -> type);
875 selector -> item.var = field;
876 selector -> item.parent = (oberon_item_t *) expr;
877
878 return selector;
879 }
880
881 #define ISSELECTOR(x) \
882 (((x) == LBRACE) \
883 || ((x) == DOT) \
884 || ((x) == UPARROW))
885
886 static oberon_expr_t *
887 oberon_designator(oberon_context_t * ctx)
888 {
889 char * name;
890 oberon_object_t * var;
891 oberon_expr_t * expr;
892
893 name = oberon_assert_ident(ctx);
894 var = oberon_find_object(ctx -> decl, name, 1);
895
896 switch(var -> class)
897 {
898 case OBERON_CLASS_CONST:
899 // TODO copy value
900 expr = (oberon_expr_t *) var -> value;
901 break;
902 case OBERON_CLASS_VAR:
903 case OBERON_CLASS_VAR_PARAM:
904 case OBERON_CLASS_PARAM:
905 expr = oberon_new_item(MODE_VAR, var -> type);
906 break;
907 case OBERON_CLASS_PROC:
908 expr = oberon_new_item(MODE_CALL, var -> type);
909 break;
910 default:
911 oberon_error(ctx, "invalid designator");
912 break;
913 }
914 expr -> item.var = var;
915
916 while(ISSELECTOR(ctx -> token))
917 {
918 switch(ctx -> token)
919 {
920 case DOT:
921 oberon_assert_token(ctx, DOT);
922 name = oberon_assert_ident(ctx);
923 expr = oberon_make_record_selector(ctx, expr, name);
924 break;
925 case LBRACE:
926 oberon_assert_token(ctx, LBRACE);
927 int num_indexes = 0;
928 oberon_expr_t * indexes = NULL;
929 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
930 oberon_assert_token(ctx, RBRACE);
931
932 for(int i = 0; i < num_indexes; i++)
933 {
934 expr = oberon_make_array_selector(ctx, expr, indexes);
935 indexes = indexes -> next;
936 }
937 break;
938 case UPARROW:
939 oberon_assert_token(ctx, UPARROW);
940 expr = oberno_make_dereferencing(ctx, expr);
941 break;
942 default:
943 oberon_error(ctx, "oberon_designator: wat");
944 break;
945 }
946 }
947 return expr;
948 }
949
950 static oberon_expr_t *
951 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
952 {
953 assert(expr -> is_item == 1);
954
955 if(ctx -> token == LPAREN)
956 {
957 if(expr -> result -> class != OBERON_TYPE_PROCEDURE)
958 {
959 oberon_error(ctx, "not a procedure");
960 }
961
962 oberon_assert_token(ctx, LPAREN);
963
964 int num_args = 0;
965 oberon_expr_t * arguments = NULL;
966
967 if(ISEXPR(ctx -> token))
968 {
969 oberon_expr_list(ctx, &num_args, &arguments, 0);
970 }
971
972 expr -> result = expr -> item.var -> type -> base;
973 expr -> item.mode = MODE_CALL;
974 expr -> item.num_args = num_args;
975 expr -> item.args = arguments;
976 oberon_assert_token(ctx, RPAREN);
977
978 oberon_autocast_call(ctx, expr);
979 }
980
981 return expr;
982 }
983
984 static oberon_expr_t *
985 oberon_factor(oberon_context_t * ctx)
986 {
987 oberon_expr_t * expr;
988
989 switch(ctx -> token)
990 {
991 case IDENT:
992 expr = oberon_designator(ctx);
993 expr = oberon_opt_proc_parens(ctx, expr);
994 break;
995 case INTEGER:
996 expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
997 expr -> item.integer = ctx -> integer;
998 oberon_assert_token(ctx, INTEGER);
999 break;
1000 case TRUE:
1001 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
1002 expr -> item.boolean = 1;
1003 oberon_assert_token(ctx, TRUE);
1004 break;
1005 case FALSE:
1006 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
1007 expr -> item.boolean = 0;
1008 oberon_assert_token(ctx, FALSE);
1009 break;
1010 case LPAREN:
1011 oberon_assert_token(ctx, LPAREN);
1012 expr = oberon_expr(ctx);
1013 oberon_assert_token(ctx, RPAREN);
1014 break;
1015 case NOT:
1016 oberon_assert_token(ctx, NOT);
1017 expr = oberon_factor(ctx);
1018 expr = oberon_make_unary_op(ctx, NOT, expr);
1019 break;
1020 case NIL:
1021 oberon_assert_token(ctx, NIL);
1022 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type);
1023 break;
1024 default:
1025 oberon_error(ctx, "invalid expression");
1026 }
1027
1028 return expr;
1029 }
1030
1031 /*
1032 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1033 * 1. Классы обоих типов должны быть одинаковы
1034 * 2. В качестве результата должен быть выбран больший тип.
1035 * 3. Если размер результат не должен быть меньше чем базовый int
1036 */
1037
1038 static void
1039 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
1040 {
1041 if((a -> class) != (b -> class))
1042 {
1043 oberon_error(ctx, "incompatible types");
1044 }
1045
1046 if((a -> size) > (b -> size))
1047 {
1048 *result = a;
1049 }
1050 else
1051 {
1052 *result = b;
1053 }
1054
1055 if(((*result) -> class) == OBERON_TYPE_INTEGER)
1056 {
1057 if(((*result) -> size) < (ctx -> int_type -> size))
1058 {
1059 *result = ctx -> int_type;
1060 }
1061 }
1062
1063 /* TODO: cast types */
1064 }
1065
1066 #define ITMAKESBOOLEAN(x) \
1067 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1068
1069 #define ITUSEONLYINTEGER(x) \
1070 ((x) >= LESS && (x) <= GEQ)
1071
1072 #define ITUSEONLYBOOLEAN(x) \
1073 (((x) == OR) || ((x) == AND))
1074
1075 static oberon_expr_t *
1076 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1077 {
1078 oberon_expr_t * expr;
1079 oberon_type_t * result;
1080
1081 if(ITMAKESBOOLEAN(token))
1082 {
1083 if(ITUSEONLYINTEGER(token))
1084 {
1085 if(a -> result -> class != OBERON_TYPE_INTEGER
1086 || b -> result -> class != OBERON_TYPE_INTEGER)
1087 {
1088 oberon_error(ctx, "used only with integer types");
1089 }
1090 }
1091 else if(ITUSEONLYBOOLEAN(token))
1092 {
1093 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1094 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1095 {
1096 oberon_error(ctx, "used only with boolean type");
1097 }
1098 }
1099
1100 result = ctx -> bool_type;
1101
1102 if(token == EQUAL)
1103 {
1104 expr = oberon_new_operator(OP_EQ, result, a, b);
1105 }
1106 else if(token == NEQ)
1107 {
1108 expr = oberon_new_operator(OP_NEQ, result, a, b);
1109 }
1110 else if(token == LESS)
1111 {
1112 expr = oberon_new_operator(OP_LSS, result, a, b);
1113 }
1114 else if(token == LEQ)
1115 {
1116 expr = oberon_new_operator(OP_LEQ, result, a, b);
1117 }
1118 else if(token == GREAT)
1119 {
1120 expr = oberon_new_operator(OP_GRT, result, a, b);
1121 }
1122 else if(token == GEQ)
1123 {
1124 expr = oberon_new_operator(OP_GEQ, result, a, b);
1125 }
1126 else if(token == OR)
1127 {
1128 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1129 }
1130 else if(token == AND)
1131 {
1132 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1133 }
1134 else
1135 {
1136 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1137 }
1138 }
1139 else
1140 {
1141 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1142
1143 if(token == PLUS)
1144 {
1145 expr = oberon_new_operator(OP_ADD, result, a, b);
1146 }
1147 else if(token == MINUS)
1148 {
1149 expr = oberon_new_operator(OP_SUB, result, a, b);
1150 }
1151 else if(token == STAR)
1152 {
1153 expr = oberon_new_operator(OP_MUL, result, a, b);
1154 }
1155 else if(token == SLASH)
1156 {
1157 expr = oberon_new_operator(OP_DIV, result, a, b);
1158 }
1159 else if(token == DIV)
1160 {
1161 expr = oberon_new_operator(OP_DIV, result, a, b);
1162 }
1163 else if(token == MOD)
1164 {
1165 expr = oberon_new_operator(OP_MOD, result, a, b);
1166 }
1167 else
1168 {
1169 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1170 }
1171 }
1172
1173 return expr;
1174 }
1175
1176 #define ISMULOP(x) \
1177 ((x) >= STAR && (x) <= AND)
1178
1179 static oberon_expr_t *
1180 oberon_term_expr(oberon_context_t * ctx)
1181 {
1182 oberon_expr_t * expr;
1183
1184 expr = oberon_factor(ctx);
1185 while(ISMULOP(ctx -> token))
1186 {
1187 int token = ctx -> token;
1188 oberon_read_token(ctx);
1189
1190 oberon_expr_t * inter = oberon_factor(ctx);
1191 expr = oberon_make_bin_op(ctx, token, expr, inter);
1192 }
1193
1194 return expr;
1195 }
1196
1197 #define ISADDOP(x) \
1198 ((x) >= PLUS && (x) <= OR)
1199
1200 static oberon_expr_t *
1201 oberon_simple_expr(oberon_context_t * ctx)
1202 {
1203 oberon_expr_t * expr;
1204
1205 int minus = 0;
1206 if(ctx -> token == PLUS)
1207 {
1208 minus = 0;
1209 oberon_assert_token(ctx, PLUS);
1210 }
1211 else if(ctx -> token == MINUS)
1212 {
1213 minus = 1;
1214 oberon_assert_token(ctx, MINUS);
1215 }
1216
1217 expr = oberon_term_expr(ctx);
1218 while(ISADDOP(ctx -> token))
1219 {
1220 int token = ctx -> token;
1221 oberon_read_token(ctx);
1222
1223 oberon_expr_t * inter = oberon_term_expr(ctx);
1224 expr = oberon_make_bin_op(ctx, token, expr, inter);
1225 }
1226
1227 if(minus)
1228 {
1229 expr = oberon_make_unary_op(ctx, MINUS, expr);
1230 }
1231
1232 return expr;
1233 }
1234
1235 #define ISRELATION(x) \
1236 ((x) >= EQUAL && (x) <= GEQ)
1237
1238 static oberon_expr_t *
1239 oberon_expr(oberon_context_t * ctx)
1240 {
1241 oberon_expr_t * expr;
1242
1243 expr = oberon_simple_expr(ctx);
1244 while(ISRELATION(ctx -> token))
1245 {
1246 int token = ctx -> token;
1247 oberon_read_token(ctx);
1248
1249 oberon_expr_t * inter = oberon_simple_expr(ctx);
1250 expr = oberon_make_bin_op(ctx, token, expr, inter);
1251 }
1252
1253 return expr;
1254 }
1255
1256 static oberon_item_t *
1257 oberon_const_expr(oberon_context_t * ctx)
1258 {
1259 oberon_expr_t * expr;
1260 expr = oberon_expr(ctx);
1261
1262 if(expr -> is_item == 0)
1263 {
1264 oberon_error(ctx, "const expression are required");
1265 }
1266
1267 return (oberon_item_t *) expr;
1268 }
1269
1270 // =======================================================================
1271 // PARSER
1272 // =======================================================================
1273
1274 static void oberon_decl_seq(oberon_context_t * ctx);
1275 static void oberon_statement_seq(oberon_context_t * ctx);
1276 static void oberon_initialize_decl(oberon_context_t * ctx);
1277
1278 static void
1279 oberon_expect_token(oberon_context_t * ctx, int token)
1280 {
1281 if(ctx -> token != token)
1282 {
1283 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1284 }
1285 }
1286
1287 static void
1288 oberon_assert_token(oberon_context_t * ctx, int token)
1289 {
1290 oberon_expect_token(ctx, token);
1291 oberon_read_token(ctx);
1292 }
1293
1294 static char *
1295 oberon_assert_ident(oberon_context_t * ctx)
1296 {
1297 oberon_expect_token(ctx, IDENT);
1298 char * ident = ctx -> string;
1299 oberon_read_token(ctx);
1300 return ident;
1301 }
1302
1303 static void
1304 oberon_var_decl(oberon_context_t * ctx)
1305 {
1306 char * name;
1307 oberon_type_t * type;
1308 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1309
1310 name = oberon_assert_ident(ctx);
1311 oberon_assert_token(ctx, COLON);
1312 oberon_type(ctx, &type);
1313 oberon_define_var(ctx -> decl, OBERON_CLASS_VAR, name, type);
1314 }
1315
1316 static oberon_object_t *
1317 oberon_make_param(oberon_context_t * ctx, int token, char * name, oberon_type_t * type)
1318 {
1319 oberon_object_t * param;
1320
1321 if(token == VAR)
1322 {
1323 param = oberon_define_var(ctx -> decl, OBERON_CLASS_VAR_PARAM, name, type);
1324 }
1325 else if(token == IDENT)
1326 {
1327 param = oberon_define_var(ctx -> decl, OBERON_CLASS_PARAM, name, type);
1328 }
1329 else
1330 {
1331 oberon_error(ctx, "oberon_make_param: wat");
1332 }
1333
1334 return param;
1335 }
1336
1337 static oberon_object_t *
1338 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1339 {
1340 int modifer_token = ctx -> token;
1341 if(ctx -> token == VAR)
1342 {
1343 oberon_read_token(ctx);
1344 }
1345
1346 char * name;
1347 name = oberon_assert_ident(ctx);
1348
1349 oberon_assert_token(ctx, COLON);
1350
1351 oberon_type_t * type;
1352 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1353 oberon_type(ctx, &type);
1354
1355 oberon_object_t * first;
1356 first = oberon_make_param(ctx, modifer_token, name, type);
1357
1358 *num_decl += 1;
1359 return first;
1360 }
1361
1362 #define ISFPSECTION \
1363 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1364
1365 static void
1366 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1367 {
1368 oberon_assert_token(ctx, LPAREN);
1369
1370 if(ISFPSECTION)
1371 {
1372 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
1373 while(ctx -> token == SEMICOLON)
1374 {
1375 oberon_assert_token(ctx, SEMICOLON);
1376 oberon_fp_section(ctx, &signature -> num_decl);
1377 }
1378 }
1379
1380 oberon_assert_token(ctx, RPAREN);
1381
1382 if(ctx -> token == COLON)
1383 {
1384 oberon_assert_token(ctx, COLON);
1385 // TODO get by qualident
1386 oberon_type(ctx, &signature -> base);
1387 }
1388 }
1389
1390 static void
1391 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
1392 {
1393 oberon_type_t * signature;
1394 signature = *type;
1395 signature -> class = OBERON_TYPE_PROCEDURE;
1396 signature -> num_decl = 0;
1397 signature -> base = ctx -> void_type;
1398 signature -> decl = NULL;
1399
1400 if(ctx -> token == LPAREN)
1401 {
1402 oberon_formal_pars(ctx, signature);
1403 }
1404 }
1405
1406 static void
1407 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1408 {
1409 if(a -> num_decl != b -> num_decl)
1410 {
1411 oberon_error(ctx, "number parameters not matched");
1412 }
1413
1414 int num_param = a -> num_decl;
1415 oberon_object_t * param_a = a -> decl;
1416 oberon_object_t * param_b = b -> decl;
1417 for(int i = 0; i < num_param; i++)
1418 {
1419 if(strcmp(param_a -> name, param_b -> name) != 0)
1420 {
1421 oberon_error(ctx, "param %i name not matched", i + 1);
1422 }
1423
1424 if(param_a -> type != param_b -> type)
1425 {
1426 oberon_error(ctx, "param %i type not matched", i + 1);
1427 }
1428
1429 param_a = param_a -> next;
1430 param_b = param_b -> next;
1431 }
1432 }
1433
1434 static void
1435 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1436 {
1437 oberon_object_t * proc = ctx -> decl -> parent;
1438 oberon_type_t * result_type = proc -> type -> base;
1439
1440 if(result_type -> class == OBERON_TYPE_VOID)
1441 {
1442 if(expr != NULL)
1443 {
1444 oberon_error(ctx, "procedure has no result type");
1445 }
1446 }
1447 else
1448 {
1449 if(expr == NULL)
1450 {
1451 oberon_error(ctx, "procedure requires expression on result");
1452 }
1453
1454 oberon_autocast_to(ctx, expr, result_type);
1455 }
1456
1457 proc -> has_return = 1;
1458
1459 oberon_generate_return(ctx, expr);
1460 }
1461
1462 static void
1463 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
1464 {
1465 oberon_assert_token(ctx, SEMICOLON);
1466
1467 ctx -> decl = proc -> scope;
1468
1469 oberon_decl_seq(ctx);
1470
1471 oberon_generate_begin_proc(ctx, proc);
1472
1473 if(ctx -> token == BEGIN)
1474 {
1475 oberon_assert_token(ctx, BEGIN);
1476 oberon_statement_seq(ctx);
1477 }
1478
1479 oberon_assert_token(ctx, END);
1480 char * name = oberon_assert_ident(ctx);
1481 if(strcmp(name, proc -> name) != 0)
1482 {
1483 oberon_error(ctx, "procedure name not matched");
1484 }
1485
1486 if(proc -> type -> base -> class == OBERON_TYPE_VOID
1487 && proc -> has_return == 0)
1488 {
1489 oberon_make_return(ctx, NULL);
1490 }
1491
1492 if(proc -> has_return == 0)
1493 {
1494 oberon_error(ctx, "procedure requires return");
1495 }
1496
1497 oberon_generate_end_proc(ctx);
1498 oberon_close_scope(ctx -> decl);
1499 }
1500
1501 static void
1502 oberon_proc_decl(oberon_context_t * ctx)
1503 {
1504 oberon_assert_token(ctx, PROCEDURE);
1505
1506 int forward = 0;
1507 if(ctx -> token == UPARROW)
1508 {
1509 oberon_assert_token(ctx, UPARROW);
1510 forward = 1;
1511 }
1512
1513 char * name;
1514 name = oberon_assert_ident(ctx);
1515
1516 oberon_scope_t * proc_scope;
1517 proc_scope = oberon_open_scope(ctx);
1518 ctx -> decl -> local = 1;
1519
1520 oberon_type_t * signature;
1521 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
1522 oberon_opt_formal_pars(ctx, &signature);
1523
1524 oberon_initialize_decl(ctx);
1525 oberon_generator_init_type(ctx, signature);
1526 oberon_close_scope(ctx -> decl);
1527
1528 oberon_object_t * proc;
1529 proc = oberon_find_object(ctx -> decl, name, 0);
1530 if(proc != NULL)
1531 {
1532 if(proc -> class != OBERON_CLASS_PROC)
1533 {
1534 oberon_error(ctx, "mult definition");
1535 }
1536
1537 if(forward == 0)
1538 {
1539 if(proc -> linked)
1540 {
1541 oberon_error(ctx, "mult procedure definition");
1542 }
1543 }
1544
1545 oberon_compare_signatures(ctx, proc -> type, signature);
1546 }
1547 else
1548 {
1549 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
1550 proc -> type = signature;
1551 proc -> scope = proc_scope;
1552 oberon_generator_init_proc(ctx, proc);
1553 }
1554
1555 proc -> scope -> parent = proc;
1556
1557 if(forward == 0)
1558 {
1559 proc -> linked = 1;
1560 oberon_proc_decl_body(ctx, proc);
1561 }
1562 }
1563
1564 static void
1565 oberon_const_decl(oberon_context_t * ctx)
1566 {
1567 char * name;
1568 oberon_item_t * value;
1569 oberon_object_t * constant;
1570
1571 name = oberon_assert_ident(ctx);
1572 oberon_assert_token(ctx, EQUAL);
1573 value = oberon_const_expr(ctx);
1574
1575 constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST);
1576 constant -> value = value;
1577 }
1578
1579 static void
1580 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
1581 {
1582 if(size -> is_item == 0)
1583 {
1584 oberon_error(ctx, "requires constant");
1585 }
1586
1587 if(size -> item.mode != MODE_INTEGER)
1588 {
1589 oberon_error(ctx, "requires integer constant");
1590 }
1591
1592 oberon_type_t * arr;
1593 arr = *type;
1594 arr -> class = OBERON_TYPE_ARRAY;
1595 arr -> size = size -> item.integer;
1596 arr -> base = base;
1597 }
1598
1599 static void
1600 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1601 {
1602 if(ctx -> token == IDENT)
1603 {
1604 char * name;
1605 oberon_type_t * type;
1606 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1607
1608 name = oberon_assert_ident(ctx);
1609 oberon_assert_token(ctx, COLON);
1610 oberon_type(ctx, &type);
1611 oberon_define_field(ctx, rec, name, type);
1612 }
1613 }
1614
1615 static void
1616 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
1617 {
1618 char * name;
1619 oberon_object_t * to;
1620
1621 name = oberon_assert_ident(ctx);
1622 to = oberon_find_object(ctx -> decl, name, 0);
1623
1624 if(to != NULL)
1625 {
1626 if(to -> class != OBERON_CLASS_TYPE)
1627 {
1628 oberon_error(ctx, "not a type");
1629 }
1630 }
1631 else
1632 {
1633 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1634 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1635 }
1636
1637 *type = to -> type;
1638 }
1639
1640 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
1641
1642 /*
1643 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1644 */
1645
1646 static void
1647 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
1648 {
1649 if(sizes == NULL)
1650 {
1651 *type = base;
1652 return;
1653 }
1654
1655 oberon_type_t * dim;
1656 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
1657
1658 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
1659
1660 oberon_make_array_type(ctx, sizes, dim, type);
1661 }
1662
1663 static void
1664 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
1665 {
1666 if(ctx -> token == IDENT)
1667 {
1668 oberon_qualident_type(ctx, type);
1669 }
1670 else if(ctx -> token == ARRAY)
1671 {
1672 oberon_assert_token(ctx, ARRAY);
1673
1674 int num_sizes = 0;
1675 oberon_expr_t * sizes;
1676 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
1677
1678 oberon_assert_token(ctx, OF);
1679
1680 oberon_type_t * base;
1681 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1682 oberon_type(ctx, &base);
1683
1684 oberon_make_multiarray(ctx, sizes, base, type);
1685 }
1686 else if(ctx -> token == RECORD)
1687 {
1688 oberon_type_t * rec;
1689 rec = *type;
1690 rec -> class = OBERON_TYPE_RECORD;
1691 oberon_object_t * list = malloc(sizeof *list);
1692 memset(list, 0, sizeof *list);
1693 rec -> num_decl = 0;
1694 rec -> base = NULL;
1695 rec -> decl = list;
1696
1697 oberon_assert_token(ctx, RECORD);
1698 oberon_field_list(ctx, rec);
1699 while(ctx -> token == SEMICOLON)
1700 {
1701 oberon_assert_token(ctx, SEMICOLON);
1702 oberon_field_list(ctx, rec);
1703 }
1704 oberon_assert_token(ctx, END);
1705
1706 rec -> decl = rec -> decl -> next;
1707 *type = rec;
1708 }
1709 else if(ctx -> token == POINTER)
1710 {
1711 oberon_assert_token(ctx, POINTER);
1712 oberon_assert_token(ctx, TO);
1713
1714 oberon_type_t * base;
1715 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1716 oberon_type(ctx, &base);
1717
1718 oberon_type_t * ptr;
1719 ptr = *type;
1720 ptr -> class = OBERON_TYPE_POINTER;
1721 ptr -> base = base;
1722 }
1723 else if(ctx -> token == PROCEDURE)
1724 {
1725 oberon_open_scope(ctx);
1726 oberon_assert_token(ctx, PROCEDURE);
1727 oberon_opt_formal_pars(ctx, type);
1728 oberon_close_scope(ctx -> decl);
1729 }
1730 else
1731 {
1732 oberon_error(ctx, "invalid type declaration");
1733 }
1734 }
1735
1736 static void
1737 oberon_type_decl(oberon_context_t * ctx)
1738 {
1739 char * name;
1740 oberon_object_t * newtype;
1741 oberon_type_t * type;
1742
1743 name = oberon_assert_ident(ctx);
1744
1745 newtype = oberon_find_object(ctx -> decl, name, 0);
1746 if(newtype == NULL)
1747 {
1748 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1749 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1750 assert(newtype -> type);
1751 }
1752 else
1753 {
1754 if(newtype -> class != OBERON_CLASS_TYPE)
1755 {
1756 oberon_error(ctx, "mult definition");
1757 }
1758
1759 if(newtype -> linked)
1760 {
1761 oberon_error(ctx, "mult definition - already linked");
1762 }
1763 }
1764
1765 oberon_assert_token(ctx, EQUAL);
1766
1767 type = newtype -> type;
1768 oberon_type(ctx, &type);
1769
1770 if(type -> class == OBERON_TYPE_VOID)
1771 {
1772 oberon_error(ctx, "recursive alias declaration");
1773 }
1774
1775 newtype -> type = type;
1776 newtype -> linked = 1;
1777 }
1778
1779 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
1780 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
1781
1782 static void
1783 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
1784 {
1785 if(type -> class != OBERON_TYPE_POINTER
1786 && type -> class != OBERON_TYPE_ARRAY)
1787 {
1788 return;
1789 }
1790
1791 if(type -> recursive)
1792 {
1793 oberon_error(ctx, "recursive pointer declaration");
1794 }
1795
1796 if(type -> base -> class == OBERON_TYPE_POINTER)
1797 {
1798 oberon_error(ctx, "attempt to make pointer to pointer");
1799 }
1800
1801 type -> recursive = 1;
1802
1803 oberon_prevent_recursive_pointer(ctx, type -> base);
1804
1805 type -> recursive = 0;
1806 }
1807
1808 static void
1809 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
1810 {
1811 if(type -> class != OBERON_TYPE_RECORD)
1812 {
1813 return;
1814 }
1815
1816 if(type -> recursive)
1817 {
1818 oberon_error(ctx, "recursive record declaration");
1819 }
1820
1821 type -> recursive = 1;
1822
1823 int num_fields = type -> num_decl;
1824 oberon_object_t * field = type -> decl;
1825 for(int i = 0; i < num_fields; i++)
1826 {
1827 oberon_prevent_recursive_object(ctx, field);
1828 field = field -> next;
1829 }
1830
1831 type -> recursive = 0;
1832 }
1833 static void
1834 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
1835 {
1836 if(type -> class != OBERON_TYPE_PROCEDURE)
1837 {
1838 return;
1839 }
1840
1841 if(type -> recursive)
1842 {
1843 oberon_error(ctx, "recursive procedure declaration");
1844 }
1845
1846 type -> recursive = 1;
1847
1848 int num_fields = type -> num_decl;
1849 oberon_object_t * field = type -> decl;
1850 for(int i = 0; i < num_fields; i++)
1851 {
1852 oberon_prevent_recursive_object(ctx, field);
1853 field = field -> next;
1854 }
1855
1856 type -> recursive = 0;
1857 }
1858
1859 static void
1860 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
1861 {
1862 if(type -> class != OBERON_TYPE_ARRAY)
1863 {
1864 return;
1865 }
1866
1867 if(type -> recursive)
1868 {
1869 oberon_error(ctx, "recursive array declaration");
1870 }
1871
1872 type -> recursive = 1;
1873
1874 oberon_prevent_recursive_type(ctx, type -> base);
1875
1876 type -> recursive = 0;
1877 }
1878
1879 static void
1880 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
1881 {
1882 if(type -> class == OBERON_TYPE_POINTER)
1883 {
1884 oberon_prevent_recursive_pointer(ctx, type);
1885 }
1886 else if(type -> class == OBERON_TYPE_RECORD)
1887 {
1888 oberon_prevent_recursive_record(ctx, type);
1889 }
1890 else if(type -> class == OBERON_TYPE_ARRAY)
1891 {
1892 oberon_prevent_recursive_array(ctx, type);
1893 }
1894 else if(type -> class == OBERON_TYPE_PROCEDURE)
1895 {
1896 oberon_prevent_recursive_procedure(ctx, type);
1897 }
1898 }
1899
1900 static void
1901 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
1902 {
1903 switch(x -> class)
1904 {
1905 case OBERON_CLASS_VAR:
1906 case OBERON_CLASS_TYPE:
1907 case OBERON_CLASS_PARAM:
1908 case OBERON_CLASS_VAR_PARAM:
1909 case OBERON_CLASS_FIELD:
1910 oberon_prevent_recursive_type(ctx, x -> type);
1911 break;
1912 case OBERON_CLASS_CONST:
1913 case OBERON_CLASS_PROC:
1914 break;
1915 default:
1916 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
1917 break;
1918 }
1919 }
1920
1921 static void
1922 oberon_prevent_recursive_decl(oberon_context_t * ctx)
1923 {
1924 oberon_object_t * x = ctx -> decl -> list -> next;
1925
1926 while(x)
1927 {
1928 oberon_prevent_recursive_object(ctx, x);
1929 x = x -> next;
1930 }
1931 }
1932
1933 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
1934 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
1935
1936 static void
1937 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
1938 {
1939 if(type -> class != OBERON_TYPE_RECORD)
1940 {
1941 return;
1942 }
1943
1944 int num_fields = type -> num_decl;
1945 oberon_object_t * field = type -> decl;
1946 for(int i = 0; i < num_fields; i++)
1947 {
1948 if(field -> type -> class == OBERON_TYPE_POINTER)
1949 {
1950 oberon_initialize_type(ctx, field -> type);
1951 }
1952
1953 oberon_initialize_object(ctx, field);
1954 field = field -> next;
1955 }
1956
1957 oberon_generator_init_record(ctx, type);
1958 }
1959
1960 static void
1961 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
1962 {
1963 if(type -> class == OBERON_TYPE_VOID)
1964 {
1965 oberon_error(ctx, "undeclarated type");
1966 }
1967
1968 if(type -> initialized)
1969 {
1970 return;
1971 }
1972
1973 type -> initialized = 1;
1974
1975 if(type -> class == OBERON_TYPE_POINTER)
1976 {
1977 oberon_initialize_type(ctx, type -> base);
1978 oberon_generator_init_type(ctx, type);
1979 }
1980 else if(type -> class == OBERON_TYPE_ARRAY)
1981 {
1982 oberon_initialize_type(ctx, type -> base);
1983 oberon_generator_init_type(ctx, type);
1984 }
1985 else if(type -> class == OBERON_TYPE_RECORD)
1986 {
1987 oberon_generator_init_type(ctx, type);
1988 oberon_initialize_record_fields(ctx, type);
1989 }
1990 else if(type -> class == OBERON_TYPE_PROCEDURE)
1991 {
1992 int num_fields = type -> num_decl;
1993 oberon_object_t * field = type -> decl;
1994 for(int i = 0; i < num_fields; i++)
1995 {
1996 oberon_initialize_object(ctx, field);
1997 field = field -> next;
1998 }
1999
2000 oberon_generator_init_type(ctx, type);
2001 }
2002 else
2003 {
2004 oberon_generator_init_type(ctx, type);
2005 }
2006 }
2007
2008 static void
2009 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2010 {
2011 if(x -> initialized)
2012 {
2013 return;
2014 }
2015
2016 x -> initialized = 1;
2017
2018 switch(x -> class)
2019 {
2020 case OBERON_CLASS_TYPE:
2021 oberon_initialize_type(ctx, x -> type);
2022 break;
2023 case OBERON_CLASS_VAR:
2024 case OBERON_CLASS_PARAM:
2025 case OBERON_CLASS_VAR_PARAM:
2026 case OBERON_CLASS_FIELD:
2027 oberon_initialize_type(ctx, x -> type);
2028 oberon_generator_init_var(ctx, x);
2029 break;
2030 case OBERON_CLASS_CONST:
2031 case OBERON_CLASS_PROC:
2032 break;
2033 default:
2034 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2035 break;
2036 }
2037 }
2038
2039 static void
2040 oberon_initialize_decl(oberon_context_t * ctx)
2041 {
2042 oberon_object_t * x = ctx -> decl -> list;
2043
2044 while(x -> next)
2045 {
2046 oberon_initialize_object(ctx, x -> next);
2047 x = x -> next;
2048 }
2049 }
2050
2051 static void
2052 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2053 {
2054 oberon_object_t * x = ctx -> decl -> list;
2055
2056 while(x -> next)
2057 {
2058 if(x -> next -> class == OBERON_CLASS_PROC)
2059 {
2060 if(x -> next -> linked == 0)
2061 {
2062 oberon_error(ctx, "unresolved forward declaration");
2063 }
2064 }
2065 x = x -> next;
2066 }
2067 }
2068
2069 static void
2070 oberon_decl_seq(oberon_context_t * ctx)
2071 {
2072 if(ctx -> token == CONST)
2073 {
2074 oberon_assert_token(ctx, CONST);
2075 while(ctx -> token == IDENT)
2076 {
2077 oberon_const_decl(ctx);
2078 oberon_assert_token(ctx, SEMICOLON);
2079 }
2080 }
2081
2082 if(ctx -> token == TYPE)
2083 {
2084 oberon_assert_token(ctx, TYPE);
2085 while(ctx -> token == IDENT)
2086 {
2087 oberon_type_decl(ctx);
2088 oberon_assert_token(ctx, SEMICOLON);
2089 }
2090 }
2091
2092 if(ctx -> token == VAR)
2093 {
2094 oberon_assert_token(ctx, VAR);
2095 while(ctx -> token == IDENT)
2096 {
2097 oberon_var_decl(ctx);
2098 oberon_assert_token(ctx, SEMICOLON);
2099 }
2100 }
2101
2102 oberon_prevent_recursive_decl(ctx);
2103 oberon_initialize_decl(ctx);
2104
2105 while(ctx -> token == PROCEDURE)
2106 {
2107 oberon_proc_decl(ctx);
2108 oberon_assert_token(ctx, SEMICOLON);
2109 }
2110
2111 oberon_prevent_undeclarated_procedures(ctx);
2112 }
2113
2114 static void
2115 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2116 {
2117 oberon_autocast_to(ctx, src, dst -> result);
2118 oberon_generate_assign(ctx, src, dst);
2119 }
2120
2121 static void
2122 oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
2123 {
2124 if(desig -> result -> class != OBERON_TYPE_VOID)
2125 {
2126 if(desig -> result -> class != OBERON_TYPE_PROCEDURE)
2127 {
2128 oberon_error(ctx, "procedure with result");
2129 }
2130 }
2131
2132 oberon_autocast_call(ctx, desig);
2133 oberon_generate_call_proc(ctx, desig);
2134 }
2135
2136 static void
2137 oberon_statement(oberon_context_t * ctx)
2138 {
2139 oberon_expr_t * item1;
2140 oberon_expr_t * item2;
2141
2142 if(ctx -> token == IDENT)
2143 {
2144 item1 = oberon_designator(ctx);
2145 if(ctx -> token == ASSIGN)
2146 {
2147 oberon_assert_token(ctx, ASSIGN);
2148 item2 = oberon_expr(ctx);
2149 oberon_assign(ctx, item2, item1);
2150 }
2151 else
2152 {
2153 item1 = oberon_opt_proc_parens(ctx, item1);
2154 oberon_make_call(ctx, item1);
2155 }
2156 }
2157 else if(ctx -> token == RETURN)
2158 {
2159 oberon_assert_token(ctx, RETURN);
2160 if(ISEXPR(ctx -> token))
2161 {
2162 oberon_expr_t * expr;
2163 expr = oberon_expr(ctx);
2164 oberon_make_return(ctx, expr);
2165 }
2166 else
2167 {
2168 oberon_make_return(ctx, NULL);
2169 }
2170 }
2171 }
2172
2173 static void
2174 oberon_statement_seq(oberon_context_t * ctx)
2175 {
2176 oberon_statement(ctx);
2177 while(ctx -> token == SEMICOLON)
2178 {
2179 oberon_assert_token(ctx, SEMICOLON);
2180 oberon_statement(ctx);
2181 }
2182 }
2183
2184 static void
2185 oberon_parse_module(oberon_context_t * ctx)
2186 {
2187 char *name1, *name2;
2188 oberon_read_token(ctx);
2189
2190 oberon_assert_token(ctx, MODULE);
2191 name1 = oberon_assert_ident(ctx);
2192 oberon_assert_token(ctx, SEMICOLON);
2193 ctx -> mod -> name = name1;
2194
2195 oberon_decl_seq(ctx);
2196
2197 if(ctx -> token == BEGIN)
2198 {
2199 oberon_assert_token(ctx, BEGIN);
2200 oberon_generate_begin_module(ctx);
2201 oberon_statement_seq(ctx);
2202 oberon_generate_end_module(ctx);
2203 }
2204
2205 oberon_assert_token(ctx, END);
2206 name2 = oberon_assert_ident(ctx);
2207 oberon_assert_token(ctx, DOT);
2208
2209 if(strcmp(name1, name2) != 0)
2210 {
2211 oberon_error(ctx, "module name not matched");
2212 }
2213 }
2214
2215 // =======================================================================
2216 // LIBRARY
2217 // =======================================================================
2218
2219 static void
2220 register_default_types(oberon_context_t * ctx)
2221 {
2222 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2223 oberon_generator_init_type(ctx, ctx -> void_type);
2224
2225 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
2226 ctx -> void_ptr_type -> base = ctx -> void_type;
2227 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
2228
2229 ctx -> int_type = oberon_new_type_integer(sizeof(int));
2230 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
2231
2232 ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
2233 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
2234 }
2235
2236 oberon_context_t *
2237 oberon_create_context()
2238 {
2239 oberon_context_t * ctx = malloc(sizeof *ctx);
2240 memset(ctx, 0, sizeof *ctx);
2241
2242 oberon_scope_t * world_scope;
2243 world_scope = oberon_open_scope(ctx);
2244 ctx -> world_scope = world_scope;
2245
2246 oberon_generator_init_context(ctx);
2247
2248 register_default_types(ctx);
2249
2250 return ctx;
2251 }
2252
2253 void
2254 oberon_destroy_context(oberon_context_t * ctx)
2255 {
2256 oberon_generator_destroy_context(ctx);
2257 free(ctx);
2258 }
2259
2260 oberon_module_t *
2261 oberon_compile_module(oberon_context_t * ctx, const char * code)
2262 {
2263 oberon_module_t * mod = malloc(sizeof *mod);
2264 memset(mod, 0, sizeof *mod);
2265 ctx -> mod = mod;
2266
2267 oberon_scope_t * module_scope;
2268 module_scope = oberon_open_scope(ctx);
2269 mod -> decl = module_scope;
2270
2271 oberon_init_scaner(ctx, code);
2272 oberon_parse_module(ctx);
2273
2274 oberon_generate_code(ctx);
2275
2276 ctx -> mod = NULL;
2277 return mod;
2278 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024