DEADSOFTWARE

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


e857b1d1ec6f93e454b5439cdcf81f96c150d167
[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 IMPORT
57 };
58
59 // =======================================================================
60 // UTILS
61 // =======================================================================
62
63 void
64 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
65 {
66 va_list ptr;
67 va_start(ptr, fmt);
68 fprintf(stderr, "error: ");
69 vfprintf(stderr, fmt, ptr);
70 fprintf(stderr, "\n");
71 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
72 fprintf(stderr, " c = %c\n", ctx -> c);
73 fprintf(stderr, " token = %i\n", ctx -> token);
74 va_end(ptr);
75 exit(1);
76 }
77
78 static oberon_type_t *
79 oberon_new_type_ptr(int class)
80 {
81 oberon_type_t * x = malloc(sizeof *x);
82 memset(x, 0, sizeof *x);
83 x -> class = class;
84 return x;
85 }
86
87 static oberon_type_t *
88 oberon_new_type_integer(int size)
89 {
90 oberon_type_t * x;
91 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
92 x -> size = size;
93 return x;
94 }
95
96 static oberon_type_t *
97 oberon_new_type_boolean(int size)
98 {
99 oberon_type_t * x;
100 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
101 x -> size = size;
102 return x;
103 }
104
105 // =======================================================================
106 // TABLE
107 // =======================================================================
108
109 static oberon_scope_t *
110 oberon_open_scope(oberon_context_t * ctx)
111 {
112 oberon_scope_t * scope = calloc(1, sizeof *scope);
113 oberon_object_t * list = calloc(1, sizeof *list);
114
115 scope -> ctx = ctx;
116 scope -> list = list;
117 scope -> up = ctx -> decl;
118
119 if(scope -> up)
120 {
121 scope -> parent = scope -> up -> parent;
122 scope -> local = scope -> up -> local;
123 }
124
125 ctx -> decl = scope;
126 return scope;
127 }
128
129 static void
130 oberon_close_scope(oberon_scope_t * scope)
131 {
132 oberon_context_t * ctx = scope -> ctx;
133 ctx -> decl = scope -> up;
134 }
135
136 static oberon_object_t *
137 oberon_define_object(oberon_scope_t * scope, char * name, int class, int export, int read_only)
138 {
139 oberon_object_t * x = scope -> list;
140 while(x -> next && strcmp(x -> next -> name, name) != 0)
141 {
142 x = x -> next;
143 }
144
145 if(x -> next)
146 {
147 oberon_error(scope -> ctx, "already defined");
148 }
149
150 oberon_object_t * newvar = malloc(sizeof *newvar);
151 memset(newvar, 0, sizeof *newvar);
152 newvar -> name = name;
153 newvar -> class = class;
154 newvar -> export = export;
155 newvar -> read_only = read_only;
156 newvar -> local = scope -> local;
157 newvar -> parent = scope -> parent;
158 newvar -> module = scope -> ctx -> mod;
159
160 x -> next = newvar;
161
162 return newvar;
163 }
164
165 static oberon_object_t *
166 oberon_find_object_in_list(oberon_object_t * list, char * name)
167 {
168 oberon_object_t * x = list;
169 while(x -> next && strcmp(x -> next -> name, name) != 0)
170 {
171 x = x -> next;
172 }
173 return x -> next;
174 }
175
176 static oberon_object_t *
177 oberon_find_object(oberon_scope_t * scope, char * name, int check_it)
178 {
179 oberon_object_t * result = NULL;
180
181 oberon_scope_t * s = scope;
182 while(result == NULL && s != NULL)
183 {
184 result = oberon_find_object_in_list(s -> list, name);
185 s = s -> up;
186 }
187
188 if(check_it && result == NULL)
189 {
190 oberon_error(scope -> ctx, "undefined ident %s", name);
191 }
192
193 return result;
194 }
195
196 static oberon_object_t *
197 oberon_find_field(oberon_context_t * ctx, oberon_type_t * rec, char * name)
198 {
199 oberon_object_t * x = rec -> decl;
200 for(int i = 0; i < rec -> num_decl; i++)
201 {
202 if(strcmp(x -> name, name) == 0)
203 {
204 return x;
205 }
206 x = x -> next;
207 }
208
209 oberon_error(ctx, "field not defined");
210
211 return NULL;
212 }
213
214 static oberon_object_t *
215 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export)
216 {
217 oberon_object_t * id;
218 id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, 0);
219 id -> type = type;
220 oberon_generator_init_type(scope -> ctx, type);
221 return id;
222 }
223
224 // =======================================================================
225 // SCANER
226 // =======================================================================
227
228 static void
229 oberon_get_char(oberon_context_t * ctx)
230 {
231 if(ctx -> code[ctx -> code_index])
232 {
233 ctx -> code_index += 1;
234 ctx -> c = ctx -> code[ctx -> code_index];
235 }
236 }
237
238 static void
239 oberon_init_scaner(oberon_context_t * ctx, const char * code)
240 {
241 ctx -> code = code;
242 ctx -> code_index = 0;
243 ctx -> c = ctx -> code[ctx -> code_index];
244 }
245
246 static void
247 oberon_read_ident(oberon_context_t * ctx)
248 {
249 int len = 0;
250 int i = ctx -> code_index;
251
252 int c = ctx -> code[i];
253 while(isalnum(c))
254 {
255 i += 1;
256 len += 1;
257 c = ctx -> code[i];
258 }
259
260 char * ident = malloc(len + 1);
261 memcpy(ident, &ctx->code[ctx->code_index], len);
262 ident[len] = 0;
263
264 ctx -> code_index = i;
265 ctx -> c = ctx -> code[i];
266 ctx -> string = ident;
267 ctx -> token = IDENT;
268
269 if(strcmp(ident, "MODULE") == 0)
270 {
271 ctx -> token = MODULE;
272 }
273 else if(strcmp(ident, "END") == 0)
274 {
275 ctx -> token = END;
276 }
277 else if(strcmp(ident, "VAR") == 0)
278 {
279 ctx -> token = VAR;
280 }
281 else if(strcmp(ident, "BEGIN") == 0)
282 {
283 ctx -> token = BEGIN;
284 }
285 else if(strcmp(ident, "TRUE") == 0)
286 {
287 ctx -> token = TRUE;
288 }
289 else if(strcmp(ident, "FALSE") == 0)
290 {
291 ctx -> token = FALSE;
292 }
293 else if(strcmp(ident, "OR") == 0)
294 {
295 ctx -> token = OR;
296 }
297 else if(strcmp(ident, "DIV") == 0)
298 {
299 ctx -> token = DIV;
300 }
301 else if(strcmp(ident, "MOD") == 0)
302 {
303 ctx -> token = MOD;
304 }
305 else if(strcmp(ident, "PROCEDURE") == 0)
306 {
307 ctx -> token = PROCEDURE;
308 }
309 else if(strcmp(ident, "RETURN") == 0)
310 {
311 ctx -> token = RETURN;
312 }
313 else if(strcmp(ident, "CONST") == 0)
314 {
315 ctx -> token = CONST;
316 }
317 else if(strcmp(ident, "TYPE") == 0)
318 {
319 ctx -> token = TYPE;
320 }
321 else if(strcmp(ident, "ARRAY") == 0)
322 {
323 ctx -> token = ARRAY;
324 }
325 else if(strcmp(ident, "OF") == 0)
326 {
327 ctx -> token = OF;
328 }
329 else if(strcmp(ident, "RECORD") == 0)
330 {
331 ctx -> token = RECORD;
332 }
333 else if(strcmp(ident, "POINTER") == 0)
334 {
335 ctx -> token = POINTER;
336 }
337 else if(strcmp(ident, "TO") == 0)
338 {
339 ctx -> token = TO;
340 }
341 else if(strcmp(ident, "NIL") == 0)
342 {
343 ctx -> token = NIL;
344 }
345 else if(strcmp(ident, "IMPORT") == 0)
346 {
347 ctx -> token = IMPORT;
348 }
349 }
350
351 static void
352 oberon_read_integer(oberon_context_t * ctx)
353 {
354 int len = 0;
355 int i = ctx -> code_index;
356
357 int c = ctx -> code[i];
358 while(isdigit(c))
359 {
360 i += 1;
361 len += 1;
362 c = ctx -> code[i];
363 }
364
365 char * ident = malloc(len + 2);
366 memcpy(ident, &ctx->code[ctx->code_index], len);
367 ident[len + 1] = 0;
368
369 ctx -> code_index = i;
370 ctx -> c = ctx -> code[i];
371 ctx -> string = ident;
372 ctx -> integer = atoi(ident);
373 ctx -> token = INTEGER;
374 }
375
376 static void
377 oberon_skip_space(oberon_context_t * ctx)
378 {
379 while(isspace(ctx -> c))
380 {
381 oberon_get_char(ctx);
382 }
383 }
384
385 static void
386 oberon_read_comment(oberon_context_t * ctx)
387 {
388 int nesting = 1;
389 while(nesting >= 1)
390 {
391 if(ctx -> c == '(')
392 {
393 oberon_get_char(ctx);
394 if(ctx -> c == '*')
395 {
396 oberon_get_char(ctx);
397 nesting += 1;
398 }
399 }
400 else if(ctx -> c == '*')
401 {
402 oberon_get_char(ctx);
403 if(ctx -> c == ')')
404 {
405 oberon_get_char(ctx);
406 nesting -= 1;
407 }
408 }
409 else if(ctx -> c == 0)
410 {
411 oberon_error(ctx, "unterminated comment");
412 }
413 else
414 {
415 oberon_get_char(ctx);
416 }
417 }
418 }
419
420 static void oberon_read_token(oberon_context_t * ctx);
421
422 static void
423 oberon_read_symbol(oberon_context_t * ctx)
424 {
425 int c = ctx -> c;
426 switch(c)
427 {
428 case 0:
429 ctx -> token = EOF_;
430 break;
431 case ';':
432 ctx -> token = SEMICOLON;
433 oberon_get_char(ctx);
434 break;
435 case ':':
436 ctx -> token = COLON;
437 oberon_get_char(ctx);
438 if(ctx -> c == '=')
439 {
440 ctx -> token = ASSIGN;
441 oberon_get_char(ctx);
442 }
443 break;
444 case '.':
445 ctx -> token = DOT;
446 oberon_get_char(ctx);
447 break;
448 case '(':
449 ctx -> token = LPAREN;
450 oberon_get_char(ctx);
451 if(ctx -> c == '*')
452 {
453 oberon_get_char(ctx);
454 oberon_read_comment(ctx);
455 oberon_read_token(ctx);
456 }
457 break;
458 case ')':
459 ctx -> token = RPAREN;
460 oberon_get_char(ctx);
461 break;
462 case '=':
463 ctx -> token = EQUAL;
464 oberon_get_char(ctx);
465 break;
466 case '#':
467 ctx -> token = NEQ;
468 oberon_get_char(ctx);
469 break;
470 case '<':
471 ctx -> token = LESS;
472 oberon_get_char(ctx);
473 if(ctx -> c == '=')
474 {
475 ctx -> token = LEQ;
476 oberon_get_char(ctx);
477 }
478 break;
479 case '>':
480 ctx -> token = GREAT;
481 oberon_get_char(ctx);
482 if(ctx -> c == '=')
483 {
484 ctx -> token = GEQ;
485 oberon_get_char(ctx);
486 }
487 break;
488 case '+':
489 ctx -> token = PLUS;
490 oberon_get_char(ctx);
491 break;
492 case '-':
493 ctx -> token = MINUS;
494 oberon_get_char(ctx);
495 break;
496 case '*':
497 ctx -> token = STAR;
498 oberon_get_char(ctx);
499 if(ctx -> c == ')')
500 {
501 oberon_get_char(ctx);
502 oberon_error(ctx, "unstarted comment");
503 }
504 break;
505 case '/':
506 ctx -> token = SLASH;
507 oberon_get_char(ctx);
508 break;
509 case '&':
510 ctx -> token = AND;
511 oberon_get_char(ctx);
512 break;
513 case '~':
514 ctx -> token = NOT;
515 oberon_get_char(ctx);
516 break;
517 case ',':
518 ctx -> token = COMMA;
519 oberon_get_char(ctx);
520 break;
521 case '[':
522 ctx -> token = LBRACE;
523 oberon_get_char(ctx);
524 break;
525 case ']':
526 ctx -> token = RBRACE;
527 oberon_get_char(ctx);
528 break;
529 case '^':
530 ctx -> token = UPARROW;
531 oberon_get_char(ctx);
532 break;
533 default:
534 oberon_error(ctx, "invalid char %c", ctx -> c);
535 break;
536 }
537 }
538
539 static void
540 oberon_read_token(oberon_context_t * ctx)
541 {
542 oberon_skip_space(ctx);
543
544 int c = ctx -> c;
545 if(isalpha(c))
546 {
547 oberon_read_ident(ctx);
548 }
549 else if(isdigit(c))
550 {
551 oberon_read_integer(ctx);
552 }
553 else
554 {
555 oberon_read_symbol(ctx);
556 }
557 }
558
559 // =======================================================================
560 // EXPRESSION
561 // =======================================================================
562
563 static void oberon_expect_token(oberon_context_t * ctx, int token);
564 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
565 static void oberon_assert_token(oberon_context_t * ctx, int token);
566 static char * oberon_assert_ident(oberon_context_t * ctx);
567 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
568 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
569
570 static oberon_expr_t *
571 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
572 {
573 oberon_oper_t * operator;
574 operator = malloc(sizeof *operator);
575 memset(operator, 0, sizeof *operator);
576
577 operator -> is_item = 0;
578 operator -> result = result;
579 operator -> read_only = 1;
580 operator -> op = op;
581 operator -> left = left;
582 operator -> right = right;
583
584 return (oberon_expr_t *) operator;
585 }
586
587 static oberon_expr_t *
588 oberon_new_item(int mode, oberon_type_t * result, int read_only)
589 {
590 oberon_item_t * item;
591 item = malloc(sizeof *item);
592 memset(item, 0, sizeof *item);
593
594 item -> is_item = 1;
595 item -> result = result;
596 item -> read_only = read_only;
597 item -> mode = mode;
598
599 return (oberon_expr_t *)item;
600 }
601
602 static oberon_expr_t *
603 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
604 {
605 oberon_expr_t * expr;
606 oberon_type_t * result;
607
608 result = a -> result;
609
610 if(token == MINUS)
611 {
612 if(result -> class != OBERON_TYPE_INTEGER)
613 {
614 oberon_error(ctx, "incompatible operator type");
615 }
616
617 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
618 }
619 else if(token == NOT)
620 {
621 if(result -> class != OBERON_TYPE_BOOLEAN)
622 {
623 oberon_error(ctx, "incompatible operator type");
624 }
625
626 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
627 }
628 else
629 {
630 oberon_error(ctx, "oberon_make_unary_op: wat");
631 }
632
633 return expr;
634 }
635
636 static void
637 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
638 {
639 oberon_expr_t * last;
640
641 *num_expr = 1;
642 *first = last = oberon_expr(ctx);
643 while(ctx -> token == COMMA)
644 {
645 oberon_assert_token(ctx, COMMA);
646 oberon_expr_t * current;
647
648 if(const_expr)
649 {
650 current = (oberon_expr_t *) oberon_const_expr(ctx);
651 }
652 else
653 {
654 current = oberon_expr(ctx);
655 }
656
657 last -> next = current;
658 last = current;
659 *num_expr += 1;
660 }
661 }
662
663 static oberon_expr_t *
664 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
665 {
666 if(pref -> class != expr -> result -> class)
667 {
668 oberon_error(ctx, "incompatible types");
669 }
670
671 if(pref -> class == OBERON_TYPE_INTEGER)
672 {
673 if(expr -> result -> class > pref -> class)
674 {
675 oberon_error(ctx, "incompatible size");
676 }
677 }
678 else if(pref -> class == OBERON_TYPE_RECORD)
679 {
680 if(expr -> result != pref)
681 {
682 printf("oberon_autocast_to: rec %p != %p\n", expr -> result, pref);
683 oberon_error(ctx, "incompatible record types");
684 }
685 }
686 else if(pref -> class == OBERON_TYPE_POINTER)
687 {
688 if(expr -> result -> base != pref -> base)
689 {
690 if(expr -> result -> base -> class != OBERON_TYPE_VOID)
691 {
692 oberon_error(ctx, "incompatible pointer types");
693 }
694 }
695 }
696
697 // TODO cast
698
699 return expr;
700 }
701
702 static void
703 oberon_autocast_call(oberon_context_t * ctx, oberon_expr_t * desig)
704 {
705 if(desig -> is_item == 0)
706 {
707 oberon_error(ctx, "expected item");
708 }
709
710 if(desig -> item.mode != MODE_CALL)
711 {
712 oberon_error(ctx, "expected mode CALL");
713 }
714
715 if(desig -> item.var -> type -> class != OBERON_TYPE_PROCEDURE)
716 {
717 oberon_error(ctx, "only procedures can be called");
718 }
719
720 oberon_type_t * fn = desig -> item.var -> type;
721 int num_args = desig -> item.num_args;
722 int num_decl = fn -> num_decl;
723
724 if(num_args < num_decl)
725 {
726 oberon_error(ctx, "too few arguments");
727 }
728 else if(num_args > num_decl)
729 {
730 oberon_error(ctx, "too many arguments");
731 }
732
733 oberon_expr_t * arg = desig -> item.args;
734 oberon_object_t * param = fn -> decl;
735 for(int i = 0; i < num_args; i++)
736 {
737 if(param -> class == OBERON_CLASS_VAR_PARAM)
738 {
739 if(arg -> is_item)
740 {
741 switch(arg -> item.mode)
742 {
743 case MODE_VAR:
744 case MODE_INDEX:
745 case MODE_FIELD:
746 // Допустимо разыменование?
747 //case MODE_DEREF:
748 break;
749 default:
750 oberon_error(ctx, "var-parameter accept only variables");
751 break;
752 }
753 }
754 }
755 oberon_autocast_to(ctx, arg, param -> type);
756 arg = arg -> next;
757 param = param -> next;
758 }
759 }
760
761 static oberon_expr_t *
762 oberon_make_call_func(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
763 {
764 switch(proc -> class)
765 {
766 case OBERON_CLASS_PROC:
767 if(proc -> class != OBERON_CLASS_PROC)
768 {
769 oberon_error(ctx, "not a procedure");
770 }
771 break;
772 case OBERON_CLASS_VAR:
773 case OBERON_CLASS_VAR_PARAM:
774 case OBERON_CLASS_PARAM:
775 if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
776 {
777 oberon_error(ctx, "not a procedure");
778 }
779 break;
780 default:
781 oberon_error(ctx, "not a procedure");
782 break;
783 }
784
785 oberon_expr_t * call;
786
787 if(proc -> sysproc)
788 {
789 if(proc -> genfunc == NULL)
790 {
791 oberon_error(ctx, "not a function-procedure");
792 }
793
794 call = proc -> genfunc(ctx, num_args, list_args);
795 }
796 else
797 {
798 if(proc -> type -> base -> class == OBERON_TYPE_VOID)
799 {
800 oberon_error(ctx, "attempt to call procedure in expression");
801 }
802
803 call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
804 call -> item.var = proc;
805 call -> item.num_args = num_args;
806 call -> item.args = list_args;
807 oberon_autocast_call(ctx, call);
808 }
809
810 return call;
811 }
812
813 static void
814 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
815 {
816 switch(proc -> class)
817 {
818 case OBERON_CLASS_PROC:
819 if(proc -> class != OBERON_CLASS_PROC)
820 {
821 oberon_error(ctx, "not a procedure");
822 }
823 break;
824 case OBERON_CLASS_VAR:
825 case OBERON_CLASS_VAR_PARAM:
826 case OBERON_CLASS_PARAM:
827 if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
828 {
829 oberon_error(ctx, "not a procedure");
830 }
831 break;
832 default:
833 oberon_error(ctx, "not a procedure");
834 break;
835 }
836
837 if(proc -> sysproc)
838 {
839 if(proc -> genproc == NULL)
840 {
841 oberon_error(ctx, "requres non-typed procedure");
842 }
843
844 proc -> genproc(ctx, num_args, list_args);
845 }
846 else
847 {
848 if(proc -> type -> base -> class != OBERON_TYPE_VOID)
849 {
850 oberon_error(ctx, "attempt to call function as non-typed procedure");
851 }
852
853 oberon_expr_t * call;
854 call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
855 call -> item.var = proc;
856 call -> item.num_args = num_args;
857 call -> item.args = list_args;
858 oberon_autocast_call(ctx, call);
859 oberon_generate_call_proc(ctx, call);
860 }
861 }
862
863 #define ISEXPR(x) \
864 (((x) == PLUS) \
865 || ((x) == MINUS) \
866 || ((x) == IDENT) \
867 || ((x) == INTEGER) \
868 || ((x) == LPAREN) \
869 || ((x) == NOT) \
870 || ((x) == TRUE) \
871 || ((x) == FALSE))
872
873 static oberon_expr_t *
874 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
875 {
876 if(expr -> result -> class != OBERON_TYPE_POINTER)
877 {
878 oberon_error(ctx, "not a pointer");
879 }
880
881 assert(expr -> is_item);
882
883 oberon_expr_t * selector;
884 selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
885 selector -> item.parent = (oberon_item_t *) expr;
886
887 return selector;
888 }
889
890 static oberon_expr_t *
891 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
892 {
893 if(desig -> result -> class == OBERON_TYPE_POINTER)
894 {
895 desig = oberno_make_dereferencing(ctx, desig);
896 }
897
898 assert(desig -> is_item);
899
900 if(desig -> result -> class != OBERON_TYPE_ARRAY)
901 {
902 oberon_error(ctx, "not array");
903 }
904
905 oberon_type_t * base;
906 base = desig -> result -> base;
907
908 if(index -> result -> class != OBERON_TYPE_INTEGER)
909 {
910 oberon_error(ctx, "index must be integer");
911 }
912
913 // Статическая проверка границ массива
914 if(index -> is_item)
915 {
916 if(index -> item.mode == MODE_INTEGER)
917 {
918 int arr_size = desig -> result -> size;
919 int index_int = index -> item.integer;
920 if(index_int < 0 || index_int > arr_size - 1)
921 {
922 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
923 }
924 }
925 }
926
927 oberon_expr_t * selector;
928 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
929 selector -> item.parent = (oberon_item_t *) desig;
930 selector -> item.num_args = 1;
931 selector -> item.args = index;
932
933 return selector;
934 }
935
936 static oberon_expr_t *
937 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
938 {
939 if(expr -> result -> class == OBERON_TYPE_POINTER)
940 {
941 expr = oberno_make_dereferencing(ctx, expr);
942 }
943
944 assert(expr -> is_item == 1);
945
946 if(expr -> result -> class != OBERON_TYPE_RECORD)
947 {
948 oberon_error(ctx, "not record");
949 }
950
951 oberon_type_t * rec = expr -> result;
952
953 oberon_object_t * field;
954 field = oberon_find_field(ctx, rec, name);
955
956 if(field -> export == 0)
957 {
958 if(field -> module != ctx -> mod)
959 {
960 oberon_error(ctx, "field not exported");
961 }
962 }
963
964 int read_only = 0;
965 if(field -> read_only)
966 {
967 if(field -> module != ctx -> mod)
968 {
969 read_only = 1;
970 }
971 }
972
973 oberon_expr_t * selector;
974 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
975 selector -> item.var = field;
976 selector -> item.parent = (oberon_item_t *) expr;
977
978 return selector;
979 }
980
981 #define ISSELECTOR(x) \
982 (((x) == LBRACE) \
983 || ((x) == DOT) \
984 || ((x) == UPARROW))
985
986 static oberon_object_t *
987 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
988 {
989 char * name;
990 oberon_object_t * x;
991
992 name = oberon_assert_ident(ctx);
993 x = oberon_find_object(ctx -> decl, name, check);
994
995 if(x != NULL)
996 {
997 if(x -> class == OBERON_CLASS_MODULE)
998 {
999 oberon_assert_token(ctx, DOT);
1000 name = oberon_assert_ident(ctx);
1001 /* Наличие объектов в левых модулях всегда проверяется */
1002 x = oberon_find_object(x -> module -> decl, name, 1);
1003
1004 if(x -> export == 0)
1005 {
1006 oberon_error(ctx, "not exported");
1007 }
1008 }
1009 }
1010
1011 if(xname)
1012 {
1013 *xname = name;
1014 }
1015
1016 return x;
1017 }
1018
1019 static oberon_expr_t *
1020 oberon_designator(oberon_context_t * ctx)
1021 {
1022 char * name;
1023 oberon_object_t * var;
1024 oberon_expr_t * expr;
1025
1026 var = oberon_qualident(ctx, NULL, 1);
1027
1028 int read_only = 0;
1029 if(var -> read_only)
1030 {
1031 if(var -> module != ctx -> mod)
1032 {
1033 read_only = 1;
1034 }
1035 }
1036
1037 switch(var -> class)
1038 {
1039 case OBERON_CLASS_CONST:
1040 // TODO copy value
1041 expr = (oberon_expr_t *) var -> value;
1042 break;
1043 case OBERON_CLASS_VAR:
1044 case OBERON_CLASS_VAR_PARAM:
1045 case OBERON_CLASS_PARAM:
1046 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1047 break;
1048 case OBERON_CLASS_PROC:
1049 expr = oberon_new_item(MODE_VAR, var -> type, 1);
1050 break;
1051 default:
1052 oberon_error(ctx, "invalid designator");
1053 break;
1054 }
1055 expr -> item.var = var;
1056
1057 while(ISSELECTOR(ctx -> token))
1058 {
1059 switch(ctx -> token)
1060 {
1061 case DOT:
1062 oberon_assert_token(ctx, DOT);
1063 name = oberon_assert_ident(ctx);
1064 expr = oberon_make_record_selector(ctx, expr, name);
1065 break;
1066 case LBRACE:
1067 oberon_assert_token(ctx, LBRACE);
1068 int num_indexes = 0;
1069 oberon_expr_t * indexes = NULL;
1070 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1071 oberon_assert_token(ctx, RBRACE);
1072
1073 for(int i = 0; i < num_indexes; i++)
1074 {
1075 expr = oberon_make_array_selector(ctx, expr, indexes);
1076 indexes = indexes -> next;
1077 }
1078 break;
1079 case UPARROW:
1080 oberon_assert_token(ctx, UPARROW);
1081 expr = oberno_make_dereferencing(ctx, expr);
1082 break;
1083 default:
1084 oberon_error(ctx, "oberon_designator: wat");
1085 break;
1086 }
1087 }
1088 return expr;
1089 }
1090
1091 static oberon_expr_t *
1092 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1093 {
1094 assert(expr -> is_item == 1);
1095
1096 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1097 if(ctx -> token == LPAREN)
1098 {
1099 oberon_assert_token(ctx, LPAREN);
1100
1101 int num_args = 0;
1102 oberon_expr_t * arguments = NULL;
1103
1104 if(ISEXPR(ctx -> token))
1105 {
1106 oberon_expr_list(ctx, &num_args, &arguments, 0);
1107 }
1108
1109 expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
1110
1111 oberon_assert_token(ctx, RPAREN);
1112 }
1113
1114 return expr;
1115 }
1116
1117 static void
1118 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1119 {
1120 assert(expr -> is_item == 1);
1121
1122 int num_args = 0;
1123 oberon_expr_t * arguments = NULL;
1124
1125 if(ctx -> token == LPAREN)
1126 {
1127 oberon_assert_token(ctx, LPAREN);
1128
1129 if(ISEXPR(ctx -> token))
1130 {
1131 oberon_expr_list(ctx, &num_args, &arguments, 0);
1132 }
1133
1134 oberon_assert_token(ctx, RPAREN);
1135 }
1136
1137 /* Вызов происходит даже без скобок */
1138 oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
1139 }
1140
1141 static oberon_expr_t *
1142 oberon_factor(oberon_context_t * ctx)
1143 {
1144 oberon_expr_t * expr;
1145
1146 switch(ctx -> token)
1147 {
1148 case IDENT:
1149 expr = oberon_designator(ctx);
1150 expr = oberon_opt_func_parens(ctx, expr);
1151 break;
1152 case INTEGER:
1153 expr = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
1154 expr -> item.integer = ctx -> integer;
1155 oberon_assert_token(ctx, INTEGER);
1156 break;
1157 case TRUE:
1158 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1159 expr -> item.boolean = 1;
1160 oberon_assert_token(ctx, TRUE);
1161 break;
1162 case FALSE:
1163 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1164 expr -> item.boolean = 0;
1165 oberon_assert_token(ctx, FALSE);
1166 break;
1167 case LPAREN:
1168 oberon_assert_token(ctx, LPAREN);
1169 expr = oberon_expr(ctx);
1170 oberon_assert_token(ctx, RPAREN);
1171 break;
1172 case NOT:
1173 oberon_assert_token(ctx, NOT);
1174 expr = oberon_factor(ctx);
1175 expr = oberon_make_unary_op(ctx, NOT, expr);
1176 break;
1177 case NIL:
1178 oberon_assert_token(ctx, NIL);
1179 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, 1);
1180 break;
1181 default:
1182 oberon_error(ctx, "invalid expression");
1183 }
1184
1185 return expr;
1186 }
1187
1188 /*
1189 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1190 * 1. Классы обоих типов должны быть одинаковы
1191 * 2. В качестве результата должен быть выбран больший тип.
1192 * 3. Если размер результат не должен быть меньше чем базовый int
1193 */
1194
1195 static void
1196 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
1197 {
1198 if((a -> class) != (b -> class))
1199 {
1200 oberon_error(ctx, "incompatible types");
1201 }
1202
1203 if((a -> size) > (b -> size))
1204 {
1205 *result = a;
1206 }
1207 else
1208 {
1209 *result = b;
1210 }
1211
1212 if(((*result) -> class) == OBERON_TYPE_INTEGER)
1213 {
1214 if(((*result) -> size) < (ctx -> int_type -> size))
1215 {
1216 *result = ctx -> int_type;
1217 }
1218 }
1219
1220 /* TODO: cast types */
1221 }
1222
1223 #define ITMAKESBOOLEAN(x) \
1224 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1225
1226 #define ITUSEONLYINTEGER(x) \
1227 ((x) >= LESS && (x) <= GEQ)
1228
1229 #define ITUSEONLYBOOLEAN(x) \
1230 (((x) == OR) || ((x) == AND))
1231
1232 static oberon_expr_t *
1233 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1234 {
1235 oberon_expr_t * expr;
1236 oberon_type_t * result;
1237
1238 if(ITMAKESBOOLEAN(token))
1239 {
1240 if(ITUSEONLYINTEGER(token))
1241 {
1242 if(a -> result -> class != OBERON_TYPE_INTEGER
1243 || b -> result -> class != OBERON_TYPE_INTEGER)
1244 {
1245 oberon_error(ctx, "used only with integer types");
1246 }
1247 }
1248 else if(ITUSEONLYBOOLEAN(token))
1249 {
1250 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1251 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1252 {
1253 oberon_error(ctx, "used only with boolean type");
1254 }
1255 }
1256
1257 result = ctx -> bool_type;
1258
1259 if(token == EQUAL)
1260 {
1261 expr = oberon_new_operator(OP_EQ, result, a, b);
1262 }
1263 else if(token == NEQ)
1264 {
1265 expr = oberon_new_operator(OP_NEQ, result, a, b);
1266 }
1267 else if(token == LESS)
1268 {
1269 expr = oberon_new_operator(OP_LSS, result, a, b);
1270 }
1271 else if(token == LEQ)
1272 {
1273 expr = oberon_new_operator(OP_LEQ, result, a, b);
1274 }
1275 else if(token == GREAT)
1276 {
1277 expr = oberon_new_operator(OP_GRT, result, a, b);
1278 }
1279 else if(token == GEQ)
1280 {
1281 expr = oberon_new_operator(OP_GEQ, result, a, b);
1282 }
1283 else if(token == OR)
1284 {
1285 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1286 }
1287 else if(token == AND)
1288 {
1289 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1290 }
1291 else
1292 {
1293 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1294 }
1295 }
1296 else
1297 {
1298 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1299
1300 if(token == PLUS)
1301 {
1302 expr = oberon_new_operator(OP_ADD, result, a, b);
1303 }
1304 else if(token == MINUS)
1305 {
1306 expr = oberon_new_operator(OP_SUB, result, a, b);
1307 }
1308 else if(token == STAR)
1309 {
1310 expr = oberon_new_operator(OP_MUL, result, a, b);
1311 }
1312 else if(token == SLASH)
1313 {
1314 expr = oberon_new_operator(OP_DIV, result, a, b);
1315 }
1316 else if(token == DIV)
1317 {
1318 expr = oberon_new_operator(OP_DIV, result, a, b);
1319 }
1320 else if(token == MOD)
1321 {
1322 expr = oberon_new_operator(OP_MOD, result, a, b);
1323 }
1324 else
1325 {
1326 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1327 }
1328 }
1329
1330 return expr;
1331 }
1332
1333 #define ISMULOP(x) \
1334 ((x) >= STAR && (x) <= AND)
1335
1336 static oberon_expr_t *
1337 oberon_term_expr(oberon_context_t * ctx)
1338 {
1339 oberon_expr_t * expr;
1340
1341 expr = oberon_factor(ctx);
1342 while(ISMULOP(ctx -> token))
1343 {
1344 int token = ctx -> token;
1345 oberon_read_token(ctx);
1346
1347 oberon_expr_t * inter = oberon_factor(ctx);
1348 expr = oberon_make_bin_op(ctx, token, expr, inter);
1349 }
1350
1351 return expr;
1352 }
1353
1354 #define ISADDOP(x) \
1355 ((x) >= PLUS && (x) <= OR)
1356
1357 static oberon_expr_t *
1358 oberon_simple_expr(oberon_context_t * ctx)
1359 {
1360 oberon_expr_t * expr;
1361
1362 int minus = 0;
1363 if(ctx -> token == PLUS)
1364 {
1365 minus = 0;
1366 oberon_assert_token(ctx, PLUS);
1367 }
1368 else if(ctx -> token == MINUS)
1369 {
1370 minus = 1;
1371 oberon_assert_token(ctx, MINUS);
1372 }
1373
1374 expr = oberon_term_expr(ctx);
1375 while(ISADDOP(ctx -> token))
1376 {
1377 int token = ctx -> token;
1378 oberon_read_token(ctx);
1379
1380 oberon_expr_t * inter = oberon_term_expr(ctx);
1381 expr = oberon_make_bin_op(ctx, token, expr, inter);
1382 }
1383
1384 if(minus)
1385 {
1386 expr = oberon_make_unary_op(ctx, MINUS, expr);
1387 }
1388
1389 return expr;
1390 }
1391
1392 #define ISRELATION(x) \
1393 ((x) >= EQUAL && (x) <= GEQ)
1394
1395 static oberon_expr_t *
1396 oberon_expr(oberon_context_t * ctx)
1397 {
1398 oberon_expr_t * expr;
1399
1400 expr = oberon_simple_expr(ctx);
1401 while(ISRELATION(ctx -> token))
1402 {
1403 int token = ctx -> token;
1404 oberon_read_token(ctx);
1405
1406 oberon_expr_t * inter = oberon_simple_expr(ctx);
1407 expr = oberon_make_bin_op(ctx, token, expr, inter);
1408 }
1409
1410 return expr;
1411 }
1412
1413 static oberon_item_t *
1414 oberon_const_expr(oberon_context_t * ctx)
1415 {
1416 oberon_expr_t * expr;
1417 expr = oberon_expr(ctx);
1418
1419 if(expr -> is_item == 0)
1420 {
1421 oberon_error(ctx, "const expression are required");
1422 }
1423
1424 return (oberon_item_t *) expr;
1425 }
1426
1427 // =======================================================================
1428 // PARSER
1429 // =======================================================================
1430
1431 static void oberon_decl_seq(oberon_context_t * ctx);
1432 static void oberon_statement_seq(oberon_context_t * ctx);
1433 static void oberon_initialize_decl(oberon_context_t * ctx);
1434
1435 static void
1436 oberon_expect_token(oberon_context_t * ctx, int token)
1437 {
1438 if(ctx -> token != token)
1439 {
1440 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1441 }
1442 }
1443
1444 static void
1445 oberon_assert_token(oberon_context_t * ctx, int token)
1446 {
1447 oberon_expect_token(ctx, token);
1448 oberon_read_token(ctx);
1449 }
1450
1451 static char *
1452 oberon_assert_ident(oberon_context_t * ctx)
1453 {
1454 oberon_expect_token(ctx, IDENT);
1455 char * ident = ctx -> string;
1456 oberon_read_token(ctx);
1457 return ident;
1458 }
1459
1460 static void
1461 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
1462 {
1463 switch(ctx -> token)
1464 {
1465 case STAR:
1466 oberon_assert_token(ctx, STAR);
1467 *export = 1;
1468 *read_only = 0;
1469 break;
1470 case MINUS:
1471 oberon_assert_token(ctx, MINUS);
1472 *export = 1;
1473 *read_only = 1;
1474 break;
1475 default:
1476 *export = 0;
1477 *read_only = 0;
1478 break;
1479 }
1480 }
1481
1482 static oberon_object_t *
1483 oberon_ident_def(oberon_context_t * ctx, int class)
1484 {
1485 char * name;
1486 int export;
1487 int read_only;
1488 oberon_object_t * x;
1489
1490 name = oberon_assert_ident(ctx);
1491 oberon_def(ctx, &export, &read_only);
1492
1493 x = oberon_define_object(ctx -> decl, name, class, export, read_only);
1494 return x;
1495 }
1496
1497 static void
1498 oberon_ident_list(oberon_context_t * ctx, int class, int * num, oberon_object_t ** list)
1499 {
1500 *num = 1;
1501 *list = oberon_ident_def(ctx, class);
1502 while(ctx -> token == COMMA)
1503 {
1504 oberon_assert_token(ctx, COMMA);
1505 oberon_ident_def(ctx, class);
1506 *num += 1;
1507 }
1508 }
1509
1510 static void
1511 oberon_var_decl(oberon_context_t * ctx)
1512 {
1513 int num;
1514 oberon_object_t * list;
1515 oberon_type_t * type;
1516 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1517
1518 oberon_ident_list(ctx, OBERON_CLASS_VAR, &num, &list);
1519 oberon_assert_token(ctx, COLON);
1520 oberon_type(ctx, &type);
1521
1522 oberon_object_t * var = list;
1523 for(int i = 0; i < num; i++)
1524 {
1525 var -> type = type;
1526 var = var -> next;
1527 }
1528 }
1529
1530 static oberon_object_t *
1531 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1532 {
1533 int class = OBERON_CLASS_PARAM;
1534 if(ctx -> token == VAR)
1535 {
1536 oberon_read_token(ctx);
1537 class = OBERON_CLASS_VAR_PARAM;
1538 }
1539
1540 int num;
1541 oberon_object_t * list;
1542 oberon_ident_list(ctx, class, &num, &list);
1543
1544 oberon_assert_token(ctx, COLON);
1545
1546 oberon_type_t * type;
1547 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1548 oberon_type(ctx, &type);
1549
1550 oberon_object_t * param = list;
1551 for(int i = 0; i < num; i++)
1552 {
1553 param -> type = type;
1554 param = param -> next;
1555 }
1556
1557 *num_decl += num;
1558 return list;
1559 }
1560
1561 #define ISFPSECTION \
1562 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1563
1564 static void
1565 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1566 {
1567 oberon_assert_token(ctx, LPAREN);
1568
1569 if(ISFPSECTION)
1570 {
1571 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
1572 while(ctx -> token == SEMICOLON)
1573 {
1574 oberon_assert_token(ctx, SEMICOLON);
1575 oberon_fp_section(ctx, &signature -> num_decl);
1576 }
1577 }
1578
1579 oberon_assert_token(ctx, RPAREN);
1580
1581 if(ctx -> token == COLON)
1582 {
1583 oberon_assert_token(ctx, COLON);
1584
1585 oberon_object_t * typeobj;
1586 typeobj = oberon_qualident(ctx, NULL, 1);
1587 if(typeobj -> class != OBERON_CLASS_TYPE)
1588 {
1589 oberon_error(ctx, "function result is not type");
1590 }
1591 signature -> base = typeobj -> type;
1592 }
1593 }
1594
1595 static void
1596 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
1597 {
1598 oberon_type_t * signature;
1599 signature = *type;
1600 signature -> class = OBERON_TYPE_PROCEDURE;
1601 signature -> num_decl = 0;
1602 signature -> base = ctx -> void_type;
1603 signature -> decl = NULL;
1604
1605 if(ctx -> token == LPAREN)
1606 {
1607 oberon_formal_pars(ctx, signature);
1608 }
1609 }
1610
1611 static void
1612 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1613 {
1614 if(a -> num_decl != b -> num_decl)
1615 {
1616 oberon_error(ctx, "number parameters not matched");
1617 }
1618
1619 int num_param = a -> num_decl;
1620 oberon_object_t * param_a = a -> decl;
1621 oberon_object_t * param_b = b -> decl;
1622 for(int i = 0; i < num_param; i++)
1623 {
1624 if(strcmp(param_a -> name, param_b -> name) != 0)
1625 {
1626 oberon_error(ctx, "param %i name not matched", i + 1);
1627 }
1628
1629 if(param_a -> type != param_b -> type)
1630 {
1631 oberon_error(ctx, "param %i type not matched", i + 1);
1632 }
1633
1634 param_a = param_a -> next;
1635 param_b = param_b -> next;
1636 }
1637 }
1638
1639 static void
1640 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1641 {
1642 oberon_object_t * proc = ctx -> decl -> parent;
1643 oberon_type_t * result_type = proc -> type -> base;
1644
1645 if(result_type -> class == OBERON_TYPE_VOID)
1646 {
1647 if(expr != NULL)
1648 {
1649 oberon_error(ctx, "procedure has no result type");
1650 }
1651 }
1652 else
1653 {
1654 if(expr == NULL)
1655 {
1656 oberon_error(ctx, "procedure requires expression on result");
1657 }
1658
1659 oberon_autocast_to(ctx, expr, result_type);
1660 }
1661
1662 proc -> has_return = 1;
1663
1664 oberon_generate_return(ctx, expr);
1665 }
1666
1667 static void
1668 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
1669 {
1670 oberon_assert_token(ctx, SEMICOLON);
1671
1672 ctx -> decl = proc -> scope;
1673
1674 oberon_decl_seq(ctx);
1675
1676 oberon_generate_begin_proc(ctx, proc);
1677
1678 if(ctx -> token == BEGIN)
1679 {
1680 oberon_assert_token(ctx, BEGIN);
1681 oberon_statement_seq(ctx);
1682 }
1683
1684 oberon_assert_token(ctx, END);
1685 char * name = oberon_assert_ident(ctx);
1686 if(strcmp(name, proc -> name) != 0)
1687 {
1688 oberon_error(ctx, "procedure name not matched");
1689 }
1690
1691 if(proc -> type -> base -> class == OBERON_TYPE_VOID
1692 && proc -> has_return == 0)
1693 {
1694 oberon_make_return(ctx, NULL);
1695 }
1696
1697 if(proc -> has_return == 0)
1698 {
1699 oberon_error(ctx, "procedure requires return");
1700 }
1701
1702 oberon_generate_end_proc(ctx);
1703 oberon_close_scope(ctx -> decl);
1704 }
1705
1706 static void
1707 oberon_proc_decl(oberon_context_t * ctx)
1708 {
1709 oberon_assert_token(ctx, PROCEDURE);
1710
1711 int forward = 0;
1712 if(ctx -> token == UPARROW)
1713 {
1714 oberon_assert_token(ctx, UPARROW);
1715 forward = 1;
1716 }
1717
1718 char * name;
1719 int export;
1720 int read_only;
1721 name = oberon_assert_ident(ctx);
1722 oberon_def(ctx, &export, &read_only);
1723
1724 oberon_scope_t * proc_scope;
1725 proc_scope = oberon_open_scope(ctx);
1726 ctx -> decl -> local = 1;
1727
1728 oberon_type_t * signature;
1729 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
1730 oberon_opt_formal_pars(ctx, &signature);
1731
1732 oberon_initialize_decl(ctx);
1733 oberon_generator_init_type(ctx, signature);
1734 oberon_close_scope(ctx -> decl);
1735
1736 oberon_object_t * proc;
1737 proc = oberon_find_object(ctx -> decl, name, 0);
1738 if(proc != NULL)
1739 {
1740 if(proc -> class != OBERON_CLASS_PROC)
1741 {
1742 oberon_error(ctx, "mult definition");
1743 }
1744
1745 if(forward == 0)
1746 {
1747 if(proc -> linked)
1748 {
1749 oberon_error(ctx, "mult procedure definition");
1750 }
1751 }
1752
1753 if(proc -> export != export || proc -> read_only != read_only)
1754 {
1755 oberon_error(ctx, "export type not matched");
1756 }
1757
1758 oberon_compare_signatures(ctx, proc -> type, signature);
1759 }
1760 else
1761 {
1762 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only);
1763 proc -> type = signature;
1764 proc -> scope = proc_scope;
1765 oberon_generator_init_proc(ctx, proc);
1766 }
1767
1768 proc -> scope -> parent = proc;
1769
1770 if(forward == 0)
1771 {
1772 proc -> linked = 1;
1773 oberon_proc_decl_body(ctx, proc);
1774 }
1775 }
1776
1777 static void
1778 oberon_const_decl(oberon_context_t * ctx)
1779 {
1780 oberon_item_t * value;
1781 oberon_object_t * constant;
1782
1783 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST);
1784 oberon_assert_token(ctx, EQUAL);
1785 value = oberon_const_expr(ctx);
1786 constant -> value = value;
1787 }
1788
1789 static void
1790 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
1791 {
1792 if(size -> is_item == 0)
1793 {
1794 oberon_error(ctx, "requires constant");
1795 }
1796
1797 if(size -> item.mode != MODE_INTEGER)
1798 {
1799 oberon_error(ctx, "requires integer constant");
1800 }
1801
1802 oberon_type_t * arr;
1803 arr = *type;
1804 arr -> class = OBERON_TYPE_ARRAY;
1805 arr -> size = size -> item.integer;
1806 arr -> base = base;
1807 }
1808
1809 static void
1810 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1811 {
1812 if(ctx -> token == IDENT)
1813 {
1814 int num;
1815 oberon_object_t * list;
1816 oberon_type_t * type;
1817 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1818
1819 oberon_ident_list(ctx, OBERON_CLASS_FIELD, &num, &list);
1820 oberon_assert_token(ctx, COLON);
1821 oberon_type(ctx, &type);
1822
1823 oberon_object_t * field = list;
1824 for(int i = 0; i < num; i++)
1825 {
1826 field -> type = type;
1827 field = field -> next;
1828 }
1829
1830 rec -> num_decl += num;
1831 }
1832 }
1833
1834 static void
1835 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
1836 {
1837 char * name;
1838 oberon_object_t * to;
1839
1840 to = oberon_qualident(ctx, &name, 0);
1841
1842 //name = oberon_assert_ident(ctx);
1843 //to = oberon_find_object(ctx -> decl, name, 0);
1844
1845 if(to != NULL)
1846 {
1847 if(to -> class != OBERON_CLASS_TYPE)
1848 {
1849 oberon_error(ctx, "not a type");
1850 }
1851 }
1852 else
1853 {
1854 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, 0, 0);
1855 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1856 }
1857
1858 *type = to -> type;
1859 }
1860
1861 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
1862
1863 /*
1864 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1865 */
1866
1867 static void
1868 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
1869 {
1870 if(sizes == NULL)
1871 {
1872 *type = base;
1873 return;
1874 }
1875
1876 oberon_type_t * dim;
1877 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
1878
1879 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
1880
1881 oberon_make_array_type(ctx, sizes, dim, type);
1882 }
1883
1884 static void
1885 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
1886 {
1887 if(ctx -> token == IDENT)
1888 {
1889 oberon_qualident_type(ctx, type);
1890 }
1891 else if(ctx -> token == ARRAY)
1892 {
1893 oberon_assert_token(ctx, ARRAY);
1894
1895 int num_sizes = 0;
1896 oberon_expr_t * sizes;
1897 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
1898
1899 oberon_assert_token(ctx, OF);
1900
1901 oberon_type_t * base;
1902 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1903 oberon_type(ctx, &base);
1904
1905 oberon_make_multiarray(ctx, sizes, base, type);
1906 }
1907 else if(ctx -> token == RECORD)
1908 {
1909 oberon_type_t * rec;
1910 rec = *type;
1911 rec -> class = OBERON_TYPE_RECORD;
1912
1913 oberon_scope_t * record_scope;
1914 record_scope = oberon_open_scope(ctx);
1915 // TODO parent object
1916 //record_scope -> parent = NULL;
1917 record_scope -> local = 1;
1918
1919 oberon_assert_token(ctx, RECORD);
1920 oberon_field_list(ctx, rec);
1921 while(ctx -> token == SEMICOLON)
1922 {
1923 oberon_assert_token(ctx, SEMICOLON);
1924 oberon_field_list(ctx, rec);
1925 }
1926 oberon_assert_token(ctx, END);
1927
1928 rec -> decl = record_scope -> list -> next;
1929 oberon_close_scope(record_scope);
1930
1931 *type = rec;
1932 }
1933 else if(ctx -> token == POINTER)
1934 {
1935 oberon_assert_token(ctx, POINTER);
1936 oberon_assert_token(ctx, TO);
1937
1938 oberon_type_t * base;
1939 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
1940 oberon_type(ctx, &base);
1941
1942 oberon_type_t * ptr;
1943 ptr = *type;
1944 ptr -> class = OBERON_TYPE_POINTER;
1945 ptr -> base = base;
1946 }
1947 else if(ctx -> token == PROCEDURE)
1948 {
1949 oberon_open_scope(ctx);
1950 oberon_assert_token(ctx, PROCEDURE);
1951 oberon_opt_formal_pars(ctx, type);
1952 oberon_close_scope(ctx -> decl);
1953 }
1954 else
1955 {
1956 oberon_error(ctx, "invalid type declaration");
1957 }
1958 }
1959
1960 static void
1961 oberon_type_decl(oberon_context_t * ctx)
1962 {
1963 char * name;
1964 oberon_object_t * newtype;
1965 oberon_type_t * type;
1966 int export;
1967 int read_only;
1968
1969 name = oberon_assert_ident(ctx);
1970 oberon_def(ctx, &export, &read_only);
1971
1972 newtype = oberon_find_object(ctx -> decl, name, 0);
1973 if(newtype == NULL)
1974 {
1975 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only);
1976 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1977 assert(newtype -> type);
1978 }
1979 else
1980 {
1981 if(newtype -> class != OBERON_CLASS_TYPE)
1982 {
1983 oberon_error(ctx, "mult definition");
1984 }
1985
1986 if(newtype -> linked)
1987 {
1988 oberon_error(ctx, "mult definition - already linked");
1989 }
1990
1991 newtype -> export = export;
1992 newtype -> read_only = read_only;
1993 }
1994
1995 oberon_assert_token(ctx, EQUAL);
1996
1997 type = newtype -> type;
1998 oberon_type(ctx, &type);
1999
2000 if(type -> class == OBERON_TYPE_VOID)
2001 {
2002 oberon_error(ctx, "recursive alias declaration");
2003 }
2004
2005 newtype -> type = type;
2006 newtype -> linked = 1;
2007 }
2008
2009 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2010 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2011
2012 static void
2013 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2014 {
2015 if(type -> class != OBERON_TYPE_POINTER
2016 && type -> class != OBERON_TYPE_ARRAY)
2017 {
2018 return;
2019 }
2020
2021 if(type -> recursive)
2022 {
2023 oberon_error(ctx, "recursive pointer declaration");
2024 }
2025
2026 if(type -> base -> class == OBERON_TYPE_POINTER)
2027 {
2028 oberon_error(ctx, "attempt to make pointer to pointer");
2029 }
2030
2031 type -> recursive = 1;
2032
2033 oberon_prevent_recursive_pointer(ctx, type -> base);
2034
2035 type -> recursive = 0;
2036 }
2037
2038 static void
2039 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2040 {
2041 if(type -> class != OBERON_TYPE_RECORD)
2042 {
2043 return;
2044 }
2045
2046 if(type -> recursive)
2047 {
2048 oberon_error(ctx, "recursive record declaration");
2049 }
2050
2051 type -> recursive = 1;
2052
2053 int num_fields = type -> num_decl;
2054 oberon_object_t * field = type -> decl;
2055 for(int i = 0; i < num_fields; i++)
2056 {
2057 oberon_prevent_recursive_object(ctx, field);
2058 field = field -> next;
2059 }
2060
2061 type -> recursive = 0;
2062 }
2063 static void
2064 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2065 {
2066 if(type -> class != OBERON_TYPE_PROCEDURE)
2067 {
2068 return;
2069 }
2070
2071 if(type -> recursive)
2072 {
2073 oberon_error(ctx, "recursive procedure declaration");
2074 }
2075
2076 type -> recursive = 1;
2077
2078 int num_fields = type -> num_decl;
2079 oberon_object_t * field = type -> decl;
2080 for(int i = 0; i < num_fields; i++)
2081 {
2082 oberon_prevent_recursive_object(ctx, field);
2083 field = field -> next;
2084 }
2085
2086 type -> recursive = 0;
2087 }
2088
2089 static void
2090 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2091 {
2092 if(type -> class != OBERON_TYPE_ARRAY)
2093 {
2094 return;
2095 }
2096
2097 if(type -> recursive)
2098 {
2099 oberon_error(ctx, "recursive array declaration");
2100 }
2101
2102 type -> recursive = 1;
2103
2104 oberon_prevent_recursive_type(ctx, type -> base);
2105
2106 type -> recursive = 0;
2107 }
2108
2109 static void
2110 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2111 {
2112 if(type -> class == OBERON_TYPE_POINTER)
2113 {
2114 oberon_prevent_recursive_pointer(ctx, type);
2115 }
2116 else if(type -> class == OBERON_TYPE_RECORD)
2117 {
2118 oberon_prevent_recursive_record(ctx, type);
2119 }
2120 else if(type -> class == OBERON_TYPE_ARRAY)
2121 {
2122 oberon_prevent_recursive_array(ctx, type);
2123 }
2124 else if(type -> class == OBERON_TYPE_PROCEDURE)
2125 {
2126 oberon_prevent_recursive_procedure(ctx, type);
2127 }
2128 }
2129
2130 static void
2131 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2132 {
2133 switch(x -> class)
2134 {
2135 case OBERON_CLASS_VAR:
2136 case OBERON_CLASS_TYPE:
2137 case OBERON_CLASS_PARAM:
2138 case OBERON_CLASS_VAR_PARAM:
2139 case OBERON_CLASS_FIELD:
2140 oberon_prevent_recursive_type(ctx, x -> type);
2141 break;
2142 case OBERON_CLASS_CONST:
2143 case OBERON_CLASS_PROC:
2144 case OBERON_CLASS_MODULE:
2145 break;
2146 default:
2147 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2148 break;
2149 }
2150 }
2151
2152 static void
2153 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2154 {
2155 oberon_object_t * x = ctx -> decl -> list -> next;
2156
2157 while(x)
2158 {
2159 oberon_prevent_recursive_object(ctx, x);
2160 x = x -> next;
2161 }
2162 }
2163
2164 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2165 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2166
2167 static void
2168 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2169 {
2170 if(type -> class != OBERON_TYPE_RECORD)
2171 {
2172 return;
2173 }
2174
2175 int num_fields = type -> num_decl;
2176 oberon_object_t * field = type -> decl;
2177 for(int i = 0; i < num_fields; i++)
2178 {
2179 if(field -> type -> class == OBERON_TYPE_POINTER)
2180 {
2181 oberon_initialize_type(ctx, field -> type);
2182 }
2183
2184 oberon_initialize_object(ctx, field);
2185 field = field -> next;
2186 }
2187
2188 oberon_generator_init_record(ctx, type);
2189 }
2190
2191 static void
2192 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2193 {
2194 if(type -> class == OBERON_TYPE_VOID)
2195 {
2196 oberon_error(ctx, "undeclarated type");
2197 }
2198
2199 if(type -> initialized)
2200 {
2201 return;
2202 }
2203
2204 type -> initialized = 1;
2205
2206 if(type -> class == OBERON_TYPE_POINTER)
2207 {
2208 oberon_initialize_type(ctx, type -> base);
2209 oberon_generator_init_type(ctx, type);
2210 }
2211 else if(type -> class == OBERON_TYPE_ARRAY)
2212 {
2213 oberon_initialize_type(ctx, type -> base);
2214 oberon_generator_init_type(ctx, type);
2215 }
2216 else if(type -> class == OBERON_TYPE_RECORD)
2217 {
2218 oberon_generator_init_type(ctx, type);
2219 oberon_initialize_record_fields(ctx, type);
2220 }
2221 else if(type -> class == OBERON_TYPE_PROCEDURE)
2222 {
2223 int num_fields = type -> num_decl;
2224 oberon_object_t * field = type -> decl;
2225 for(int i = 0; i < num_fields; i++)
2226 {
2227 oberon_initialize_object(ctx, field);
2228 field = field -> next;
2229 }
2230
2231 oberon_generator_init_type(ctx, type);
2232 }
2233 else
2234 {
2235 oberon_generator_init_type(ctx, type);
2236 }
2237 }
2238
2239 static void
2240 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2241 {
2242 if(x -> initialized)
2243 {
2244 return;
2245 }
2246
2247 x -> initialized = 1;
2248
2249 switch(x -> class)
2250 {
2251 case OBERON_CLASS_TYPE:
2252 oberon_initialize_type(ctx, x -> type);
2253 break;
2254 case OBERON_CLASS_VAR:
2255 case OBERON_CLASS_PARAM:
2256 case OBERON_CLASS_VAR_PARAM:
2257 case OBERON_CLASS_FIELD:
2258 oberon_initialize_type(ctx, x -> type);
2259 oberon_generator_init_var(ctx, x);
2260 break;
2261 case OBERON_CLASS_CONST:
2262 case OBERON_CLASS_PROC:
2263 case OBERON_CLASS_MODULE:
2264 break;
2265 default:
2266 oberon_error(ctx, "oberon_initialize_object: wat");
2267 break;
2268 }
2269 }
2270
2271 static void
2272 oberon_initialize_decl(oberon_context_t * ctx)
2273 {
2274 oberon_object_t * x = ctx -> decl -> list;
2275
2276 while(x -> next)
2277 {
2278 oberon_initialize_object(ctx, x -> next);
2279 x = x -> next;
2280 }
2281 }
2282
2283 static void
2284 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2285 {
2286 oberon_object_t * x = ctx -> decl -> list;
2287
2288 while(x -> next)
2289 {
2290 if(x -> next -> class == OBERON_CLASS_PROC)
2291 {
2292 if(x -> next -> linked == 0)
2293 {
2294 oberon_error(ctx, "unresolved forward declaration");
2295 }
2296 }
2297 x = x -> next;
2298 }
2299 }
2300
2301 static void
2302 oberon_decl_seq(oberon_context_t * ctx)
2303 {
2304 if(ctx -> token == CONST)
2305 {
2306 oberon_assert_token(ctx, CONST);
2307 while(ctx -> token == IDENT)
2308 {
2309 oberon_const_decl(ctx);
2310 oberon_assert_token(ctx, SEMICOLON);
2311 }
2312 }
2313
2314 if(ctx -> token == TYPE)
2315 {
2316 oberon_assert_token(ctx, TYPE);
2317 while(ctx -> token == IDENT)
2318 {
2319 oberon_type_decl(ctx);
2320 oberon_assert_token(ctx, SEMICOLON);
2321 }
2322 }
2323
2324 if(ctx -> token == VAR)
2325 {
2326 oberon_assert_token(ctx, VAR);
2327 while(ctx -> token == IDENT)
2328 {
2329 oberon_var_decl(ctx);
2330 oberon_assert_token(ctx, SEMICOLON);
2331 }
2332 }
2333
2334 oberon_prevent_recursive_decl(ctx);
2335 oberon_initialize_decl(ctx);
2336
2337 while(ctx -> token == PROCEDURE)
2338 {
2339 oberon_proc_decl(ctx);
2340 oberon_assert_token(ctx, SEMICOLON);
2341 }
2342
2343 oberon_prevent_undeclarated_procedures(ctx);
2344 }
2345
2346 static void
2347 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2348 {
2349 if(dst -> read_only)
2350 {
2351 oberon_error(ctx, "read-only destination");
2352 }
2353
2354 oberon_autocast_to(ctx, src, dst -> result);
2355 oberon_generate_assign(ctx, src, dst);
2356 }
2357
2358 static void
2359 oberon_statement(oberon_context_t * ctx)
2360 {
2361 oberon_expr_t * item1;
2362 oberon_expr_t * item2;
2363
2364 if(ctx -> token == IDENT)
2365 {
2366 item1 = oberon_designator(ctx);
2367 if(ctx -> token == ASSIGN)
2368 {
2369 oberon_assert_token(ctx, ASSIGN);
2370 item2 = oberon_expr(ctx);
2371 oberon_assign(ctx, item2, item1);
2372 }
2373 else
2374 {
2375 oberon_opt_proc_parens(ctx, item1);
2376 }
2377 }
2378 else if(ctx -> token == RETURN)
2379 {
2380 oberon_assert_token(ctx, RETURN);
2381 if(ISEXPR(ctx -> token))
2382 {
2383 oberon_expr_t * expr;
2384 expr = oberon_expr(ctx);
2385 oberon_make_return(ctx, expr);
2386 }
2387 else
2388 {
2389 oberon_make_return(ctx, NULL);
2390 }
2391 }
2392 }
2393
2394 static void
2395 oberon_statement_seq(oberon_context_t * ctx)
2396 {
2397 oberon_statement(ctx);
2398 while(ctx -> token == SEMICOLON)
2399 {
2400 oberon_assert_token(ctx, SEMICOLON);
2401 oberon_statement(ctx);
2402 }
2403 }
2404
2405 static void
2406 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
2407 {
2408 oberon_module_t * m = ctx -> module_list;
2409 while(m && strcmp(m -> name, name) != 0)
2410 {
2411 m = m -> next;
2412 }
2413
2414 if(m == NULL)
2415 {
2416 const char * code;
2417 code = ctx -> import_module(name);
2418 if(code == NULL)
2419 {
2420 oberon_error(ctx, "no such module");
2421 }
2422
2423 m = oberon_compile_module(ctx, code);
2424 assert(m);
2425 }
2426
2427 if(m -> ready == 0)
2428 {
2429 oberon_error(ctx, "cyclic module import");
2430 }
2431
2432 oberon_object_t * ident;
2433 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, 0, 0);
2434 ident -> module = m;
2435 }
2436
2437 static void
2438 oberon_import_decl(oberon_context_t * ctx)
2439 {
2440 char * alias;
2441 char * name;
2442
2443 alias = name = oberon_assert_ident(ctx);
2444 if(ctx -> token == ASSIGN)
2445 {
2446 oberon_assert_token(ctx, ASSIGN);
2447 name = oberon_assert_ident(ctx);
2448 }
2449
2450 oberon_import_module(ctx, alias, name);
2451 }
2452
2453 static void
2454 oberon_import_list(oberon_context_t * ctx)
2455 {
2456 oberon_assert_token(ctx, IMPORT);
2457
2458 oberon_import_decl(ctx);
2459 while(ctx -> token == COMMA)
2460 {
2461 oberon_assert_token(ctx, COMMA);
2462 oberon_import_decl(ctx);
2463 }
2464
2465 oberon_assert_token(ctx, SEMICOLON);
2466 }
2467
2468 static void
2469 oberon_parse_module(oberon_context_t * ctx)
2470 {
2471 char * name1;
2472 char * name2;
2473 oberon_read_token(ctx);
2474
2475 oberon_assert_token(ctx, MODULE);
2476 name1 = oberon_assert_ident(ctx);
2477 oberon_assert_token(ctx, SEMICOLON);
2478 ctx -> mod -> name = name1;
2479
2480 if(ctx -> token == IMPORT)
2481 {
2482 oberon_import_list(ctx);
2483 }
2484
2485 oberon_decl_seq(ctx);
2486
2487 oberon_generate_begin_module(ctx);
2488 if(ctx -> token == BEGIN)
2489 {
2490 oberon_assert_token(ctx, BEGIN);
2491 oberon_statement_seq(ctx);
2492 }
2493 oberon_generate_end_module(ctx);
2494
2495 oberon_assert_token(ctx, END);
2496 name2 = oberon_assert_ident(ctx);
2497 oberon_assert_token(ctx, DOT);
2498
2499 if(strcmp(name1, name2) != 0)
2500 {
2501 oberon_error(ctx, "module name not matched");
2502 }
2503 }
2504
2505 // =======================================================================
2506 // LIBRARY
2507 // =======================================================================
2508
2509 static void
2510 register_default_types(oberon_context_t * ctx)
2511 {
2512 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2513 oberon_generator_init_type(ctx, ctx -> void_type);
2514
2515 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
2516 ctx -> void_ptr_type -> base = ctx -> void_type;
2517 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
2518
2519 ctx -> int_type = oberon_new_type_integer(sizeof(int));
2520 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
2521
2522 ctx -> bool_type = oberon_new_type_boolean(sizeof(int));
2523 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
2524 }
2525
2526 static void
2527 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
2528 {
2529 oberon_object_t * proc;
2530 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, 1, 0);
2531 proc -> sysproc = 1;
2532 proc -> genfunc = f;
2533 proc -> genproc = p;
2534 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
2535 }
2536
2537 static oberon_expr_t *
2538 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2539 {
2540 if(num_args < 1)
2541 {
2542 oberon_error(ctx, "too few arguments");
2543 }
2544
2545 if(num_args > 1)
2546 {
2547 oberon_error(ctx, "too mach arguments");
2548 }
2549
2550 oberon_expr_t * arg;
2551 arg = list_args;
2552
2553 oberon_type_t * result_type;
2554 result_type = arg -> result;
2555
2556 if(result_type -> class != OBERON_TYPE_INTEGER)
2557 {
2558 oberon_error(ctx, "ABS accepts only integers");
2559 }
2560
2561
2562 oberon_expr_t * expr;
2563 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
2564 return expr;
2565 }
2566
2567 oberon_context_t *
2568 oberon_create_context(ModuleImportCallback import_module)
2569 {
2570 oberon_context_t * ctx = calloc(1, sizeof *ctx);
2571
2572 oberon_scope_t * world_scope;
2573 world_scope = oberon_open_scope(ctx);
2574 ctx -> world_scope = world_scope;
2575
2576 ctx -> import_module = import_module;
2577
2578 oberon_generator_init_context(ctx);
2579
2580 register_default_types(ctx);
2581 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
2582
2583 return ctx;
2584 }
2585
2586 void
2587 oberon_destroy_context(oberon_context_t * ctx)
2588 {
2589 oberon_generator_destroy_context(ctx);
2590 free(ctx);
2591 }
2592
2593 oberon_module_t *
2594 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
2595 {
2596 const char * code = ctx -> code;
2597 int code_index = ctx -> code_index;
2598 char c = ctx -> c;
2599 int token = ctx -> token;
2600 char * string = ctx -> string;
2601 int integer = ctx -> integer;
2602 oberon_scope_t * decl = ctx -> decl;
2603 oberon_module_t * mod = ctx -> mod;
2604
2605 oberon_scope_t * module_scope;
2606 module_scope = oberon_open_scope(ctx);
2607
2608 oberon_module_t * module;
2609 module = calloc(1, sizeof *module);
2610 module -> decl = module_scope;
2611 module -> next = ctx -> module_list;
2612
2613 ctx -> mod = module;
2614 ctx -> module_list = module;
2615
2616 oberon_init_scaner(ctx, newcode);
2617 oberon_parse_module(ctx);
2618
2619 module -> ready = 1;
2620
2621 ctx -> code = code;
2622 ctx -> code_index = code_index;
2623 ctx -> c = c;
2624 ctx -> token = token;
2625 ctx -> string = string;
2626 ctx -> integer = integer;
2627 ctx -> decl = decl;
2628 ctx -> mod = mod;
2629
2630 return module;
2631 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024