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