DEADSOFTWARE

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


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