DEADSOFTWARE

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


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