DEADSOFTWARE
GIT / REPO / FRED-BOY

Projects / dsw-obn.git / blob


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