DEADSOFTWARE

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


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