DEADSOFTWARE

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