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 static oberon_expr_t *
781 oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
782 {
783 if(proc -> class != OBERON_CLASS_PROC)
784 {
785 oberon_error(ctx, "not a procedure");
786 }
787
788 oberon_expr_t * call;
789
790 if(proc -> sysproc)
791 {
792 if(proc -> genfunc == NULL)
793 {
794 oberon_error(ctx, "not a function-procedure");
795 }
796
797 call = proc -> genfunc(ctx, num_args, list_args);
798 }
799 else
800 {
801 if(proc -> type -> base -> class == OBERON_TYPE_VOID)
802 {
803 oberon_error(ctx, "attempt to call procedure in expression");
804 }
805
806 call = oberon_new_item(MODE_CALL, proc -> type -> base);
807 call -> item.var = proc;
808 call -> item.num_args = num_args;
809 call -> item.args = list_args;
810 oberon_autocast_call(ctx, call);
811 }
812
813 return call;
814 }
815
816 static void
817 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
818 {
819 if(proc -> class != OBERON_CLASS_PROC)
820 {
821 oberon_error(ctx, "not a procedure");
822 }
823
824 if(proc -> sysproc)
825 {
826 if(proc -> genproc == NULL)
827 {
828 oberon_error(ctx, "requres non-typed procedure");
829 }
830
831 proc -> genproc(ctx, num_args, list_args);
832 }
833 else
834 {
835 if(proc -> type -> base -> class != OBERON_TYPE_VOID)
836 {
837 oberon_error(ctx, "attempt to call function as non-typed procedure");
838 }
839
840 oberon_expr_t * call;
841 call = oberon_new_item(MODE_CALL, proc -> type -> base);
842 call -> item.var = proc;
843 call -> item.num_args = num_args;
844 call -> item.args = list_args;
845 oberon_autocast_call(ctx, call);
846 oberon_generate_call_proc(ctx, call);
847 }
848 }
849
850 #define ISEXPR(x) \
851 (((x) == PLUS) \
852 || ((x) == MINUS) \
853 || ((x) == IDENT) \
854 || ((x) == INTEGER) \
855 || ((x) == LPAREN) \
856 || ((x) == NOT) \
857 || ((x) == TRUE) \
858 || ((x) == FALSE))
859
860 static oberon_expr_t *
861 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
862 {
863 if(expr -> result -> class != OBERON_TYPE_POINTER)
864 {
865 oberon_error(ctx, "not a pointer");
866 }
867
868 assert(expr -> is_item);
869
870 oberon_expr_t * selector;
871 selector = oberon_new_item(MODE_DEREF, expr -> result -> base);
872 selector -> item.parent = (oberon_item_t *) expr;
873
874 return selector;
875 }
876
877 static oberon_expr_t *
878 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
879 {
880 if(desig -> result -> class == OBERON_TYPE_POINTER)
881 {
882 desig = oberno_make_dereferencing(ctx, desig);
883 }
884
885 assert(desig -> is_item);
886
887 if(desig -> result -> class != OBERON_TYPE_ARRAY)
888 {
889 oberon_error(ctx, "not array");
890 }
891
892 oberon_type_t * base;
893 base = desig -> result -> base;
894
895 if(index -> result -> class != OBERON_TYPE_INTEGER)
896 {
897 oberon_error(ctx, "index must be integer");
898 }
899
900 // Статическая проверка границ массива
901 if(index -> is_item)
902 {
903 if(index -> item.mode == MODE_INTEGER)
904 {
905 int arr_size = desig -> result -> size;
906 int index_int = index -> item.integer;
907 if(index_int < 0 || index_int > arr_size - 1)
908 {
909 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
910 }
911 }
912 }
913
914 oberon_expr_t * selector;
915 selector = oberon_new_item(MODE_INDEX, base);
916 selector -> item.parent = (oberon_item_t *) desig;
917 selector -> item.num_args = 1;
918 selector -> item.args = index;
919
920 return selector;
921 }
922
923 static oberon_expr_t *
924 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
925 {
926 if(expr -> result -> class == OBERON_TYPE_POINTER)
927 {
928 expr = oberno_make_dereferencing(ctx, expr);
929 }
930
931 assert(expr -> is_item == 1);
932
933 if(expr -> result -> class != OBERON_TYPE_RECORD)
934 {
935 oberon_error(ctx, "not record");
936 }
937
938 oberon_type_t * rec = expr -> result;
939
940 oberon_object_t * field;
941 field = oberon_find_field(ctx, rec, name);
942
943 oberon_expr_t * selector;
944 selector = oberon_new_item(MODE_FIELD, field -> type);
945 selector -> item.var = field;
946 selector -> item.parent = (oberon_item_t *) expr;
947
948 return selector;
949 }
950
951 #define ISSELECTOR(x) \
952 (((x) == LBRACE) \
953 || ((x) == DOT) \
954 || ((x) == UPARROW))
955
956 static oberon_expr_t *
957 oberon_designator(oberon_context_t * ctx)
958 {
959 char * name;
960 oberon_object_t * var;
961 oberon_expr_t * expr;
962
963 name = oberon_assert_ident(ctx);
964 var = oberon_find_object(ctx -> decl, name, 1);
965
966 switch(var -> class)
967 {
968 case OBERON_CLASS_CONST:
969 // TODO copy value
970 expr = (oberon_expr_t *) var -> value;
971 break;
972 case OBERON_CLASS_VAR:
973 case OBERON_CLASS_VAR_PARAM:
974 case OBERON_CLASS_PARAM:
975 expr = oberon_new_item(MODE_VAR, var -> type);
976 break;
977 case OBERON_CLASS_PROC:
978 //expr = oberon_make_call_expr(var, 0, NULL);
979 expr = oberon_new_item(MODE_CALL, var -> type);
980 break;
981 default:
982 oberon_error(ctx, "invalid designator");
983 break;
984 }
985 expr -> item.var = var;
986
987 while(ISSELECTOR(ctx -> token))
988 {
989 switch(ctx -> token)
990 {
991 case DOT:
992 oberon_assert_token(ctx, DOT);
993 name = oberon_assert_ident(ctx);
994 expr = oberon_make_record_selector(ctx, expr, name);
995 break;
996 case LBRACE:
997 oberon_assert_token(ctx, LBRACE);
998 int num_indexes = 0;
999 oberon_expr_t * indexes = NULL;
1000 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1001 oberon_assert_token(ctx, RBRACE);
1002
1003 for(int i = 0; i < num_indexes; i++)
1004 {
1005 expr = oberon_make_array_selector(ctx, expr, indexes);
1006 indexes = indexes -> next;
1007 }
1008 break;
1009 case UPARROW:
1010 oberon_assert_token(ctx, UPARROW);
1011 expr = oberno_make_dereferencing(ctx, expr);
1012 break;
1013 default:
1014 oberon_error(ctx, "oberon_designator: wat");
1015 break;
1016 }
1017 }
1018 return expr;
1019 }
1020
1021 static oberon_expr_t *
1022 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1023 {
1024 assert(expr -> is_item == 1);
1025
1026 if(ctx -> token == LPAREN)
1027 {
1028 oberon_assert_token(ctx, LPAREN);
1029
1030 int num_args = 0;
1031 oberon_expr_t * arguments = NULL;
1032
1033 if(ISEXPR(ctx -> token))
1034 {
1035 oberon_expr_list(ctx, &num_args, &arguments, 0);
1036 }
1037
1038 expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
1039
1040 oberon_assert_token(ctx, RPAREN);
1041 }
1042
1043 return expr;
1044 }
1045
1046 static void
1047 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1048 {
1049 assert(expr -> is_item == 1);
1050
1051 if(ctx -> token == LPAREN)
1052 {
1053 oberon_assert_token(ctx, LPAREN);
1054
1055 int num_args = 0;
1056 oberon_expr_t * arguments = NULL;
1057
1058 if(ISEXPR(ctx -> token))
1059 {
1060 oberon_expr_list(ctx, &num_args, &arguments, 0);
1061 }
1062
1063 oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
1064
1065 oberon_assert_token(ctx, RPAREN);
1066 }
1067 }
1068
1069 static oberon_expr_t *
1070 oberon_factor(oberon_context_t * ctx)
1071 {
1072 oberon_expr_t * expr;
1073
1074 switch(ctx -> token)
1075 {
1076 case IDENT:
1077 expr = oberon_designator(ctx);
1078 expr = oberon_opt_func_parens(ctx, expr);
1079 break;
1080 case INTEGER:
1081 expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
1082 expr -> item.integer = ctx -> integer;
1083 oberon_assert_token(ctx, INTEGER);
1084 break;
1085 case TRUE:
1086 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
1087 expr -> item.boolean = 1;
1088 oberon_assert_token(ctx, TRUE);
1089 break;
1090 case FALSE:
1091 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
1092 expr -> item.boolean = 0;
1093 oberon_assert_token(ctx, FALSE);
1094 break;
1095 case LPAREN:
1096 oberon_assert_token(ctx, LPAREN);
1097 expr = oberon_expr(ctx);
1098 oberon_assert_token(ctx, RPAREN);
1099 break;
1100 case NOT:
1101 oberon_assert_token(ctx, NOT);
1102 expr = oberon_factor(ctx);
1103 expr = oberon_make_unary_op(ctx, NOT, expr);
1104 break;
1105 case NIL:
1106 oberon_assert_token(ctx, NIL);
1107 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type);
1108 break;
1109 default:
1110 oberon_error(ctx, "invalid expression");
1111 }
1112
1113 return expr;
1114 }
1115
1116 /*
1117 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1118 * 1. Классы обоих типов должны быть одинаковы
1119 * 2. В качестве результата должен быть выбран больший тип.
1120 * 3. Если размер результат не должен быть меньше чем базовый int
1121 */
1122
1123 static void
1124 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
1125 {
1126 if((a -> class) != (b -> class))
1127 {
1128 oberon_error(ctx, "incompatible types");
1129 }
1130
1131 if((a -> size) > (b -> size))
1132 {
1133 *result = a;
1134 }
1135 else
1136 {
1137 *result = b;
1138 }
1139
1140 if(((*result) -> class) == OBERON_TYPE_INTEGER)
1141 {
1142 if(((*result) -> size) < (ctx -> int_type -> size))
1143 {
1144 *result = ctx -> int_type;
1145 }
1146 }
1147
1148 /* TODO: cast types */
1149 }
1150
1151 #define ITMAKESBOOLEAN(x) \
1152 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1153
1154 #define ITUSEONLYINTEGER(x) \
1155 ((x) >= LESS && (x) <= GEQ)
1156
1157 #define ITUSEONLYBOOLEAN(x) \
1158 (((x) == OR) || ((x) == AND))
1159
1160 static oberon_expr_t *
1161 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1162 {
1163 oberon_expr_t * expr;
1164 oberon_type_t * result;
1165
1166 if(ITMAKESBOOLEAN(token))
1167 {
1168 if(ITUSEONLYINTEGER(token))
1169 {
1170 if(a -> result -> class != OBERON_TYPE_INTEGER
1171 || b -> result -> class != OBERON_TYPE_INTEGER)
1172 {
1173 oberon_error(ctx, "used only with integer types");
1174 }
1175 }
1176 else if(ITUSEONLYBOOLEAN(token))
1177 {
1178 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1179 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1180 {
1181 oberon_error(ctx, "used only with boolean type");
1182 }
1183 }
1184
1185 result = ctx -> bool_type;
1186
1187 if(token == EQUAL)
1188 {
1189 expr = oberon_new_operator(OP_EQ, result, a, b);
1190 }
1191 else if(token == NEQ)
1192 {
1193 expr = oberon_new_operator(OP_NEQ, result, a, b);
1194 }
1195 else if(token == LESS)
1196 {
1197 expr = oberon_new_operator(OP_LSS, result, a, b);
1198 }
1199 else if(token == LEQ)
1200 {
1201 expr = oberon_new_operator(OP_LEQ, result, a, b);
1202 }
1203 else if(token == GREAT)
1204 {
1205 expr = oberon_new_operator(OP_GRT, result, a, b);
1206 }
1207 else if(token == GEQ)
1208 {
1209 expr = oberon_new_operator(OP_GEQ, result, a, b);
1210 }
1211 else if(token == OR)
1212 {
1213 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1214 }
1215 else if(token == AND)
1216 {
1217 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1218 }
1219 else
1220 {
1221 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1222 }
1223 }
1224 else
1225 {
1226 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1227
1228 if(token == PLUS)
1229 {
1230 expr = oberon_new_operator(OP_ADD, result, a, b);
1231 }
1232 else if(token == MINUS)
1233 {
1234 expr = oberon_new_operator(OP_SUB, result, a, b);
1235 }
1236 else if(token == STAR)
1237 {
1238 expr = oberon_new_operator(OP_MUL, result, a, b);
1239 }
1240 else if(token == SLASH)
1241 {
1242 expr = oberon_new_operator(OP_DIV, result, a, b);
1243 }
1244 else if(token == DIV)
1245 {
1246 expr = oberon_new_operator(OP_DIV, result, a, b);
1247 }
1248 else if(token == MOD)
1249 {
1250 expr = oberon_new_operator(OP_MOD, result, a, b);
1251 }
1252 else
1253 {
1254 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1255 }
1256 }
1257
1258 return expr;
1259 }
1260
1261 #define ISMULOP(x) \
1262 ((x) >= STAR && (x) <= AND)
1263
1264 static oberon_expr_t *
1265 oberon_term_expr(oberon_context_t * ctx)
1266 {
1267 oberon_expr_t * expr;
1268
1269 expr = oberon_factor(ctx);
1270 while(ISMULOP(ctx -> token))
1271 {
1272 int token = ctx -> token;
1273 oberon_read_token(ctx);
1274
1275 oberon_expr_t * inter = oberon_factor(ctx);
1276 expr = oberon_make_bin_op(ctx, token, expr, inter);
1277 }
1278
1279 return expr;
1280 }
1281
1282 #define ISADDOP(x) \
1283 ((x) >= PLUS && (x) <= OR)
1284
1285 static oberon_expr_t *
1286 oberon_simple_expr(oberon_context_t * ctx)
1287 {
1288 oberon_expr_t * expr;
1289
1290 int minus = 0;
1291 if(ctx -> token == PLUS)
1292 {
1293 minus = 0;
1294 oberon_assert_token(ctx, PLUS);
1295 }
1296 else if(ctx -> token == MINUS)
1297 {
1298 minus = 1;
1299 oberon_assert_token(ctx, MINUS);
1300 }
1301
1302 expr = oberon_term_expr(ctx);
1303 while(ISADDOP(ctx -> token))
1304 {
1305 int token = ctx -> token;
1306 oberon_read_token(ctx);
1307
1308 oberon_expr_t * inter = oberon_term_expr(ctx);
1309 expr = oberon_make_bin_op(ctx, token, expr, inter);
1310 }
1311
1312 if(minus)
1313 {
1314 expr = oberon_make_unary_op(ctx, MINUS, expr);
1315 }
1316
1317 return expr;
1318 }
1319
1320 #define ISRELATION(x) \
1321 ((x) >= EQUAL && (x) <= GEQ)
1322
1323 static oberon_expr_t *
1324 oberon_expr(oberon_context_t * ctx)
1325 {
1326 oberon_expr_t * expr;
1327
1328 expr = oberon_simple_expr(ctx);
1329 while(ISRELATION(ctx -> token))
1330 {
1331 int token = ctx -> token;
1332 oberon_read_token(ctx);
1333
1334 oberon_expr_t * inter = oberon_simple_expr(ctx);
1335 expr = oberon_make_bin_op(ctx, token, expr, inter);
1336 }
1337
1338 return expr;
1339 }
1340
1341 static oberon_item_t *
1342 oberon_const_expr(oberon_context_t * ctx)
1343 {
1344 oberon_expr_t * expr;
1345 expr = oberon_expr(ctx);
1346
1347 if(expr -> is_item == 0)
1348 {
1349 oberon_error(ctx, "const expression are required");
1350 }
1351
1352 return (oberon_item_t *) expr;
1353 }
1354
1355 // =======================================================================
1356 // PARSER
1357 // =======================================================================
1358
1359 static void oberon_decl_seq(oberon_context_t * ctx);
1360 static void oberon_statement_seq(oberon_context_t * ctx);
1361 static void oberon_initialize_decl(oberon_context_t * ctx);
1362
1363 static void
1364 oberon_expect_token(oberon_context_t * ctx, int token)
1365 {
1366 if(ctx -> token != token)
1367 {
1368 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1369 }
1370 }
1371
1372 static void
1373 oberon_assert_token(oberon_context_t * ctx, int token)
1374 {
1375 oberon_expect_token(ctx, token);
1376 oberon_read_token(ctx);
1377 }
1378
1379 static char *
1380 oberon_assert_ident(oberon_context_t * ctx)
1381 {
1382 oberon_expect_token(ctx, IDENT);
1383 char * ident = ctx -> string;
1384 oberon_read_token(ctx);
1385 return ident;
1386 }
1387
1388 static void
1389 oberon_var_decl(oberon_context_t * ctx)
1390 {
1391 char * name;
1392 oberon_type_t * type;
1393 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1394
1395 name = oberon_assert_ident(ctx);
1396 oberon_assert_token(ctx, COLON);
1397 oberon_type(ctx, &type);
1398 oberon_define_var(ctx -> decl, OBERON_CLASS_VAR, name, type);
1399 }
1400
1401 static oberon_object_t *
1402 oberon_make_param(oberon_context_t * ctx, int token, char * name, oberon_type_t * type)
1403 {
1404 oberon_object_t * param;
1405
1406 if(token == VAR)
1407 {
1408 param = oberon_define_var(ctx -> decl, OBERON_CLASS_VAR_PARAM, name, type);
1409 }
1410 else if(token == IDENT)
1411 {
1412 param = oberon_define_var(ctx -> decl, OBERON_CLASS_PARAM, name, type);
1413 }
1414 else
1415 {
1416 oberon_error(ctx, "oberon_make_param: wat");
1417 }
1418
1419 return param;
1420 }
1421
1422 static oberon_object_t *
1423 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1424 {
1425 int modifer_token = ctx -> token;
1426 if(ctx -> token == VAR)
1427 {
1428 oberon_read_token(ctx);
1429 }
1430
1431 char * name;
1432 name = oberon_assert_ident(ctx);
1433
1434 oberon_assert_token(ctx, COLON);
1435
1436 oberon_type_t * type;
1437 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1438 oberon_type(ctx, &type);
1439
1440 oberon_object_t * first;
1441 first = oberon_make_param(ctx, modifer_token, name, type);
1442
1443 *num_decl += 1;
1444 return first;
1445 }
1446
1447 #define ISFPSECTION \
1448 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1449
1450 static void
1451 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1452 {
1453 oberon_assert_token(ctx, LPAREN);
1454
1455 if(ISFPSECTION)
1456 {
1457 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
1458 while(ctx -> token == SEMICOLON)
1459 {
1460 oberon_assert_token(ctx, SEMICOLON);
1461 oberon_fp_section(ctx, &signature -> num_decl);
1462 }
1463 }
1464
1465 oberon_assert_token(ctx, RPAREN);
1466
1467 if(ctx -> token == COLON)
1468 {
1469 oberon_assert_token(ctx, COLON);
1470 // TODO get by qualident
1471 oberon_type(ctx, &signature -> base);
1472 }
1473 }
1474
1475 static void
1476 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
1477 {
1478 oberon_type_t * signature;
1479 signature = *type;
1480 signature -> class = OBERON_TYPE_PROCEDURE;
1481 signature -> num_decl = 0;
1482 signature -> base = ctx -> void_type;
1483 signature -> decl = NULL;
1484
1485 if(ctx -> token == LPAREN)
1486 {
1487 oberon_formal_pars(ctx, signature);
1488 }
1489 }
1490
1491 static void
1492 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1493 {
1494 if(a -> num_decl != b -> num_decl)
1495 {
1496 oberon_error(ctx, "number parameters not matched");
1497 }
1498
1499 int num_param = a -> num_decl;
1500 oberon_object_t * param_a = a -> decl;
1501 oberon_object_t * param_b = b -> decl;
1502 for(int i = 0; i < num_param; i++)
1503 {
1504 if(strcmp(param_a -> name, param_b -> name) != 0)
1505 {
1506 oberon_error(ctx, "param %i name not matched", i + 1);
1507 }
1508
1509 if(param_a -> type != param_b -> type)
1510 {
1511 oberon_error(ctx, "param %i type not matched", i + 1);
1512 }
1513
1514 param_a = param_a -> next;
1515 param_b = param_b -> next;
1516 }
1517 }
1518
1519 static void
1520 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1521 {
1522 oberon_object_t * proc = ctx -> decl -> parent;
1523 oberon_type_t * result_type = proc -> type -> base;
1524
1525 if(result_type -> class == OBERON_TYPE_VOID)
1526 {
1527 if(expr != NULL)
1528 {
1529 oberon_error(ctx, "procedure has no result type");
1530 }
1531 }
1532 else
1533 {
1534 if(expr == NULL)
1535 {
1536 oberon_error(ctx, "procedure requires expression on result");
1537 }
1538
1539 oberon_autocast_to(ctx, expr, result_type);
1540 }
1541
1542 proc -> has_return = 1;
1543
1544 oberon_generate_return(ctx, expr);
1545 }
1546
1547 static void
1548 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
1549 {
1550 oberon_assert_token(ctx, SEMICOLON);
1551
1552 ctx -> decl = proc -> scope;
1553
1554 oberon_decl_seq(ctx);
1555
1556 oberon_generate_begin_proc(ctx, proc);
1557
1558 if(ctx -> token == BEGIN)
1559 {
1560 oberon_assert_token(ctx, BEGIN);
1561 oberon_statement_seq(ctx);
1562 }
1563
1564 oberon_assert_token(ctx, END);
1565 char * name = oberon_assert_ident(ctx);
1566 if(strcmp(name, proc -> name) != 0)
1567 {
1568 oberon_error(ctx, "procedure name not matched");
1569 }
1570
1571 if(proc -> type -> base -> class == OBERON_TYPE_VOID
1572 && proc -> has_return == 0)
1573 {
1574 oberon_make_return(ctx, NULL);
1575 }
1576
1577 if(proc -> has_return == 0)
1578 {
1579 oberon_error(ctx, "procedure requires return");
1580 }
1581
1582 oberon_generate_end_proc(ctx);
1583 oberon_close_scope(ctx -> decl);
1584 }
1585
1586 static void
1587 oberon_proc_decl(oberon_context_t * ctx)
1588 {
1589 oberon_assert_token(ctx, PROCEDURE);
1590
1591 int forward = 0;
1592 if(ctx -> token == UPARROW)
1593 {
1594 oberon_assert_token(ctx, UPARROW);
1595 forward = 1;
1596 }
1597
1598 char * name;
1599 name = oberon_assert_ident(ctx);
1600
1601 oberon_scope_t * proc_scope;
1602 proc_scope = oberon_open_scope(ctx);
1603 ctx -> decl -> local = 1;
1604
1605 oberon_type_t * signature;
1606 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
1607 oberon_opt_formal_pars(ctx, &signature);
1608
1609 oberon_initialize_decl(ctx);
1610 oberon_generator_init_type(ctx, signature);
1611 oberon_close_scope(ctx -> decl);
1612
1613 oberon_object_t * proc;
1614 proc = oberon_find_object(ctx -> decl, name, 0);
1615 if(proc != NULL)
1616 {
1617 if(proc -> class != OBERON_CLASS_PROC)
1618 {
1619 oberon_error(ctx, "mult definition");
1620 }
1621
1622 if(forward == 0)
1623 {
1624 if(proc -> linked)
1625 {
1626 oberon_error(ctx, "mult procedure definition");
1627 }
1628 }
1629
1630 oberon_compare_signatures(ctx, proc -> type, signature);
1631 }
1632 else
1633 {
1634 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
1635 proc -> type = signature;
1636 proc -> scope = proc_scope;
1637 oberon_generator_init_proc(ctx, proc);
1638 }
1639
1640 proc -> scope -> parent = proc;
1641
1642 if(forward == 0)
1643 {
1644 proc -> linked = 1;
1645 oberon_proc_decl_body(ctx, proc);
1646 }
1647 }
1648
1649 static void
1650 oberon_const_decl(oberon_context_t * ctx)
1651 {
1652 char * name;
1653 oberon_item_t * value;
1654 oberon_object_t * constant;
1655
1656 name = oberon_assert_ident(ctx);
1657 oberon_assert_token(ctx, EQUAL);
1658 value = oberon_const_expr(ctx);
1659
1660 constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST);
1661 constant -> value = value;
1662 }
1663
1664 static void
1665 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
1666 {
1667 if(size -> is_item == 0)
1668 {
1669 oberon_error(ctx, "requires constant");
1670 }
1671
1672 if(size -> item.mode != MODE_INTEGER)
1673 {
1674 oberon_error(ctx, "requires integer constant");
1675 }
1676
1677 oberon_type_t * arr;
1678 arr = *type;
1679 arr -> class = OBERON_TYPE_ARRAY;
1680 arr -> size = size -> item.integer;
1681 arr -> base = base;
1682 }
1683
1684 static void
1685 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1686 {
1687 if(ctx -> token == IDENT)
1688 {
1689 char * name;
1690 oberon_type_t * type;
1691 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1692
1693 name = oberon_assert_ident(ctx);
1694 oberon_assert_token(ctx, COLON);
1695 oberon_type(ctx, &type);
1696 oberon_define_field(ctx, rec, name, type);
1697 }
1698 }
1699
1700 static void
1701 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
1702 {
1703 char * name;
1704 oberon_object_t * to;
1705
1706 name = oberon_assert_ident(ctx);
1707 to = oberon_find_object(ctx -> decl, name, 0);
1708
1709 if(to != NULL)
1710 {
1711 if(to -> class != OBERON_CLASS_TYPE)
1712 {
1713 oberon_error(ctx, "not a type");
1714 }
1715 }
1716 else
1717 {
1718 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1719 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1720 }
1721
1722 *type = to -> type;
1723 }
1724
1725 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
1726
1727 /*
1728 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1729 */
1730
1731 static void
1732 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
1733 {
1734 if(sizes == NULL)
1735 {
1736 *type = base;
1737 return;
1738 }
1739
1740 oberon_type_t * dim;
1741 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
1742
1743 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
1744
1745 oberon_make_array_type(ctx, sizes, dim, type);
1746 }
1747
1748 static void
1749 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
1750 {
1751 if(ctx -> token == IDENT)
1752 {
1753 oberon_qualident_type(ctx, type);
1754 }
1755 else if(ctx -> token == ARRAY)
1756 {
1757 oberon_assert_token(ctx, ARRAY);
1758
1759 int num_sizes = 0;
1760 oberon_expr_t * sizes;
1761 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
1762
1763 oberon_assert_token(ctx, OF);
1764
1765 oberon_type_t * base;
1766 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1767 oberon_type(ctx, &base);
1768
1769 oberon_make_multiarray(ctx, sizes, base, type);
1770 }
1771 else if(ctx -> token == RECORD)
1772 {
1773 oberon_type_t * rec;
1774 rec = *type;
1775 rec -> class = OBERON_TYPE_RECORD;
1776 oberon_object_t * list = malloc(sizeof *list);
1777 memset(list, 0, sizeof *list);
1778 rec -> num_decl = 0;
1779 rec -> base = NULL;
1780 rec -> decl = list;
1781
1782 oberon_assert_token(ctx, RECORD);
1783 oberon_field_list(ctx, rec);
1784 while(ctx -> token == SEMICOLON)
1785 {
1786 oberon_assert_token(ctx, SEMICOLON);
1787 oberon_field_list(ctx, rec);
1788 }
1789 oberon_assert_token(ctx, END);
1790
1791 rec -> decl = rec -> decl -> next;
1792 *type = rec;
1793 }
1794 else if(ctx -> token == POINTER)
1795 {
1796 oberon_assert_token(ctx, POINTER);
1797 oberon_assert_token(ctx, TO);
1798
1799 oberon_type_t * base;
1800 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1801 oberon_type(ctx, &base);
1802
1803 oberon_type_t * ptr;
1804 ptr = *type;
1805 ptr -> class = OBERON_TYPE_POINTER;
1806 ptr -> base = base;
1807 }
1808 else if(ctx -> token == PROCEDURE)
1809 {
1810 oberon_open_scope(ctx);
1811 oberon_assert_token(ctx, PROCEDURE);
1812 oberon_opt_formal_pars(ctx, type);
1813 oberon_close_scope(ctx -> decl);
1814 }
1815 else
1816 {
1817 oberon_error(ctx, "invalid type declaration");
1818 }
1819 }
1820
1821 static void
1822 oberon_type_decl(oberon_context_t * ctx)
1823 {
1824 char * name;
1825 oberon_object_t * newtype;
1826 oberon_type_t * type;
1827
1828 name = oberon_assert_ident(ctx);
1829
1830 newtype = oberon_find_object(ctx -> decl, name, 0);
1831 if(newtype == NULL)
1832 {
1833 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1834 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1835 assert(newtype -> type);
1836 }
1837 else
1838 {
1839 if(newtype -> class != OBERON_CLASS_TYPE)
1840 {
1841 oberon_error(ctx, "mult definition");
1842 }
1843
1844 if(newtype -> linked)
1845 {
1846 oberon_error(ctx, "mult definition - already linked");
1847 }
1848 }
1849
1850 oberon_assert_token(ctx, EQUAL);
1851
1852 type = newtype -> type;
1853 oberon_type(ctx, &type);
1854
1855 if(type -> class == OBERON_TYPE_VOID)
1856 {
1857 oberon_error(ctx, "recursive alias declaration");
1858 }
1859
1860 newtype -> type = type;
1861 newtype -> linked = 1;
1862 }
1863
1864 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
1865 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
1866
1867 static void
1868 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
1869 {
1870 if(type -> class != OBERON_TYPE_POINTER
1871 && type -> class != OBERON_TYPE_ARRAY)
1872 {
1873 return;
1874 }
1875
1876 if(type -> recursive)
1877 {
1878 oberon_error(ctx, "recursive pointer declaration");
1879 }
1880
1881 if(type -> base -> class == OBERON_TYPE_POINTER)
1882 {
1883 oberon_error(ctx, "attempt to make pointer to pointer");
1884 }
1885
1886 type -> recursive = 1;
1887
1888 oberon_prevent_recursive_pointer(ctx, type -> base);
1889
1890 type -> recursive = 0;
1891 }
1892
1893 static void
1894 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
1895 {
1896 if(type -> class != OBERON_TYPE_RECORD)
1897 {
1898 return;
1899 }
1900
1901 if(type -> recursive)
1902 {
1903 oberon_error(ctx, "recursive record declaration");
1904 }
1905
1906 type -> recursive = 1;
1907
1908 int num_fields = type -> num_decl;
1909 oberon_object_t * field = type -> decl;
1910 for(int i = 0; i < num_fields; i++)
1911 {
1912 oberon_prevent_recursive_object(ctx, field);
1913 field = field -> next;
1914 }
1915
1916 type -> recursive = 0;
1917 }
1918 static void
1919 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
1920 {
1921 if(type -> class != OBERON_TYPE_PROCEDURE)
1922 {
1923 return;
1924 }
1925
1926 if(type -> recursive)
1927 {
1928 oberon_error(ctx, "recursive procedure declaration");
1929 }
1930
1931 type -> recursive = 1;
1932
1933 int num_fields = type -> num_decl;
1934 oberon_object_t * field = type -> decl;
1935 for(int i = 0; i < num_fields; i++)
1936 {
1937 oberon_prevent_recursive_object(ctx, field);
1938 field = field -> next;
1939 }
1940
1941 type -> recursive = 0;
1942 }
1943
1944 static void
1945 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
1946 {
1947 if(type -> class != OBERON_TYPE_ARRAY)
1948 {
1949 return;
1950 }
1951
1952 if(type -> recursive)
1953 {
1954 oberon_error(ctx, "recursive array declaration");
1955 }
1956
1957 type -> recursive = 1;
1958
1959 oberon_prevent_recursive_type(ctx, type -> base);
1960
1961 type -> recursive = 0;
1962 }
1963
1964 static void
1965 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
1966 {
1967 if(type -> class == OBERON_TYPE_POINTER)
1968 {
1969 oberon_prevent_recursive_pointer(ctx, type);
1970 }
1971 else if(type -> class == OBERON_TYPE_RECORD)
1972 {
1973 oberon_prevent_recursive_record(ctx, type);
1974 }
1975 else if(type -> class == OBERON_TYPE_ARRAY)
1976 {
1977 oberon_prevent_recursive_array(ctx, type);
1978 }
1979 else if(type -> class == OBERON_TYPE_PROCEDURE)
1980 {
1981 oberon_prevent_recursive_procedure(ctx, type);
1982 }
1983 }
1984
1985 static void
1986 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
1987 {
1988 switch(x -> class)
1989 {
1990 case OBERON_CLASS_VAR:
1991 case OBERON_CLASS_TYPE:
1992 case OBERON_CLASS_PARAM:
1993 case OBERON_CLASS_VAR_PARAM:
1994 case OBERON_CLASS_FIELD:
1995 oberon_prevent_recursive_type(ctx, x -> type);
1996 break;
1997 case OBERON_CLASS_CONST:
1998 case OBERON_CLASS_PROC:
1999 break;
2000 default:
2001 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2002 break;
2003 }
2004 }
2005
2006 static void
2007 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2008 {
2009 oberon_object_t * x = ctx -> decl -> list -> next;
2010
2011 while(x)
2012 {
2013 oberon_prevent_recursive_object(ctx, x);
2014 x = x -> next;
2015 }
2016 }
2017
2018 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2019 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2020
2021 static void
2022 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2023 {
2024 if(type -> class != OBERON_TYPE_RECORD)
2025 {
2026 return;
2027 }
2028
2029 int num_fields = type -> num_decl;
2030 oberon_object_t * field = type -> decl;
2031 for(int i = 0; i < num_fields; i++)
2032 {
2033 if(field -> type -> class == OBERON_TYPE_POINTER)
2034 {
2035 oberon_initialize_type(ctx, field -> type);
2036 }
2037
2038 oberon_initialize_object(ctx, field);
2039 field = field -> next;
2040 }
2041
2042 oberon_generator_init_record(ctx, type);
2043 }
2044
2045 static void
2046 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2047 {
2048 if(type -> class == OBERON_TYPE_VOID)
2049 {
2050 oberon_error(ctx, "undeclarated type");
2051 }
2052
2053 if(type -> initialized)
2054 {
2055 return;
2056 }
2057
2058 type -> initialized = 1;
2059
2060 if(type -> class == OBERON_TYPE_POINTER)
2061 {
2062 oberon_initialize_type(ctx, type -> base);
2063 oberon_generator_init_type(ctx, type);
2064 }
2065 else if(type -> class == OBERON_TYPE_ARRAY)
2066 {
2067 oberon_initialize_type(ctx, type -> base);
2068 oberon_generator_init_type(ctx, type);
2069 }
2070 else if(type -> class == OBERON_TYPE_RECORD)
2071 {
2072 oberon_generator_init_type(ctx, type);
2073 oberon_initialize_record_fields(ctx, type);
2074 }
2075 else if(type -> class == OBERON_TYPE_PROCEDURE)
2076 {
2077 int num_fields = type -> num_decl;
2078 oberon_object_t * field = type -> decl;
2079 for(int i = 0; i < num_fields; i++)
2080 {
2081 oberon_initialize_object(ctx, field);
2082 field = field -> next;
2083 }
2084
2085 oberon_generator_init_type(ctx, type);
2086 }
2087 else
2088 {
2089 oberon_generator_init_type(ctx, type);
2090 }
2091 }
2092
2093 static void
2094 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2095 {
2096 if(x -> initialized)
2097 {
2098 return;
2099 }
2100
2101 x -> initialized = 1;
2102
2103 switch(x -> class)
2104 {
2105 case OBERON_CLASS_TYPE:
2106 oberon_initialize_type(ctx, x -> type);
2107 break;
2108 case OBERON_CLASS_VAR:
2109 case OBERON_CLASS_PARAM:
2110 case OBERON_CLASS_VAR_PARAM:
2111 case OBERON_CLASS_FIELD:
2112 oberon_initialize_type(ctx, x -> type);
2113 oberon_generator_init_var(ctx, x);
2114 break;
2115 case OBERON_CLASS_CONST:
2116 case OBERON_CLASS_PROC:
2117 break;
2118 default:
2119 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2120 break;
2121 }
2122 }
2123
2124 static void
2125 oberon_initialize_decl(oberon_context_t * ctx)
2126 {
2127 oberon_object_t * x = ctx -> decl -> list;
2128
2129 while(x -> next)
2130 {
2131 oberon_initialize_object(ctx, x -> next);
2132 x = x -> next;
2133 }
2134 }
2135
2136 static void
2137 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2138 {
2139 oberon_object_t * x = ctx -> decl -> list;
2140
2141 while(x -> next)
2142 {
2143 if(x -> next -> class == OBERON_CLASS_PROC)
2144 {
2145 if(x -> next -> linked == 0)
2146 {
2147 oberon_error(ctx, "unresolved forward declaration");
2148 }
2149 }
2150 x = x -> next;
2151 }
2152 }
2153
2154 static void
2155 oberon_decl_seq(oberon_context_t * ctx)
2156 {
2157 if(ctx -> token == CONST)
2158 {
2159 oberon_assert_token(ctx, CONST);
2160 while(ctx -> token == IDENT)
2161 {
2162 oberon_const_decl(ctx);
2163 oberon_assert_token(ctx, SEMICOLON);
2164 }
2165 }
2166
2167 if(ctx -> token == TYPE)
2168 {
2169 oberon_assert_token(ctx, TYPE);
2170 while(ctx -> token == IDENT)
2171 {
2172 oberon_type_decl(ctx);
2173 oberon_assert_token(ctx, SEMICOLON);
2174 }
2175 }
2176
2177 if(ctx -> token == VAR)
2178 {
2179 oberon_assert_token(ctx, VAR);
2180 while(ctx -> token == IDENT)
2181 {
2182 oberon_var_decl(ctx);
2183 oberon_assert_token(ctx, SEMICOLON);
2184 }
2185 }
2186
2187 oberon_prevent_recursive_decl(ctx);
2188 oberon_initialize_decl(ctx);
2189
2190 while(ctx -> token == PROCEDURE)
2191 {
2192 oberon_proc_decl(ctx);
2193 oberon_assert_token(ctx, SEMICOLON);
2194 }
2195
2196 oberon_prevent_undeclarated_procedures(ctx);
2197 }
2198
2199 static void
2200 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2201 {
2202 oberon_autocast_to(ctx, src, dst -> result);
2203 oberon_generate_assign(ctx, src, dst);
2204 }
2205
2206 static void
2207 oberon_statement(oberon_context_t * ctx)
2208 {
2209 oberon_expr_t * item1;
2210 oberon_expr_t * item2;
2211
2212 if(ctx -> token == IDENT)
2213 {
2214 item1 = oberon_designator(ctx);
2215 if(ctx -> token == ASSIGN)
2216 {
2217 oberon_assert_token(ctx, ASSIGN);
2218 item2 = oberon_expr(ctx);
2219 oberon_assign(ctx, item2, item1);
2220 }
2221 else
2222 {
2223 oberon_opt_proc_parens(ctx, item1);
2224 }
2225 }
2226 else if(ctx -> token == RETURN)
2227 {
2228 oberon_assert_token(ctx, RETURN);
2229 if(ISEXPR(ctx -> token))
2230 {
2231 oberon_expr_t * expr;
2232 expr = oberon_expr(ctx);
2233 oberon_make_return(ctx, expr);
2234 }
2235 else
2236 {
2237 oberon_make_return(ctx, NULL);
2238 }
2239 }
2240 }
2241
2242 static void
2243 oberon_statement_seq(oberon_context_t * ctx)
2244 {
2245 oberon_statement(ctx);
2246 while(ctx -> token == SEMICOLON)
2247 {
2248 oberon_assert_token(ctx, SEMICOLON);
2249 oberon_statement(ctx);
2250 }
2251 }
2252
2253 static void
2254 oberon_parse_module(oberon_context_t * ctx)
2255 {
2256 char *name1, *name2;
2257 oberon_read_token(ctx);
2258
2259 oberon_assert_token(ctx, MODULE);
2260 name1 = oberon_assert_ident(ctx);
2261 oberon_assert_token(ctx, SEMICOLON);
2262 ctx -> mod -> name = name1;
2263
2264 oberon_decl_seq(ctx);
2265
2266 if(ctx -> token == BEGIN)
2267 {
2268 oberon_assert_token(ctx, BEGIN);
2269 oberon_generate_begin_module(ctx);
2270 oberon_statement_seq(ctx);
2271 oberon_generate_end_module(ctx);
2272 }
2273
2274 oberon_assert_token(ctx, END);
2275 name2 = oberon_assert_ident(ctx);
2276 oberon_assert_token(ctx, DOT);
2277
2278 if(strcmp(name1, name2) != 0)
2279 {
2280 oberon_error(ctx, "module name not matched");
2281 }
2282 }
2283
2284 // =======================================================================
2285 // LIBRARY
2286 // =======================================================================
2287
2288 static void
2289 register_default_types(oberon_context_t * ctx)
2290 {
2291 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2292 oberon_generator_init_type(ctx, ctx -> void_type);
2293
2294 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
2295 ctx -> void_ptr_type -> base = ctx -> void_type;
2296 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
2297
2298 ctx -> int_type = oberon_new_type_integer(sizeof(int));
2299 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
2300
2301 ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
2302 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
2303 }
2304
2305 static void
2306 oberon_new_intrinsic_function(oberon_context_t * ctx, char * name, GenerateFuncCallback generate)
2307 {
2308 oberon_object_t * proc;
2309 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
2310 proc -> sysproc = 1;
2311 proc -> genfunc = generate;
2312 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
2313 }
2314
2315 /*
2316 static void
2317 oberon_new_intrinsic_procedure(oberon_context_t * ctx, char * name, GenerateProcCallback generate)
2318 {
2319 oberon_object_t * proc;
2320 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC);
2321 proc -> sysproc = 1;
2322 proc -> genproc = generate;
2323 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
2324 }
2325 */
2326
2327 static oberon_expr_t *
2328 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2329 {
2330 if(num_args < 1)
2331 {
2332 oberon_error(ctx, "too few arguments");
2333 }
2334
2335 if(num_args > 1)
2336 {
2337 oberon_error(ctx, "too mach arguments");
2338 }
2339
2340 oberon_expr_t * arg;
2341 arg = list_args;
2342
2343 oberon_type_t * result_type;
2344 result_type = arg -> result;
2345
2346 if(result_type -> class != OBERON_TYPE_INTEGER)
2347 {
2348 oberon_error(ctx, "ABS accepts only integers");
2349 }
2350
2351
2352 oberon_expr_t * expr;
2353 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
2354 return expr;
2355 }
2356
2357 oberon_context_t *
2358 oberon_create_context()
2359 {
2360 oberon_context_t * ctx = malloc(sizeof *ctx);
2361 memset(ctx, 0, sizeof *ctx);
2362
2363 oberon_scope_t * world_scope;
2364 world_scope = oberon_open_scope(ctx);
2365 ctx -> world_scope = world_scope;
2366
2367 oberon_generator_init_context(ctx);
2368
2369 register_default_types(ctx);
2370 oberon_new_intrinsic_function(ctx, "ABS", oberon_make_abs_call);
2371
2372 return ctx;
2373 }
2374
2375 void
2376 oberon_destroy_context(oberon_context_t * ctx)
2377 {
2378 oberon_generator_destroy_context(ctx);
2379 free(ctx);
2380 }
2381
2382 oberon_module_t *
2383 oberon_compile_module(oberon_context_t * ctx, const char * code)
2384 {
2385 oberon_module_t * mod = malloc(sizeof *mod);
2386 memset(mod, 0, sizeof *mod);
2387 ctx -> mod = mod;
2388
2389 oberon_scope_t * module_scope;
2390 module_scope = oberon_open_scope(ctx);
2391 mod -> decl = module_scope;
2392
2393 oberon_init_scaner(ctx, code);
2394 oberon_parse_module(ctx);
2395
2396 oberon_generate_code(ctx);
2397
2398 ctx -> mod = NULL;
2399 return mod;
2400 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024