DEADSOFTWARE

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


7ca600e205a26e377f25bea0de64ff7ad0c758cf
[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 };
55
56 // =======================================================================
57 // UTILS
58 // =======================================================================
59
60 void
61 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
62 {
63 va_list ptr;
64 va_start(ptr, fmt);
65 fprintf(stderr, "error: ");
66 vfprintf(stderr, fmt, ptr);
67 fprintf(stderr, "\n");
68 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
69 fprintf(stderr, " c = %c\n", ctx -> c);
70 fprintf(stderr, " token = %i\n", ctx -> token);
71 va_end(ptr);
72 exit(1);
73 }
74
75 static oberon_type_t *
76 oberon_new_type_ptr(int class)
77 {
78 oberon_type_t * x = malloc(sizeof *x);
79 memset(x, 0, sizeof *x);
80 x -> class = class;
81 return x;
82 }
83
84 static oberon_type_t *
85 oberon_new_type_integer(int size)
86 {
87 oberon_type_t * x;
88 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
89 x -> size = size;
90 return x;
91 }
92
93 static oberon_type_t *
94 oberon_new_type_boolean(int size)
95 {
96 oberon_type_t * x;
97 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
98 x -> size = size;
99 return x;
100 }
101
102 // =======================================================================
103 // TABLE
104 // =======================================================================
105
106 static oberon_scope_t *
107 oberon_open_scope(oberon_context_t * ctx)
108 {
109 oberon_scope_t * scope = malloc(sizeof *scope);
110 memset(scope, 0, sizeof *scope);
111
112 oberon_object_t * list = malloc(sizeof *list);
113 memset(list, 0, sizeof *list);
114
115 scope -> ctx = ctx;
116 scope -> list = list;
117 scope -> up = ctx -> decl;
118
119 ctx -> decl = scope;
120 return scope;
121 }
122
123 static void
124 oberon_close_scope(oberon_scope_t * scope)
125 {
126 oberon_context_t * ctx = scope -> ctx;
127 ctx -> decl = scope -> up;
128 }
129
130 static oberon_object_t *
131 oberon_define_object(oberon_scope_t * scope, char * name, int class)
132 {
133 oberon_object_t * x = scope -> list;
134 while(x -> next && strcmp(x -> next -> name, name) != 0)
135 {
136 x = x -> next;
137 }
138
139 if(x -> next)
140 {
141 oberon_error(scope -> ctx, "already defined");
142 }
143
144 oberon_object_t * newvar = malloc(sizeof *newvar);
145 memset(newvar, 0, sizeof *newvar);
146 newvar -> name = name;
147 newvar -> class = class;
148
149 x -> next = newvar;
150
151 return newvar;
152 }
153
154 static void
155 oberon_define_field(oberon_context_t * ctx, oberon_type_t * rec, char * name, oberon_type_t * type)
156 {
157 oberon_object_t * x = rec -> decl;
158 while(x -> next && strcmp(x -> next -> name, name) != 0)
159 {
160 x = x -> next;
161 }
162
163 if(x -> next)
164 {
165 oberon_error(ctx, "multiple definition");
166 }
167
168 oberon_object_t * field = malloc(sizeof *field);
169 memset(field, 0, sizeof *field);
170 field -> name = name;
171 field -> class = OBERON_CLASS_FIELD;
172 field -> type = type;
173
174 rec -> num_decl += 1;
175 oberon_generator_init_var(ctx, field);
176
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)
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(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 static oberon_type_t *
240 oberon_find_type(oberon_scope_t * scope, char * name)
241 {
242 oberon_object_t * x = oberon_find_object(scope, name);
243 if(x -> class != OBERON_CLASS_TYPE)
244 {
245 oberon_error(scope -> ctx, "%s not a type", name);
246 }
247
248 return x -> type;
249 }
250
251 static oberon_object_t *
252 oberon_define_var(oberon_scope_t * scope, int class, char * name, oberon_type_t * type)
253 {
254 oberon_object_t * var;
255 var = oberon_define_object(scope, name, class);
256 var -> type = type;
257 oberon_generator_init_var(scope -> ctx, var);
258 return var;
259 }
260
261 /*
262 static oberon_object_t *
263 oberon_find_var(oberon_scope_t * scope, char * name)
264 {
265 oberon_object_t * x = oberon_find_object(scope, name);
266
267 if(x -> class != OBERON_CLASS_VAR)
268 {
269 oberon_error(scope -> ctx, "%s not a var", name);
270 }
271
272 return x;
273 }
274 */
275
276 static oberon_object_t *
277 oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signature)
278 {
279 oberon_object_t * proc;
280 proc = oberon_define_object(scope, name, OBERON_CLASS_PROC);
281 proc -> type = signature;
282 oberon_generator_init_proc(scope -> ctx, proc);
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 }
401
402 static void
403 oberon_read_integer(oberon_context_t * ctx)
404 {
405 int len = 0;
406 int i = ctx -> code_index;
407
408 int c = ctx -> code[i];
409 while(isdigit(c))
410 {
411 i += 1;
412 len += 1;
413 c = ctx -> code[i];
414 }
415
416 char * ident = malloc(len + 2);
417 memcpy(ident, &ctx->code[ctx->code_index], len);
418 ident[len + 1] = 0;
419
420 ctx -> code_index = i;
421 ctx -> c = ctx -> code[i];
422 ctx -> string = ident;
423 ctx -> integer = atoi(ident);
424 ctx -> token = INTEGER;
425 }
426
427 static void
428 oberon_skip_space(oberon_context_t * ctx)
429 {
430 while(isspace(ctx -> c))
431 {
432 oberon_get_char(ctx);
433 }
434 }
435
436 static void
437 oberon_read_symbol(oberon_context_t * ctx)
438 {
439 int c = ctx -> c;
440 switch(c)
441 {
442 case 0:
443 ctx -> token = EOF_;
444 break;
445 case ';':
446 ctx -> token = SEMICOLON;
447 oberon_get_char(ctx);
448 break;
449 case ':':
450 ctx -> token = COLON;
451 oberon_get_char(ctx);
452 if(ctx -> c == '=')
453 {
454 ctx -> token = ASSIGN;
455 oberon_get_char(ctx);
456 }
457 break;
458 case '.':
459 ctx -> token = DOT;
460 oberon_get_char(ctx);
461 break;
462 case '(':
463 ctx -> token = LPAREN;
464 oberon_get_char(ctx);
465 break;
466 case ')':
467 ctx -> token = RPAREN;
468 oberon_get_char(ctx);
469 break;
470 case '=':
471 ctx -> token = EQUAL;
472 oberon_get_char(ctx);
473 break;
474 case '#':
475 ctx -> token = NEQ;
476 oberon_get_char(ctx);
477 break;
478 case '<':
479 ctx -> token = LESS;
480 oberon_get_char(ctx);
481 if(ctx -> c == '=')
482 {
483 ctx -> token = LEQ;
484 oberon_get_char(ctx);
485 }
486 break;
487 case '>':
488 ctx -> token = GREAT;
489 oberon_get_char(ctx);
490 if(ctx -> c == '=')
491 {
492 ctx -> token = GEQ;
493 oberon_get_char(ctx);
494 }
495 break;
496 case '+':
497 ctx -> token = PLUS;
498 oberon_get_char(ctx);
499 break;
500 case '-':
501 ctx -> token = MINUS;
502 oberon_get_char(ctx);
503 break;
504 case '*':
505 ctx -> token = STAR;
506 oberon_get_char(ctx);
507 break;
508 case '/':
509 ctx -> token = SLASH;
510 oberon_get_char(ctx);
511 break;
512 case '&':
513 ctx -> token = AND;
514 oberon_get_char(ctx);
515 break;
516 case '~':
517 ctx -> token = NOT;
518 oberon_get_char(ctx);
519 break;
520 case ',':
521 ctx -> token = COMMA;
522 oberon_get_char(ctx);
523 break;
524 case '[':
525 ctx -> token = LBRACE;
526 oberon_get_char(ctx);
527 break;
528 case ']':
529 ctx -> token = RBRACE;
530 oberon_get_char(ctx);
531 break;
532 default:
533 oberon_error(ctx, "invalid char");
534 break;
535 }
536 }
537
538 static void
539 oberon_read_token(oberon_context_t * ctx)
540 {
541 oberon_skip_space(ctx);
542
543 int c = ctx -> c;
544 if(isalpha(c))
545 {
546 oberon_read_ident(ctx);
547 }
548 else if(isdigit(c))
549 {
550 oberon_read_integer(ctx);
551 }
552 else
553 {
554 oberon_read_symbol(ctx);
555 }
556 }
557
558 // =======================================================================
559 // EXPRESSION
560 // =======================================================================
561
562 static void oberon_expect_token(oberon_context_t * ctx, int token);
563 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
564 static void oberon_assert_token(oberon_context_t * ctx, int token);
565 static char * oberon_assert_ident(oberon_context_t * ctx);
566 static oberon_type_t * oberon_type(oberon_context_t * ctx);
567
568 static oberon_expr_t *
569 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
570 {
571 oberon_oper_t * operator;
572 operator = malloc(sizeof *operator);
573 memset(operator, 0, sizeof *operator);
574
575 operator -> is_item = 0;
576 operator -> result = result;
577 operator -> op = op;
578 operator -> left = left;
579 operator -> right = right;
580
581 return (oberon_expr_t *) operator;
582 }
583
584 static oberon_expr_t *
585 oberon_new_item(int mode, oberon_type_t * result)
586 {
587 oberon_item_t * item;
588 item = malloc(sizeof *item);
589 memset(item, 0, sizeof *item);
590
591 item -> is_item = 1;
592 item -> result = result;
593 item -> mode = mode;
594
595 return (oberon_expr_t *)item;
596 }
597
598 static oberon_expr_t *
599 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
600 {
601 oberon_expr_t * expr;
602 oberon_type_t * result;
603
604 result = a -> result;
605
606 if(token == MINUS)
607 {
608 if(result -> class != OBERON_TYPE_INTEGER)
609 {
610 oberon_error(ctx, "incompatible operator type");
611 }
612
613 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
614 }
615 else if(token == NOT)
616 {
617 if(result -> class != OBERON_TYPE_BOOLEAN)
618 {
619 oberon_error(ctx, "incompatible operator type");
620 }
621
622 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
623 }
624 else
625 {
626 oberon_error(ctx, "oberon_make_unary_op: wat");
627 }
628
629 return expr;
630 }
631
632 static void
633 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first)
634 {
635 oberon_expr_t * last;
636
637 *num_expr = 1;
638 *first = last = oberon_expr(ctx);
639 while(ctx -> token == COMMA)
640 {
641 oberon_assert_token(ctx, COMMA);
642 oberon_expr_t * current;
643 current = oberon_expr(ctx);
644 last -> next = current;
645 last = current;
646 *num_expr += 1;
647 }
648 }
649
650 static oberon_expr_t *
651 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
652 {
653 if(pref -> class != expr -> result -> class)
654 {
655 oberon_error(ctx, "incompatible types");
656 }
657
658
659 if(pref -> class == OBERON_TYPE_INTEGER)
660 {
661 if(expr -> result -> class > pref -> class)
662 {
663 oberon_error(ctx, "incompatible size");
664 }
665 }
666 else if(pref -> class == OBERON_TYPE_RECORD)
667 {
668 if(expr -> result != pref)
669 {
670 printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
671 oberon_error(ctx, "incompatible record types");
672 }
673 }
674
675 // TODO cast
676
677 return expr;
678 }
679
680 static void
681 oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
682 {
683 if(desig -> is_item == 0)
684 {
685 oberon_error(ctx, "expected item");
686 }
687
688 if(desig -> item.mode != MODE_CALL)
689 {
690 oberon_error(ctx, "expected mode CALL");
691 }
692
693 if(desig -> item.var -> class != OBERON_CLASS_PROC)
694 {
695 oberon_error(ctx, "only procedures can be called");
696 }
697
698 oberon_type_t * fn = desig -> item.var -> type;
699 int num_args = desig -> item.num_args;
700 int num_decl = fn -> num_decl;
701
702 if(num_args < num_decl)
703 {
704 oberon_error(ctx, "too few arguments");
705 }
706 else if(num_args > num_decl)
707 {
708 oberon_error(ctx, "too many arguments");
709 }
710
711 oberon_expr_t * arg = desig -> item.args;
712 oberon_object_t * param = fn -> decl;
713 for(int i = 0; i < num_args; i++)
714 {
715 oberon_autocast_to(ctx, arg, param -> type);
716 arg = arg -> next;
717 param = param -> next;
718 }
719 }
720
721 #define ISEXPR(x) \
722 (((x) == PLUS) \
723 || ((x) == MINUS) \
724 || ((x) == IDENT) \
725 || ((x) == INTEGER) \
726 || ((x) == LPAREN) \
727 || ((x) == NOT) \
728 || ((x) == TRUE) \
729 || ((x) == FALSE))
730
731 #define ISSELECTOR(x) \
732 (((x) == LBRACE) \
733 || ((x) == DOT))
734
735 static oberon_expr_t *
736 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, int num_indexes, oberon_expr_t * indexes)
737 {
738 assert(desig -> is_item == 1);
739
740 if(desig -> item.mode != MODE_VAR)
741 {
742 oberon_error(ctx, "not MODE_VAR");
743 }
744
745 int class = desig -> item.var -> class;
746 switch(class)
747 {
748 case OBERON_CLASS_VAR:
749 case OBERON_CLASS_VAR_PARAM:
750 case OBERON_CLASS_PARAM:
751 break;
752 default:
753 oberon_error(ctx, "not variable");
754 break;
755 }
756
757 oberon_type_t * type = desig -> item.var -> type;
758 if(type -> class != OBERON_TYPE_ARRAY)
759 {
760 oberon_error(ctx, "not array");
761 }
762
763 int dim = desig -> item.var -> type -> dim;
764 if(num_indexes != dim)
765 {
766 oberon_error(ctx, "dimesions not matched");
767 }
768
769 oberon_type_t * base = desig -> item.var -> type -> base;
770
771 oberon_expr_t * selector;
772 selector = oberon_new_item(MODE_INDEX, base);
773 selector -> item.parent = (oberon_item_t *) desig;
774 selector -> item.num_args = num_indexes;
775 selector -> item.args = indexes;
776
777 return selector;
778 }
779
780 static oberon_expr_t *
781 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
782 {
783 assert(expr -> is_item == 1);
784
785 int class = expr -> result -> class;
786 if(class != OBERON_TYPE_RECORD)
787 {
788 oberon_error(ctx, "not record");
789 }
790
791 oberon_type_t * rec = expr -> result;
792
793 oberon_object_t * field;
794 field = oberon_find_field(ctx, rec, name);
795
796 oberon_expr_t * selector;
797 selector = oberon_new_item(MODE_FIELD, field -> type);
798 selector -> item.var = field;
799 selector -> item.parent = (oberon_item_t *) expr;
800
801 return selector;
802 }
803
804 static oberon_expr_t *
805 oberon_designator(oberon_context_t * ctx)
806 {
807 char * name;
808 oberon_object_t * var;
809 oberon_expr_t * expr;
810
811 name = oberon_assert_ident(ctx);
812 var = oberon_find_object(ctx -> decl, name);
813
814 switch(var -> class)
815 {
816 case OBERON_CLASS_CONST:
817 // TODO copy value
818 expr = (oberon_expr_t *) var -> value;
819 break;
820 case OBERON_CLASS_VAR:
821 case OBERON_CLASS_VAR_PARAM:
822 case OBERON_CLASS_PARAM:
823 expr = oberon_new_item(MODE_VAR, var -> type);
824 break;
825 case OBERON_CLASS_PROC:
826 expr = oberon_new_item(MODE_CALL, var -> type);
827 break;
828 default:
829 oberon_error(ctx, "invalid designator");
830 break;
831 }
832 expr -> item.var = var;
833
834 while(ISSELECTOR(ctx -> token))
835 {
836 switch(ctx -> token)
837 {
838 case DOT:
839 oberon_assert_token(ctx, DOT);
840 name = oberon_assert_ident(ctx);
841 expr = oberon_make_record_selector(ctx, expr, name);
842 break;
843 case LBRACE:
844 oberon_assert_token(ctx, LBRACE);
845 int num_indexes = 0;
846 oberon_expr_t * indexes = NULL;
847 oberon_expr_list(ctx, &num_indexes, &indexes);
848 oberon_assert_token(ctx, RBRACE);
849 expr = oberon_make_array_selector(ctx, expr, num_indexes, indexes);
850 break;
851 default:
852 oberon_error(ctx, "oberon_designator: wat");
853 break;
854 }
855 }
856 return expr;
857 }
858
859 static oberon_expr_t *
860 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
861 {
862 assert(expr -> is_item == 1);
863
864 if(ctx -> token == LPAREN)
865 {
866 if(expr -> result -> class != OBERON_TYPE_PROCEDURE)
867 {
868 oberon_error(ctx, "not a procedure");
869 }
870
871 oberon_assert_token(ctx, LPAREN);
872
873 int num_args = 0;
874 oberon_expr_t * arguments = NULL;
875
876 if(ISEXPR(ctx -> token))
877 {
878 oberon_expr_list(ctx, &num_args, &arguments);
879 }
880
881 expr -> result = expr -> item.var -> type -> base;
882 expr -> item.mode = MODE_CALL;
883 expr -> item.num_args = num_args;
884 expr -> item.args = arguments;
885 oberon_assert_token(ctx, RPAREN);
886
887 oberon_autocast_call(ctx, expr);
888 }
889
890 return expr;
891 }
892
893 static oberon_expr_t *
894 oberon_factor(oberon_context_t * ctx)
895 {
896 oberon_expr_t * expr;
897
898 switch(ctx -> token)
899 {
900 case IDENT:
901 expr = oberon_designator(ctx);
902 expr = oberon_opt_proc_parens(ctx, expr);
903 break;
904 case INTEGER:
905 expr = oberon_new_item(MODE_INTEGER, ctx -> int_type);
906 expr -> item.integer = ctx -> integer;
907 oberon_assert_token(ctx, INTEGER);
908 break;
909 case TRUE:
910 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
911 expr -> item.boolean = 1;
912 oberon_assert_token(ctx, TRUE);
913 break;
914 case FALSE:
915 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type);
916 expr -> item.boolean = 0;
917 oberon_assert_token(ctx, FALSE);
918 break;
919 case LPAREN:
920 oberon_assert_token(ctx, LPAREN);
921 expr = oberon_expr(ctx);
922 oberon_assert_token(ctx, RPAREN);
923 break;
924 case NOT:
925 oberon_assert_token(ctx, NOT);
926 expr = oberon_factor(ctx);
927 expr = oberon_make_unary_op(ctx, NOT, expr);
928 break;
929 default:
930 oberon_error(ctx, "invalid expression");
931 }
932
933 return expr;
934 }
935
936 /*
937 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
938 * 1. Классы обоих типов должны быть одинаковы
939 * 2. В качестве результата должен быть выбран больший тип.
940 * 3. Если размер результат не должен быть меньше чем базовый int
941 */
942
943 static void
944 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
945 {
946 if((a -> class) != (b -> class))
947 {
948 oberon_error(ctx, "incompatible types");
949 }
950
951 if((a -> size) > (b -> size))
952 {
953 *result = a;
954 }
955 else
956 {
957 *result = b;
958 }
959
960 if(((*result) -> class) == OBERON_TYPE_INTEGER)
961 {
962 if(((*result) -> size) < (ctx -> int_type -> size))
963 {
964 *result = ctx -> int_type;
965 }
966 }
967
968 /* TODO: cast types */
969 }
970
971 #define ITMAKESBOOLEAN(x) \
972 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
973
974 #define ITUSEONLYINTEGER(x) \
975 ((x) >= LESS && (x) <= GEQ)
976
977 #define ITUSEONLYBOOLEAN(x) \
978 (((x) == OR) || ((x) == AND))
979
980 static oberon_expr_t *
981 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
982 {
983 oberon_expr_t * expr;
984 oberon_type_t * result;
985
986 if(ITMAKESBOOLEAN(token))
987 {
988 if(ITUSEONLYINTEGER(token))
989 {
990 if(a -> result -> class != OBERON_TYPE_INTEGER
991 || b -> result -> class != OBERON_TYPE_INTEGER)
992 {
993 oberon_error(ctx, "used only with integer types");
994 }
995 }
996 else if(ITUSEONLYBOOLEAN(token))
997 {
998 if(a -> result -> class != OBERON_TYPE_BOOLEAN
999 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1000 {
1001 oberon_error(ctx, "used only with boolean type");
1002 }
1003 }
1004
1005 result = ctx -> bool_type;
1006
1007 if(token == EQUAL)
1008 {
1009 expr = oberon_new_operator(OP_EQ, result, a, b);
1010 }
1011 else if(token == NEQ)
1012 {
1013 expr = oberon_new_operator(OP_NEQ, result, a, b);
1014 }
1015 else if(token == LESS)
1016 {
1017 expr = oberon_new_operator(OP_LSS, result, a, b);
1018 }
1019 else if(token == LEQ)
1020 {
1021 expr = oberon_new_operator(OP_LEQ, result, a, b);
1022 }
1023 else if(token == GREAT)
1024 {
1025 expr = oberon_new_operator(OP_GRT, result, a, b);
1026 }
1027 else if(token == GEQ)
1028 {
1029 expr = oberon_new_operator(OP_GEQ, result, a, b);
1030 }
1031 else if(token == OR)
1032 {
1033 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1034 }
1035 else if(token == AND)
1036 {
1037 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1038 }
1039 else
1040 {
1041 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1042 }
1043 }
1044 else
1045 {
1046 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1047
1048 if(token == PLUS)
1049 {
1050 expr = oberon_new_operator(OP_ADD, result, a, b);
1051 }
1052 else if(token == MINUS)
1053 {
1054 expr = oberon_new_operator(OP_SUB, result, a, b);
1055 }
1056 else if(token == STAR)
1057 {
1058 expr = oberon_new_operator(OP_MUL, result, a, b);
1059 }
1060 else if(token == SLASH)
1061 {
1062 expr = oberon_new_operator(OP_DIV, result, a, b);
1063 }
1064 else if(token == DIV)
1065 {
1066 expr = oberon_new_operator(OP_DIV, result, a, b);
1067 }
1068 else if(token == MOD)
1069 {
1070 expr = oberon_new_operator(OP_MOD, result, a, b);
1071 }
1072 else
1073 {
1074 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1075 }
1076 }
1077
1078 return expr;
1079 }
1080
1081 #define ISMULOP(x) \
1082 ((x) >= STAR && (x) <= AND)
1083
1084 static oberon_expr_t *
1085 oberon_term_expr(oberon_context_t * ctx)
1086 {
1087 oberon_expr_t * expr;
1088
1089 expr = oberon_factor(ctx);
1090 while(ISMULOP(ctx -> token))
1091 {
1092 int token = ctx -> token;
1093 oberon_read_token(ctx);
1094
1095 oberon_expr_t * inter = oberon_factor(ctx);
1096 expr = oberon_make_bin_op(ctx, token, expr, inter);
1097 }
1098
1099 return expr;
1100 }
1101
1102 #define ISADDOP(x) \
1103 ((x) >= PLUS && (x) <= OR)
1104
1105 static oberon_expr_t *
1106 oberon_simple_expr(oberon_context_t * ctx)
1107 {
1108 oberon_expr_t * expr;
1109
1110 int minus = 0;
1111 if(ctx -> token == PLUS)
1112 {
1113 minus = 0;
1114 oberon_assert_token(ctx, PLUS);
1115 }
1116 else if(ctx -> token == MINUS)
1117 {
1118 minus = 1;
1119 oberon_assert_token(ctx, MINUS);
1120 }
1121
1122 expr = oberon_term_expr(ctx);
1123 while(ISADDOP(ctx -> token))
1124 {
1125 int token = ctx -> token;
1126 oberon_read_token(ctx);
1127
1128 oberon_expr_t * inter = oberon_term_expr(ctx);
1129 expr = oberon_make_bin_op(ctx, token, expr, inter);
1130 }
1131
1132 if(minus)
1133 {
1134 expr = oberon_make_unary_op(ctx, MINUS, expr);
1135 }
1136
1137 return expr;
1138 }
1139
1140 #define ISRELATION(x) \
1141 ((x) >= EQUAL && (x) <= GEQ)
1142
1143 static oberon_expr_t *
1144 oberon_expr(oberon_context_t * ctx)
1145 {
1146 oberon_expr_t * expr;
1147
1148 expr = oberon_simple_expr(ctx);
1149 while(ISRELATION(ctx -> token))
1150 {
1151 int token = ctx -> token;
1152 oberon_read_token(ctx);
1153
1154 oberon_expr_t * inter = oberon_simple_expr(ctx);
1155 expr = oberon_make_bin_op(ctx, token, expr, inter);
1156 }
1157
1158 return expr;
1159 }
1160
1161 static oberon_item_t *
1162 oberon_const_expr(oberon_context_t * ctx)
1163 {
1164 oberon_expr_t * expr;
1165 expr = oberon_expr(ctx);
1166
1167 if(expr -> is_item == 0)
1168 {
1169 oberon_error(ctx, "const expression are required");
1170 }
1171
1172 return (oberon_item_t *) expr;
1173 }
1174
1175 // =======================================================================
1176 // PARSER
1177 // =======================================================================
1178
1179 static void oberon_statement_seq(oberon_context_t * ctx);
1180
1181 static void
1182 oberon_expect_token(oberon_context_t * ctx, int token)
1183 {
1184 if(ctx -> token != token)
1185 {
1186 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1187 }
1188 }
1189
1190 static void
1191 oberon_assert_token(oberon_context_t * ctx, int token)
1192 {
1193 oberon_expect_token(ctx, token);
1194 oberon_read_token(ctx);
1195 }
1196
1197 static char *
1198 oberon_assert_ident(oberon_context_t * ctx)
1199 {
1200 oberon_expect_token(ctx, IDENT);
1201 char * ident = ctx -> string;
1202 oberon_read_token(ctx);
1203 return ident;
1204 }
1205
1206 static oberon_type_t *
1207 oberon_make_array_type(oberon_context_t * ctx, int dim, oberon_item_t * size, oberon_type_t * base)
1208 {
1209 assert(dim == 1);
1210 oberon_type_t * newtype;
1211
1212 if(size -> mode != MODE_INTEGER)
1213 {
1214 oberon_error(ctx, "requires integer constant");
1215 }
1216
1217 newtype = oberon_new_type_ptr(OBERON_TYPE_ARRAY);
1218 newtype -> dim = dim;
1219 newtype -> size = size -> integer;
1220 newtype -> base = base;
1221 oberon_generator_init_type(ctx, newtype);
1222
1223 return newtype;
1224 }
1225
1226 static void
1227 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1228 {
1229 if(ctx -> token == IDENT)
1230 {
1231 char * name;
1232 oberon_type_t * type;
1233 name = oberon_assert_ident(ctx);
1234 oberon_assert_token(ctx, COLON);
1235 type = oberon_type(ctx);
1236 oberon_define_field(ctx, rec, name, type);
1237 }
1238 }
1239
1240 static oberon_type_t *
1241 oberon_make_pointer(oberon_context_t * ctx, oberon_type_t * type)
1242 {
1243 if(type -> class == OBERON_TYPE_POINTER)
1244 {
1245 return type;
1246 }
1247
1248 if(type -> class == OBERON_TYPE_INTEGER
1249 || type -> class == OBERON_TYPE_BOOLEAN
1250 || type -> class == OBERON_TYPE_PROCEDURE
1251 || type -> class == OBERON_TYPE_VOID)
1252 {
1253 oberon_error(ctx, "oberon not support pointers to non structure types");
1254 }
1255
1256 oberon_type_t * newtype;
1257 newtype = oberon_new_type_ptr(OBERON_TYPE_POINTER);
1258 newtype -> base = type;
1259
1260 oberon_generator_init_type(ctx, newtype);
1261
1262 return newtype;
1263 }
1264
1265 static oberon_type_t * oberon_opt_formal_pars(oberon_context_t * ctx, int class);
1266
1267 static oberon_type_t *
1268 oberon_type(oberon_context_t * ctx)
1269 {
1270 oberon_type_t * type;
1271
1272 if(ctx -> token == IDENT)
1273 {
1274 char * name = oberon_assert_ident(ctx);
1275 type = oberon_find_type(ctx -> decl, name);
1276 }
1277 else if(ctx -> token == ARRAY)
1278 {
1279 oberon_assert_token(ctx, ARRAY);
1280 oberon_item_t * size = oberon_const_expr(ctx);
1281 oberon_assert_token(ctx, OF);
1282 oberon_type_t * base = oberon_type(ctx);
1283 type = oberon_make_array_type(ctx, 1, size, base);
1284 }
1285 else if(ctx -> token == RECORD)
1286 {
1287 type = oberon_new_type_ptr(OBERON_TYPE_RECORD);
1288 oberon_object_t * list = malloc(sizeof *list);
1289 memset(list, 0, sizeof *list);
1290 type -> num_decl = 0;
1291 type -> base = NULL;
1292 type -> decl = list;
1293
1294 oberon_assert_token(ctx, RECORD);
1295 oberon_field_list(ctx, type);
1296 while(ctx -> token == SEMICOLON)
1297 {
1298 oberon_assert_token(ctx, SEMICOLON);
1299 oberon_field_list(ctx, type);
1300 }
1301 oberon_assert_token(ctx, END);
1302
1303 type -> decl = type -> decl -> next;
1304 oberon_generator_init_type(ctx, type);
1305 }
1306 else if(ctx -> token == POINTER)
1307 {
1308 oberon_assert_token(ctx, POINTER);
1309 oberon_assert_token(ctx, TO);
1310 type = oberon_type(ctx);
1311 type = oberon_make_pointer(ctx, type);
1312 }
1313 else if(ctx -> token == PROCEDURE)
1314 {
1315 oberon_assert_token(ctx, PROCEDURE);
1316 type = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE);
1317 }
1318 else
1319 {
1320 oberon_error(ctx, "invalid type declaration");
1321 }
1322
1323 return type;
1324 }
1325
1326 static void
1327 oberon_var_decl(oberon_context_t * ctx)
1328 {
1329 char * name = oberon_assert_ident(ctx);
1330 oberon_assert_token(ctx, COLON);
1331 oberon_type_t * type = oberon_type(ctx);
1332 oberon_define_var(ctx -> decl, OBERON_CLASS_VAR, name, type);
1333 }
1334
1335 static oberon_object_t *
1336 oberon_make_param(oberon_context_t * ctx, int token, char * name, oberon_type_t * type)
1337 {
1338 oberon_object_t * param;
1339
1340 if(token == VAR)
1341 {
1342 param = oberon_define_var(ctx -> decl, OBERON_CLASS_VAR_PARAM, name, type);
1343 }
1344 else if(token == IDENT)
1345 {
1346 param = oberon_define_var(ctx -> decl, OBERON_CLASS_PARAM, name, type);
1347 }
1348 else
1349 {
1350 oberon_error(ctx, "oberon_make_param: wat");
1351 }
1352
1353 return param;
1354 }
1355
1356 static oberon_object_t *
1357 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1358 {
1359 int modifer_token = ctx -> token;
1360 if(ctx -> token == VAR)
1361 {
1362 oberon_read_token(ctx);
1363 }
1364
1365 char * name;
1366 name = oberon_assert_ident(ctx);
1367
1368 oberon_assert_token(ctx, COLON);
1369
1370 oberon_type_t * type;
1371 type = oberon_type(ctx);
1372
1373 oberon_object_t * first;
1374 first = oberon_make_param(ctx, modifer_token, name, type);
1375
1376 *num_decl += 1;
1377 return first;
1378 }
1379
1380 #define ISFPSECTION \
1381 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1382
1383 static oberon_type_t *
1384 oberon_formal_pars(oberon_context_t * ctx)
1385 {
1386 oberon_type_t * tp;
1387 tp = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
1388 tp -> num_decl = 0;
1389 tp -> base = ctx -> void_type;
1390 tp -> decl = NULL;
1391
1392 oberon_assert_token(ctx, LPAREN);
1393
1394 if(ISFPSECTION)
1395 {
1396 tp -> decl = oberon_fp_section(ctx, &tp -> num_decl);
1397 while(ctx -> token == SEMICOLON)
1398 {
1399 oberon_assert_token(ctx, SEMICOLON);
1400 oberon_fp_section(ctx, &tp -> num_decl);
1401 }
1402 }
1403
1404 oberon_assert_token(ctx, RPAREN);
1405
1406 if(ctx -> token == COLON)
1407 {
1408 oberon_assert_token(ctx, COLON);
1409 tp -> base = oberon_type(ctx);
1410 }
1411
1412 oberon_generator_init_type(ctx, tp);
1413 return tp;
1414 }
1415
1416 static oberon_type_t *
1417 oberon_opt_formal_pars(oberon_context_t * ctx, int class)
1418 {
1419 oberon_type_t * signature;
1420
1421 if(ctx -> token == LPAREN)
1422 {
1423 signature = oberon_formal_pars(ctx);
1424 }
1425 else
1426 {
1427 signature = oberon_new_type_ptr(class);
1428 signature -> num_decl = 0;
1429 signature -> base = ctx -> void_type;
1430 signature -> decl = NULL;
1431 oberon_generator_init_type(ctx, signature);
1432 }
1433
1434 return signature;
1435 }
1436
1437 static void
1438 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1439 {
1440 if(ctx -> result_type -> class == OBERON_TYPE_VOID)
1441 {
1442 if(expr != NULL)
1443 {
1444 oberon_error(ctx, "procedure has no result type");
1445 }
1446 }
1447 else
1448 {
1449 if(expr == NULL)
1450 {
1451 oberon_error(ctx, "procedure requires expression on result");
1452 }
1453
1454 oberon_autocast_to(ctx, expr, ctx -> result_type);
1455 }
1456
1457 ctx -> has_return = 1;
1458
1459 oberon_generate_return(ctx, expr);
1460 }
1461
1462 static void
1463 oberon_proc_decl(oberon_context_t * ctx)
1464 {
1465 oberon_assert_token(ctx, PROCEDURE);
1466
1467 char * name;
1468 name = oberon_assert_ident(ctx);
1469
1470 oberon_scope_t * this_proc_def_scope = ctx -> decl;
1471 oberon_open_scope(ctx);
1472
1473 oberon_type_t * signature;
1474 signature = oberon_opt_formal_pars(ctx, OBERON_TYPE_PROCEDURE);
1475
1476 oberon_object_t * proc;
1477 proc = oberon_define_proc(this_proc_def_scope, name, signature);
1478
1479 ctx -> result_type = signature -> base;
1480 ctx -> has_return = 0;
1481
1482 oberon_assert_token(ctx, SEMICOLON);
1483
1484 oberon_generate_begin_proc(ctx, proc);
1485
1486 // TODO declarations
1487
1488 if(ctx -> token == BEGIN)
1489 {
1490 oberon_assert_token(ctx, BEGIN);
1491 oberon_statement_seq(ctx);
1492 }
1493
1494 oberon_assert_token(ctx, END);
1495 char * name2 = oberon_assert_ident(ctx);
1496 if(strcmp(name2, name) != 0)
1497 {
1498 oberon_error(ctx, "procedure name not matched");
1499 }
1500
1501 if(signature -> base -> class == OBERON_TYPE_VOID)
1502 {
1503 oberon_make_return(ctx, NULL);
1504 }
1505
1506 if(ctx -> has_return == 0)
1507 {
1508 oberon_error(ctx, "procedure requires return");
1509 }
1510 ctx -> result_type = NULL;
1511
1512 oberon_generate_end_proc(ctx);
1513 oberon_close_scope(ctx -> decl);
1514 }
1515
1516 static void
1517 oberon_const_decl(oberon_context_t * ctx)
1518 {
1519 char * name;
1520 oberon_item_t * value;
1521 oberon_object_t * constant;
1522
1523 name = oberon_assert_ident(ctx);
1524 oberon_assert_token(ctx, EQUAL);
1525 value = oberon_const_expr(ctx);
1526
1527 constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST);
1528 constant -> value = value;
1529 }
1530
1531 static void
1532 oberon_type_decl(oberon_context_t * ctx)
1533 {
1534 char * name;
1535 oberon_object_t * newtype;
1536 oberon_type_t * type;
1537
1538 name = oberon_assert_ident(ctx);
1539 oberon_assert_token(ctx, EQUAL);
1540 type = oberon_type(ctx);
1541
1542 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE);
1543 newtype -> type = type;
1544 }
1545
1546 static void
1547 oberon_decl_seq(oberon_context_t * ctx)
1548 {
1549 if(ctx -> token == CONST)
1550 {
1551 oberon_assert_token(ctx, CONST);
1552 while(ctx -> token == IDENT)
1553 {
1554 oberon_const_decl(ctx);
1555 oberon_assert_token(ctx, SEMICOLON);
1556 }
1557 }
1558
1559 if(ctx -> token == TYPE)
1560 {
1561 oberon_assert_token(ctx, TYPE);
1562 while(ctx -> token == IDENT)
1563 {
1564 oberon_type_decl(ctx);
1565 oberon_assert_token(ctx, SEMICOLON);
1566 }
1567 }
1568
1569 if(ctx -> token == VAR)
1570 {
1571 oberon_assert_token(ctx, VAR);
1572 while(ctx -> token == IDENT)
1573 {
1574 oberon_var_decl(ctx);
1575 oberon_assert_token(ctx, SEMICOLON);
1576 }
1577 }
1578
1579 while(ctx -> token == PROCEDURE)
1580 {
1581 oberon_proc_decl(ctx);
1582 oberon_assert_token(ctx, SEMICOLON);
1583 }
1584 }
1585
1586 static void
1587 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
1588 {
1589 oberon_autocast_to(ctx, src, dst -> result);
1590 oberon_generate_assign(ctx, src, dst);
1591 }
1592
1593 static void
1594 oberon_make_call(oberon_context_t * ctx, oberon_expr_t * desig)
1595 {
1596 oberon_autocast_call(ctx, desig);
1597 oberon_generate_call_proc(ctx, desig);
1598 }
1599
1600 static void
1601 oberon_statement(oberon_context_t * ctx)
1602 {
1603 oberon_expr_t * item1;
1604 oberon_expr_t * item2;
1605
1606 if(ctx -> token == IDENT)
1607 {
1608 item1 = oberon_designator(ctx);
1609 if(ctx -> token == ASSIGN)
1610 {
1611 oberon_assert_token(ctx, ASSIGN);
1612 item2 = oberon_expr(ctx);
1613 oberon_assign(ctx, item2, item1);
1614 }
1615 else
1616 {
1617 item1 = oberon_opt_proc_parens(ctx, item1);
1618 oberon_make_call(ctx, item1);
1619 }
1620 }
1621 else if(ctx -> token == RETURN)
1622 {
1623 oberon_assert_token(ctx, RETURN);
1624 if(ISEXPR(ctx -> token))
1625 {
1626 oberon_expr_t * expr;
1627 expr = oberon_expr(ctx);
1628 oberon_make_return(ctx, expr);
1629 }
1630 else
1631 {
1632 oberon_make_return(ctx, NULL);
1633 }
1634 }
1635 }
1636
1637 static void
1638 oberon_statement_seq(oberon_context_t * ctx)
1639 {
1640 oberon_statement(ctx);
1641 while(ctx -> token == SEMICOLON)
1642 {
1643 oberon_assert_token(ctx, SEMICOLON);
1644 oberon_statement(ctx);
1645 }
1646 }
1647
1648 static void
1649 oberon_parse_module(oberon_context_t * ctx)
1650 {
1651 char *name1, *name2;
1652 oberon_read_token(ctx);
1653
1654 oberon_assert_token(ctx, MODULE);
1655 name1 = oberon_assert_ident(ctx);
1656 oberon_assert_token(ctx, SEMICOLON);
1657 ctx -> mod -> name = name1;
1658
1659 oberon_decl_seq(ctx);
1660
1661 if(ctx -> token == BEGIN)
1662 {
1663 oberon_assert_token(ctx, BEGIN);
1664 oberon_generate_begin_module(ctx);
1665 oberon_statement_seq(ctx);
1666 oberon_generate_end_module(ctx);
1667 }
1668
1669 oberon_assert_token(ctx, END);
1670 name2 = oberon_assert_ident(ctx);
1671 oberon_assert_token(ctx, DOT);
1672
1673 if(strcmp(name1, name2) != 0)
1674 {
1675 oberon_error(ctx, "module name not matched");
1676 }
1677 }
1678
1679 // =======================================================================
1680 // LIBRARY
1681 // =======================================================================
1682
1683 static void
1684 register_default_types(oberon_context_t * ctx)
1685 {
1686 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1687 oberon_generator_init_type(ctx, ctx -> void_type);
1688
1689 ctx -> int_type = oberon_new_type_integer(sizeof(int));
1690 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type);
1691
1692 ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
1693 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type);
1694 }
1695
1696 oberon_context_t *
1697 oberon_create_context()
1698 {
1699 oberon_context_t * ctx = malloc(sizeof *ctx);
1700 memset(ctx, 0, sizeof *ctx);
1701
1702 oberon_scope_t * world_scope;
1703 world_scope = oberon_open_scope(ctx);
1704 ctx -> world_scope = world_scope;
1705
1706 oberon_generator_init_context(ctx);
1707
1708 register_default_types(ctx);
1709
1710 return ctx;
1711 }
1712
1713 void
1714 oberon_destroy_context(oberon_context_t * ctx)
1715 {
1716 oberon_generator_destroy_context(ctx);
1717 free(ctx);
1718 }
1719
1720 oberon_module_t *
1721 oberon_compile_module(oberon_context_t * ctx, const char * code)
1722 {
1723 oberon_module_t * mod = malloc(sizeof *mod);
1724 memset(mod, 0, sizeof *mod);
1725 ctx -> mod = mod;
1726
1727 oberon_scope_t * module_scope;
1728 module_scope = oberon_open_scope(ctx);
1729 mod -> decl = module_scope;
1730
1731 oberon_init_scaner(ctx, code);
1732 oberon_parse_module(ctx);
1733
1734 oberon_generate_code(ctx);
1735
1736 ctx -> mod = NULL;
1737 return mod;
1738 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024