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 #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(desig -> result -> size != 0)
1028 {
1029 if(index -> is_item)
1030 {
1031 if(index -> item.mode == MODE_INTEGER)
1032 {
1033 int arr_size = desig -> result -> size;
1034 int index_int = index -> item.integer;
1035 if(index_int < 0 || index_int > arr_size - 1)
1036 {
1037 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
1038 }
1039 }
1040 }
1041 }
1042
1043 oberon_expr_t * selector;
1044 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
1045 selector -> item.parent = (oberon_item_t *) desig;
1046 selector -> item.num_args = 1;
1047 selector -> item.args = index;
1048
1049 return selector;
1050 }
1051
1052 static oberon_expr_t *
1053 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
1054 {
1055 if(expr -> result -> class == OBERON_TYPE_POINTER)
1056 {
1057 expr = oberno_make_dereferencing(ctx, expr);
1058 }
1059
1060 assert(expr -> is_item == 1);
1061
1062 if(expr -> result -> class != OBERON_TYPE_RECORD)
1063 {
1064 oberon_error(ctx, "not record");
1065 }
1066
1067 oberon_type_t * rec = expr -> result;
1068
1069 oberon_object_t * field;
1070 field = oberon_find_field(ctx, rec, name);
1071
1072 if(field -> export == 0)
1073 {
1074 if(field -> module != ctx -> mod)
1075 {
1076 oberon_error(ctx, "field not exported");
1077 }
1078 }
1079
1080 int read_only = 0;
1081 if(field -> read_only)
1082 {
1083 if(field -> module != ctx -> mod)
1084 {
1085 read_only = 1;
1086 }
1087 }
1088
1089 oberon_expr_t * selector;
1090 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
1091 selector -> item.var = field;
1092 selector -> item.parent = (oberon_item_t *) expr;
1093
1094 return selector;
1095 }
1096
1097 #define ISSELECTOR(x) \
1098 (((x) == LBRACE) \
1099 || ((x) == DOT) \
1100 || ((x) == UPARROW))
1101
1102 static oberon_object_t *
1103 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1104 {
1105 char * name;
1106 oberon_object_t * x;
1107
1108 name = oberon_assert_ident(ctx);
1109 x = oberon_find_object(ctx -> decl, name, check);
1110
1111 if(x != NULL)
1112 {
1113 if(x -> class == OBERON_CLASS_MODULE)
1114 {
1115 oberon_assert_token(ctx, DOT);
1116 name = oberon_assert_ident(ctx);
1117 /* Наличие объектов в левых модулях всегда проверяется */
1118 x = oberon_find_object(x -> module -> decl, name, 1);
1119
1120 if(x -> export == 0)
1121 {
1122 oberon_error(ctx, "not exported");
1123 }
1124 }
1125 }
1126
1127 if(xname)
1128 {
1129 *xname = name;
1130 }
1131
1132 return x;
1133 }
1134
1135 static oberon_expr_t *
1136 oberon_designator(oberon_context_t * ctx)
1137 {
1138 char * name;
1139 oberon_object_t * var;
1140 oberon_expr_t * expr;
1141
1142 var = oberon_qualident(ctx, NULL, 1);
1143
1144 int read_only = 0;
1145 if(var -> read_only)
1146 {
1147 if(var -> module != ctx -> mod)
1148 {
1149 read_only = 1;
1150 }
1151 }
1152
1153 switch(var -> class)
1154 {
1155 case OBERON_CLASS_CONST:
1156 // TODO copy value
1157 expr = (oberon_expr_t *) var -> value;
1158 break;
1159 case OBERON_CLASS_VAR:
1160 case OBERON_CLASS_VAR_PARAM:
1161 case OBERON_CLASS_PARAM:
1162 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1163 break;
1164 case OBERON_CLASS_PROC:
1165 expr = oberon_new_item(MODE_VAR, var -> type, 1);
1166 break;
1167 default:
1168 oberon_error(ctx, "invalid designator");
1169 break;
1170 }
1171 expr -> item.var = var;
1172
1173 while(ISSELECTOR(ctx -> token))
1174 {
1175 switch(ctx -> token)
1176 {
1177 case DOT:
1178 oberon_assert_token(ctx, DOT);
1179 name = oberon_assert_ident(ctx);
1180 expr = oberon_make_record_selector(ctx, expr, name);
1181 break;
1182 case LBRACE:
1183 oberon_assert_token(ctx, LBRACE);
1184 int num_indexes = 0;
1185 oberon_expr_t * indexes = NULL;
1186 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1187 oberon_assert_token(ctx, RBRACE);
1188
1189 for(int i = 0; i < num_indexes; i++)
1190 {
1191 expr = oberon_make_array_selector(ctx, expr, indexes);
1192 indexes = indexes -> next;
1193 }
1194 break;
1195 case UPARROW:
1196 oberon_assert_token(ctx, UPARROW);
1197 expr = oberno_make_dereferencing(ctx, expr);
1198 break;
1199 default:
1200 oberon_error(ctx, "oberon_designator: wat");
1201 break;
1202 }
1203 }
1204 return expr;
1205 }
1206
1207 static oberon_expr_t *
1208 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1209 {
1210 assert(expr -> is_item == 1);
1211
1212 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1213 if(ctx -> token == LPAREN)
1214 {
1215 oberon_assert_token(ctx, LPAREN);
1216
1217 int num_args = 0;
1218 oberon_expr_t * arguments = NULL;
1219
1220 if(ISEXPR(ctx -> token))
1221 {
1222 oberon_expr_list(ctx, &num_args, &arguments, 0);
1223 }
1224
1225 expr = oberon_make_call_func(ctx, expr -> item.var, num_args, arguments);
1226
1227 oberon_assert_token(ctx, RPAREN);
1228 }
1229
1230 return expr;
1231 }
1232
1233 static void
1234 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1235 {
1236 assert(expr -> is_item == 1);
1237
1238 int num_args = 0;
1239 oberon_expr_t * arguments = NULL;
1240
1241 if(ctx -> token == LPAREN)
1242 {
1243 oberon_assert_token(ctx, LPAREN);
1244
1245 if(ISEXPR(ctx -> token))
1246 {
1247 oberon_expr_list(ctx, &num_args, &arguments, 0);
1248 }
1249
1250 oberon_assert_token(ctx, RPAREN);
1251 }
1252
1253 /* Вызов происходит даже без скобок */
1254 oberon_make_call_proc(ctx, expr -> item.var, num_args, arguments);
1255 }
1256
1257 static oberon_expr_t *
1258 oberon_factor(oberon_context_t * ctx)
1259 {
1260 oberon_expr_t * expr;
1261
1262 switch(ctx -> token)
1263 {
1264 case IDENT:
1265 expr = oberon_designator(ctx);
1266 expr = oberon_opt_func_parens(ctx, expr);
1267 break;
1268 case INTEGER:
1269 expr = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
1270 expr -> item.integer = ctx -> integer;
1271 oberon_assert_token(ctx, INTEGER);
1272 break;
1273 case REAL:
1274 expr = oberon_new_item(MODE_REAL, ctx -> real_type, 1);
1275 expr -> item.real = ctx -> real;
1276 oberon_assert_token(ctx, REAL);
1277 break;
1278 case TRUE:
1279 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1280 expr -> item.boolean = 1;
1281 oberon_assert_token(ctx, TRUE);
1282 break;
1283 case FALSE:
1284 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, 1);
1285 expr -> item.boolean = 0;
1286 oberon_assert_token(ctx, FALSE);
1287 break;
1288 case LPAREN:
1289 oberon_assert_token(ctx, LPAREN);
1290 expr = oberon_expr(ctx);
1291 oberon_assert_token(ctx, RPAREN);
1292 break;
1293 case NOT:
1294 oberon_assert_token(ctx, NOT);
1295 expr = oberon_factor(ctx);
1296 expr = oberon_make_unary_op(ctx, NOT, expr);
1297 break;
1298 case NIL:
1299 oberon_assert_token(ctx, NIL);
1300 expr = oberon_new_item(MODE_NIL, ctx -> void_ptr_type, 1);
1301 break;
1302 default:
1303 oberon_error(ctx, "invalid expression");
1304 }
1305
1306 return expr;
1307 }
1308
1309 /*
1310 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1311 * 1. Классы обоих типов должны быть одинаковы
1312 * 2. В качестве результата должен быть выбран больший тип.
1313 * 3. Если размер результат не должен быть меньше чем базовый int
1314 */
1315
1316 static void
1317 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b, oberon_type_t ** result)
1318 {
1319 if((a -> class) != (b -> class))
1320 {
1321 oberon_error(ctx, "incompatible types");
1322 }
1323
1324 if((a -> size) > (b -> size))
1325 {
1326 *result = a;
1327 }
1328 else
1329 {
1330 *result = b;
1331 }
1332
1333 if(((*result) -> class) == OBERON_TYPE_INTEGER)
1334 {
1335 if(((*result) -> size) < (ctx -> int_type -> size))
1336 {
1337 *result = ctx -> int_type;
1338 }
1339 }
1340
1341 /* TODO: cast types */
1342 }
1343
1344 #define ITMAKESBOOLEAN(x) \
1345 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1346
1347 #define ITUSEONLYINTEGER(x) \
1348 ((x) >= LESS && (x) <= GEQ)
1349
1350 #define ITUSEONLYBOOLEAN(x) \
1351 (((x) == OR) || ((x) == AND))
1352
1353 static oberon_expr_t *
1354 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1355 {
1356 oberon_expr_t * expr;
1357 oberon_type_t * result;
1358
1359 if(ITMAKESBOOLEAN(token))
1360 {
1361 if(ITUSEONLYINTEGER(token))
1362 {
1363 if(a -> result -> class != OBERON_TYPE_INTEGER
1364 || b -> result -> class != OBERON_TYPE_INTEGER)
1365 {
1366 oberon_error(ctx, "used only with integer types");
1367 }
1368 }
1369 else if(ITUSEONLYBOOLEAN(token))
1370 {
1371 if(a -> result -> class != OBERON_TYPE_BOOLEAN
1372 || b -> result -> class != OBERON_TYPE_BOOLEAN)
1373 {
1374 oberon_error(ctx, "used only with boolean type");
1375 }
1376 }
1377
1378 result = ctx -> bool_type;
1379
1380 if(token == EQUAL)
1381 {
1382 expr = oberon_new_operator(OP_EQ, result, a, b);
1383 }
1384 else if(token == NEQ)
1385 {
1386 expr = oberon_new_operator(OP_NEQ, result, a, b);
1387 }
1388 else if(token == LESS)
1389 {
1390 expr = oberon_new_operator(OP_LSS, result, a, b);
1391 }
1392 else if(token == LEQ)
1393 {
1394 expr = oberon_new_operator(OP_LEQ, result, a, b);
1395 }
1396 else if(token == GREAT)
1397 {
1398 expr = oberon_new_operator(OP_GRT, result, a, b);
1399 }
1400 else if(token == GEQ)
1401 {
1402 expr = oberon_new_operator(OP_GEQ, result, a, b);
1403 }
1404 else if(token == OR)
1405 {
1406 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
1407 }
1408 else if(token == AND)
1409 {
1410 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
1411 }
1412 else
1413 {
1414 oberon_error(ctx, "oberon_make_bin_op: bool wat");
1415 }
1416 }
1417 else if(token == SLASH)
1418 {
1419 if(a -> result -> class != OBERON_TYPE_REAL)
1420 {
1421 if(a -> result -> class == OBERON_TYPE_INTEGER)
1422 {
1423 oberon_error(ctx, "TODO cast int -> real");
1424 }
1425 else
1426 {
1427 oberon_error(ctx, "operator / requires numeric type");
1428 }
1429 }
1430
1431 if(b -> result -> class != OBERON_TYPE_REAL)
1432 {
1433 if(b -> result -> class == OBERON_TYPE_INTEGER)
1434 {
1435 oberon_error(ctx, "TODO cast int -> real");
1436 }
1437 else
1438 {
1439 oberon_error(ctx, "operator / requires numeric type");
1440 }
1441 }
1442
1443 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1444 expr = oberon_new_operator(OP_DIV, result, a, b);
1445 }
1446 else if(token == DIV)
1447 {
1448 if(a -> result -> class != OBERON_TYPE_INTEGER
1449 || b -> result -> class != OBERON_TYPE_INTEGER)
1450 {
1451 oberon_error(ctx, "operator DIV requires integer type");
1452 }
1453
1454 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1455 expr = oberon_new_operator(OP_DIV, result, a, b);
1456 }
1457 else
1458 {
1459 oberon_autocast_binary_op(ctx, a -> result, b -> result, &result);
1460
1461 if(token == PLUS)
1462 {
1463 expr = oberon_new_operator(OP_ADD, result, a, b);
1464 }
1465 else if(token == MINUS)
1466 {
1467 expr = oberon_new_operator(OP_SUB, result, a, b);
1468 }
1469 else if(token == STAR)
1470 {
1471 expr = oberon_new_operator(OP_MUL, result, a, b);
1472 }
1473 else if(token == MOD)
1474 {
1475 expr = oberon_new_operator(OP_MOD, result, a, b);
1476 }
1477 else
1478 {
1479 oberon_error(ctx, "oberon_make_bin_op: bin wat");
1480 }
1481 }
1482
1483 return expr;
1484 }
1485
1486 #define ISMULOP(x) \
1487 ((x) >= STAR && (x) <= AND)
1488
1489 static oberon_expr_t *
1490 oberon_term_expr(oberon_context_t * ctx)
1491 {
1492 oberon_expr_t * expr;
1493
1494 expr = oberon_factor(ctx);
1495 while(ISMULOP(ctx -> token))
1496 {
1497 int token = ctx -> token;
1498 oberon_read_token(ctx);
1499
1500 oberon_expr_t * inter = oberon_factor(ctx);
1501 expr = oberon_make_bin_op(ctx, token, expr, inter);
1502 }
1503
1504 return expr;
1505 }
1506
1507 #define ISADDOP(x) \
1508 ((x) >= PLUS && (x) <= OR)
1509
1510 static oberon_expr_t *
1511 oberon_simple_expr(oberon_context_t * ctx)
1512 {
1513 oberon_expr_t * expr;
1514
1515 int minus = 0;
1516 if(ctx -> token == PLUS)
1517 {
1518 minus = 0;
1519 oberon_assert_token(ctx, PLUS);
1520 }
1521 else if(ctx -> token == MINUS)
1522 {
1523 minus = 1;
1524 oberon_assert_token(ctx, MINUS);
1525 }
1526
1527 expr = oberon_term_expr(ctx);
1528 while(ISADDOP(ctx -> token))
1529 {
1530 int token = ctx -> token;
1531 oberon_read_token(ctx);
1532
1533 oberon_expr_t * inter = oberon_term_expr(ctx);
1534 expr = oberon_make_bin_op(ctx, token, expr, inter);
1535 }
1536
1537 if(minus)
1538 {
1539 expr = oberon_make_unary_op(ctx, MINUS, expr);
1540 }
1541
1542 return expr;
1543 }
1544
1545 #define ISRELATION(x) \
1546 ((x) >= EQUAL && (x) <= GEQ)
1547
1548 static oberon_expr_t *
1549 oberon_expr(oberon_context_t * ctx)
1550 {
1551 oberon_expr_t * expr;
1552
1553 expr = oberon_simple_expr(ctx);
1554 while(ISRELATION(ctx -> token))
1555 {
1556 int token = ctx -> token;
1557 oberon_read_token(ctx);
1558
1559 oberon_expr_t * inter = oberon_simple_expr(ctx);
1560 expr = oberon_make_bin_op(ctx, token, expr, inter);
1561 }
1562
1563 return expr;
1564 }
1565
1566 static oberon_item_t *
1567 oberon_const_expr(oberon_context_t * ctx)
1568 {
1569 oberon_expr_t * expr;
1570 expr = oberon_expr(ctx);
1571
1572 if(expr -> is_item == 0)
1573 {
1574 oberon_error(ctx, "const expression are required");
1575 }
1576
1577 return (oberon_item_t *) expr;
1578 }
1579
1580 // =======================================================================
1581 // PARSER
1582 // =======================================================================
1583
1584 static void oberon_decl_seq(oberon_context_t * ctx);
1585 static void oberon_statement_seq(oberon_context_t * ctx);
1586 static void oberon_initialize_decl(oberon_context_t * ctx);
1587
1588 static void
1589 oberon_expect_token(oberon_context_t * ctx, int token)
1590 {
1591 if(ctx -> token != token)
1592 {
1593 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
1594 }
1595 }
1596
1597 static void
1598 oberon_assert_token(oberon_context_t * ctx, int token)
1599 {
1600 oberon_expect_token(ctx, token);
1601 oberon_read_token(ctx);
1602 }
1603
1604 static char *
1605 oberon_assert_ident(oberon_context_t * ctx)
1606 {
1607 oberon_expect_token(ctx, IDENT);
1608 char * ident = ctx -> string;
1609 oberon_read_token(ctx);
1610 return ident;
1611 }
1612
1613 static void
1614 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
1615 {
1616 switch(ctx -> token)
1617 {
1618 case STAR:
1619 oberon_assert_token(ctx, STAR);
1620 *export = 1;
1621 *read_only = 0;
1622 break;
1623 case MINUS:
1624 oberon_assert_token(ctx, MINUS);
1625 *export = 1;
1626 *read_only = 1;
1627 break;
1628 default:
1629 *export = 0;
1630 *read_only = 0;
1631 break;
1632 }
1633 }
1634
1635 static oberon_object_t *
1636 oberon_ident_def(oberon_context_t * ctx, int class)
1637 {
1638 char * name;
1639 int export;
1640 int read_only;
1641 oberon_object_t * x;
1642
1643 name = oberon_assert_ident(ctx);
1644 oberon_def(ctx, &export, &read_only);
1645
1646 x = oberon_define_object(ctx -> decl, name, class, export, read_only);
1647 return x;
1648 }
1649
1650 static void
1651 oberon_ident_list(oberon_context_t * ctx, int class, int * num, oberon_object_t ** list)
1652 {
1653 *num = 1;
1654 *list = oberon_ident_def(ctx, class);
1655 while(ctx -> token == COMMA)
1656 {
1657 oberon_assert_token(ctx, COMMA);
1658 oberon_ident_def(ctx, class);
1659 *num += 1;
1660 }
1661 }
1662
1663 static void
1664 oberon_var_decl(oberon_context_t * ctx)
1665 {
1666 int num;
1667 oberon_object_t * list;
1668 oberon_type_t * type;
1669 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1670
1671 oberon_ident_list(ctx, OBERON_CLASS_VAR, &num, &list);
1672 oberon_assert_token(ctx, COLON);
1673 oberon_type(ctx, &type);
1674
1675 oberon_object_t * var = list;
1676 for(int i = 0; i < num; i++)
1677 {
1678 var -> type = type;
1679 var = var -> next;
1680 }
1681 }
1682
1683 static oberon_object_t *
1684 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
1685 {
1686 int class = OBERON_CLASS_PARAM;
1687 if(ctx -> token == VAR)
1688 {
1689 oberon_read_token(ctx);
1690 class = OBERON_CLASS_VAR_PARAM;
1691 }
1692
1693 int num;
1694 oberon_object_t * list;
1695 oberon_ident_list(ctx, class, &num, &list);
1696
1697 oberon_assert_token(ctx, COLON);
1698
1699 oberon_type_t * type;
1700 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1701 oberon_type(ctx, &type);
1702
1703 oberon_object_t * param = list;
1704 for(int i = 0; i < num; i++)
1705 {
1706 param -> type = type;
1707 param = param -> next;
1708 }
1709
1710 *num_decl += num;
1711 return list;
1712 }
1713
1714 #define ISFPSECTION \
1715 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1716
1717 static void
1718 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
1719 {
1720 oberon_assert_token(ctx, LPAREN);
1721
1722 if(ISFPSECTION)
1723 {
1724 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
1725 while(ctx -> token == SEMICOLON)
1726 {
1727 oberon_assert_token(ctx, SEMICOLON);
1728 oberon_fp_section(ctx, &signature -> num_decl);
1729 }
1730 }
1731
1732 oberon_assert_token(ctx, RPAREN);
1733
1734 if(ctx -> token == COLON)
1735 {
1736 oberon_assert_token(ctx, COLON);
1737
1738 oberon_object_t * typeobj;
1739 typeobj = oberon_qualident(ctx, NULL, 1);
1740 if(typeobj -> class != OBERON_CLASS_TYPE)
1741 {
1742 oberon_error(ctx, "function result is not type");
1743 }
1744 signature -> base = typeobj -> type;
1745 }
1746 }
1747
1748 static void
1749 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
1750 {
1751 oberon_type_t * signature;
1752 signature = *type;
1753 signature -> class = OBERON_TYPE_PROCEDURE;
1754 signature -> num_decl = 0;
1755 signature -> base = ctx -> void_type;
1756 signature -> decl = NULL;
1757
1758 if(ctx -> token == LPAREN)
1759 {
1760 oberon_formal_pars(ctx, signature);
1761 }
1762 }
1763
1764 static void
1765 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1766 {
1767 if(a -> num_decl != b -> num_decl)
1768 {
1769 oberon_error(ctx, "number parameters not matched");
1770 }
1771
1772 int num_param = a -> num_decl;
1773 oberon_object_t * param_a = a -> decl;
1774 oberon_object_t * param_b = b -> decl;
1775 for(int i = 0; i < num_param; i++)
1776 {
1777 if(strcmp(param_a -> name, param_b -> name) != 0)
1778 {
1779 oberon_error(ctx, "param %i name not matched", i + 1);
1780 }
1781
1782 if(param_a -> type != param_b -> type)
1783 {
1784 oberon_error(ctx, "param %i type not matched", i + 1);
1785 }
1786
1787 param_a = param_a -> next;
1788 param_b = param_b -> next;
1789 }
1790 }
1791
1792 static void
1793 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
1794 {
1795 oberon_object_t * proc = ctx -> decl -> parent;
1796 oberon_type_t * result_type = proc -> type -> base;
1797
1798 if(result_type -> class == OBERON_TYPE_VOID)
1799 {
1800 if(expr != NULL)
1801 {
1802 oberon_error(ctx, "procedure has no result type");
1803 }
1804 }
1805 else
1806 {
1807 if(expr == NULL)
1808 {
1809 oberon_error(ctx, "procedure requires expression on result");
1810 }
1811
1812 oberon_autocast_to(ctx, expr, result_type);
1813 }
1814
1815 proc -> has_return = 1;
1816
1817 oberon_generate_return(ctx, expr);
1818 }
1819
1820 static void
1821 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
1822 {
1823 oberon_assert_token(ctx, SEMICOLON);
1824
1825 ctx -> decl = proc -> scope;
1826
1827 oberon_decl_seq(ctx);
1828
1829 oberon_generate_begin_proc(ctx, proc);
1830
1831 if(ctx -> token == BEGIN)
1832 {
1833 oberon_assert_token(ctx, BEGIN);
1834 oberon_statement_seq(ctx);
1835 }
1836
1837 oberon_assert_token(ctx, END);
1838 char * name = oberon_assert_ident(ctx);
1839 if(strcmp(name, proc -> name) != 0)
1840 {
1841 oberon_error(ctx, "procedure name not matched");
1842 }
1843
1844 if(proc -> type -> base -> class == OBERON_TYPE_VOID
1845 && proc -> has_return == 0)
1846 {
1847 oberon_make_return(ctx, NULL);
1848 }
1849
1850 if(proc -> has_return == 0)
1851 {
1852 oberon_error(ctx, "procedure requires return");
1853 }
1854
1855 oberon_generate_end_proc(ctx);
1856 oberon_close_scope(ctx -> decl);
1857 }
1858
1859 static void
1860 oberon_proc_decl(oberon_context_t * ctx)
1861 {
1862 oberon_assert_token(ctx, PROCEDURE);
1863
1864 int forward = 0;
1865 if(ctx -> token == UPARROW)
1866 {
1867 oberon_assert_token(ctx, UPARROW);
1868 forward = 1;
1869 }
1870
1871 char * name;
1872 int export;
1873 int read_only;
1874 name = oberon_assert_ident(ctx);
1875 oberon_def(ctx, &export, &read_only);
1876
1877 oberon_scope_t * proc_scope;
1878 proc_scope = oberon_open_scope(ctx);
1879 ctx -> decl -> local = 1;
1880
1881 oberon_type_t * signature;
1882 signature = oberon_new_type_ptr(OBERON_TYPE_VOID);
1883 oberon_opt_formal_pars(ctx, &signature);
1884
1885 oberon_initialize_decl(ctx);
1886 oberon_generator_init_type(ctx, signature);
1887 oberon_close_scope(ctx -> decl);
1888
1889 oberon_object_t * proc;
1890 proc = oberon_find_object(ctx -> decl, name, 0);
1891 if(proc != NULL)
1892 {
1893 if(proc -> class != OBERON_CLASS_PROC)
1894 {
1895 oberon_error(ctx, "mult definition");
1896 }
1897
1898 if(forward == 0)
1899 {
1900 if(proc -> linked)
1901 {
1902 oberon_error(ctx, "mult procedure definition");
1903 }
1904 }
1905
1906 if(proc -> export != export || proc -> read_only != read_only)
1907 {
1908 oberon_error(ctx, "export type not matched");
1909 }
1910
1911 oberon_compare_signatures(ctx, proc -> type, signature);
1912 }
1913 else
1914 {
1915 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only);
1916 proc -> type = signature;
1917 proc -> scope = proc_scope;
1918 oberon_generator_init_proc(ctx, proc);
1919 }
1920
1921 proc -> scope -> parent = proc;
1922
1923 if(forward == 0)
1924 {
1925 proc -> linked = 1;
1926 oberon_proc_decl_body(ctx, proc);
1927 }
1928 }
1929
1930 static void
1931 oberon_const_decl(oberon_context_t * ctx)
1932 {
1933 oberon_item_t * value;
1934 oberon_object_t * constant;
1935
1936 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST);
1937 oberon_assert_token(ctx, EQUAL);
1938 value = oberon_const_expr(ctx);
1939 constant -> value = value;
1940 }
1941
1942 static void
1943 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
1944 {
1945 if(size -> is_item == 0)
1946 {
1947 oberon_error(ctx, "requires constant");
1948 }
1949
1950 if(size -> item.mode != MODE_INTEGER)
1951 {
1952 oberon_error(ctx, "requires integer constant");
1953 }
1954
1955 oberon_type_t * arr;
1956 arr = *type;
1957 arr -> class = OBERON_TYPE_ARRAY;
1958 arr -> size = size -> item.integer;
1959 arr -> base = base;
1960 }
1961
1962 static void
1963 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec)
1964 {
1965 if(ctx -> token == IDENT)
1966 {
1967 int num;
1968 oberon_object_t * list;
1969 oberon_type_t * type;
1970 type = oberon_new_type_ptr(OBERON_TYPE_VOID);
1971
1972 oberon_ident_list(ctx, OBERON_CLASS_FIELD, &num, &list);
1973 oberon_assert_token(ctx, COLON);
1974 oberon_type(ctx, &type);
1975
1976 oberon_object_t * field = list;
1977 for(int i = 0; i < num; i++)
1978 {
1979 field -> type = type;
1980 field = field -> next;
1981 }
1982
1983 rec -> num_decl += num;
1984 }
1985 }
1986
1987 static void
1988 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
1989 {
1990 char * name;
1991 oberon_object_t * to;
1992
1993 to = oberon_qualident(ctx, &name, 0);
1994
1995 //name = oberon_assert_ident(ctx);
1996 //to = oberon_find_object(ctx -> decl, name, 0);
1997
1998 if(to != NULL)
1999 {
2000 if(to -> class != OBERON_CLASS_TYPE)
2001 {
2002 oberon_error(ctx, "not a type");
2003 }
2004 }
2005 else
2006 {
2007 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, 0, 0);
2008 to -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2009 }
2010
2011 *type = to -> type;
2012 }
2013
2014 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2015
2016 /*
2017 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2018 */
2019
2020 static void
2021 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2022 {
2023 if(sizes == NULL)
2024 {
2025 *type = base;
2026 return;
2027 }
2028
2029 oberon_type_t * dim;
2030 dim = oberon_new_type_ptr(OBERON_TYPE_VOID);
2031
2032 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2033
2034 oberon_make_array_type(ctx, sizes, dim, type);
2035 }
2036
2037 static void
2038 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2039 {
2040 type -> class = OBERON_TYPE_ARRAY;
2041 type -> size = 0;
2042 type -> base = base;
2043 }
2044
2045 static void
2046 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2047 {
2048 if(ctx -> token == IDENT)
2049 {
2050 oberon_qualident_type(ctx, type);
2051 }
2052 else if(ctx -> token == ARRAY)
2053 {
2054 oberon_assert_token(ctx, ARRAY);
2055
2056 int num_sizes = 0;
2057 oberon_expr_t * sizes;
2058
2059 if(ISEXPR(ctx -> token))
2060 {
2061 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2062 }
2063
2064 oberon_assert_token(ctx, OF);
2065
2066 oberon_type_t * base;
2067 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2068 oberon_type(ctx, &base);
2069
2070 if(num_sizes == 0)
2071 {
2072 oberon_make_open_array(ctx, base, *type);
2073 }
2074 else
2075 {
2076 oberon_make_multiarray(ctx, sizes, base, type);
2077 }
2078 }
2079 else if(ctx -> token == RECORD)
2080 {
2081 oberon_type_t * rec;
2082 rec = *type;
2083 rec -> class = OBERON_TYPE_RECORD;
2084
2085 oberon_scope_t * record_scope;
2086 record_scope = oberon_open_scope(ctx);
2087 // TODO parent object
2088 //record_scope -> parent = NULL;
2089 record_scope -> local = 1;
2090
2091 oberon_assert_token(ctx, RECORD);
2092 oberon_field_list(ctx, rec);
2093 while(ctx -> token == SEMICOLON)
2094 {
2095 oberon_assert_token(ctx, SEMICOLON);
2096 oberon_field_list(ctx, rec);
2097 }
2098 oberon_assert_token(ctx, END);
2099
2100 rec -> decl = record_scope -> list -> next;
2101 oberon_close_scope(record_scope);
2102
2103 *type = rec;
2104 }
2105 else if(ctx -> token == POINTER)
2106 {
2107 oberon_assert_token(ctx, POINTER);
2108 oberon_assert_token(ctx, TO);
2109
2110 oberon_type_t * base;
2111 base = oberon_new_type_ptr(OBERON_TYPE_VOID);
2112 oberon_type(ctx, &base);
2113
2114 oberon_type_t * ptr;
2115 ptr = *type;
2116 ptr -> class = OBERON_TYPE_POINTER;
2117 ptr -> base = base;
2118 }
2119 else if(ctx -> token == PROCEDURE)
2120 {
2121 oberon_open_scope(ctx);
2122 oberon_assert_token(ctx, PROCEDURE);
2123 oberon_opt_formal_pars(ctx, type);
2124 oberon_close_scope(ctx -> decl);
2125 }
2126 else
2127 {
2128 oberon_error(ctx, "invalid type declaration");
2129 }
2130 }
2131
2132 static void
2133 oberon_type_decl(oberon_context_t * ctx)
2134 {
2135 char * name;
2136 oberon_object_t * newtype;
2137 oberon_type_t * type;
2138 int export;
2139 int read_only;
2140
2141 name = oberon_assert_ident(ctx);
2142 oberon_def(ctx, &export, &read_only);
2143
2144 newtype = oberon_find_object(ctx -> decl, name, 0);
2145 if(newtype == NULL)
2146 {
2147 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only);
2148 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2149 assert(newtype -> type);
2150 }
2151 else
2152 {
2153 if(newtype -> class != OBERON_CLASS_TYPE)
2154 {
2155 oberon_error(ctx, "mult definition");
2156 }
2157
2158 if(newtype -> linked)
2159 {
2160 oberon_error(ctx, "mult definition - already linked");
2161 }
2162
2163 newtype -> export = export;
2164 newtype -> read_only = read_only;
2165 }
2166
2167 oberon_assert_token(ctx, EQUAL);
2168
2169 type = newtype -> type;
2170 oberon_type(ctx, &type);
2171
2172 if(type -> class == OBERON_TYPE_VOID)
2173 {
2174 oberon_error(ctx, "recursive alias declaration");
2175 }
2176
2177 newtype -> type = type;
2178 newtype -> linked = 1;
2179 }
2180
2181 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2182 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2183
2184 static void
2185 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2186 {
2187 if(type -> class != OBERON_TYPE_POINTER
2188 && type -> class != OBERON_TYPE_ARRAY)
2189 {
2190 return;
2191 }
2192
2193 if(type -> recursive)
2194 {
2195 oberon_error(ctx, "recursive pointer declaration");
2196 }
2197
2198 if(type -> base -> class == OBERON_TYPE_POINTER)
2199 {
2200 oberon_error(ctx, "attempt to make pointer to pointer");
2201 }
2202
2203 type -> recursive = 1;
2204
2205 oberon_prevent_recursive_pointer(ctx, type -> base);
2206
2207 type -> recursive = 0;
2208 }
2209
2210 static void
2211 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2212 {
2213 if(type -> class != OBERON_TYPE_RECORD)
2214 {
2215 return;
2216 }
2217
2218 if(type -> recursive)
2219 {
2220 oberon_error(ctx, "recursive record declaration");
2221 }
2222
2223 type -> recursive = 1;
2224
2225 int num_fields = type -> num_decl;
2226 oberon_object_t * field = type -> decl;
2227 for(int i = 0; i < num_fields; i++)
2228 {
2229 oberon_prevent_recursive_object(ctx, field);
2230 field = field -> next;
2231 }
2232
2233 type -> recursive = 0;
2234 }
2235 static void
2236 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2237 {
2238 if(type -> class != OBERON_TYPE_PROCEDURE)
2239 {
2240 return;
2241 }
2242
2243 if(type -> recursive)
2244 {
2245 oberon_error(ctx, "recursive procedure declaration");
2246 }
2247
2248 type -> recursive = 1;
2249
2250 int num_fields = type -> num_decl;
2251 oberon_object_t * field = type -> decl;
2252 for(int i = 0; i < num_fields; i++)
2253 {
2254 oberon_prevent_recursive_object(ctx, field);
2255 field = field -> next;
2256 }
2257
2258 type -> recursive = 0;
2259 }
2260
2261 static void
2262 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
2263 {
2264 if(type -> class != OBERON_TYPE_ARRAY)
2265 {
2266 return;
2267 }
2268
2269 if(type -> recursive)
2270 {
2271 oberon_error(ctx, "recursive array declaration");
2272 }
2273
2274 type -> recursive = 1;
2275
2276 oberon_prevent_recursive_type(ctx, type -> base);
2277
2278 type -> recursive = 0;
2279 }
2280
2281 static void
2282 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
2283 {
2284 if(type -> class == OBERON_TYPE_POINTER)
2285 {
2286 oberon_prevent_recursive_pointer(ctx, type);
2287 }
2288 else if(type -> class == OBERON_TYPE_RECORD)
2289 {
2290 oberon_prevent_recursive_record(ctx, type);
2291 }
2292 else if(type -> class == OBERON_TYPE_ARRAY)
2293 {
2294 oberon_prevent_recursive_array(ctx, type);
2295 }
2296 else if(type -> class == OBERON_TYPE_PROCEDURE)
2297 {
2298 oberon_prevent_recursive_procedure(ctx, type);
2299 }
2300 }
2301
2302 static void
2303 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
2304 {
2305 switch(x -> class)
2306 {
2307 case OBERON_CLASS_VAR:
2308 case OBERON_CLASS_TYPE:
2309 case OBERON_CLASS_PARAM:
2310 case OBERON_CLASS_VAR_PARAM:
2311 case OBERON_CLASS_FIELD:
2312 oberon_prevent_recursive_type(ctx, x -> type);
2313 break;
2314 case OBERON_CLASS_CONST:
2315 case OBERON_CLASS_PROC:
2316 case OBERON_CLASS_MODULE:
2317 break;
2318 default:
2319 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
2320 break;
2321 }
2322 }
2323
2324 static void
2325 oberon_prevent_recursive_decl(oberon_context_t * ctx)
2326 {
2327 oberon_object_t * x = ctx -> decl -> list -> next;
2328
2329 while(x)
2330 {
2331 oberon_prevent_recursive_object(ctx, x);
2332 x = x -> next;
2333 }
2334 }
2335
2336 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
2337 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
2338
2339 static void
2340 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
2341 {
2342 if(type -> class != OBERON_TYPE_RECORD)
2343 {
2344 return;
2345 }
2346
2347 int num_fields = type -> num_decl;
2348 oberon_object_t * field = type -> decl;
2349 for(int i = 0; i < num_fields; i++)
2350 {
2351 if(field -> type -> class == OBERON_TYPE_POINTER)
2352 {
2353 oberon_initialize_type(ctx, field -> type);
2354 }
2355
2356 oberon_initialize_object(ctx, field);
2357 field = field -> next;
2358 }
2359
2360 oberon_generator_init_record(ctx, type);
2361 }
2362
2363 static void
2364 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
2365 {
2366 if(type -> class == OBERON_TYPE_VOID)
2367 {
2368 oberon_error(ctx, "undeclarated type");
2369 }
2370
2371 if(type -> initialized)
2372 {
2373 return;
2374 }
2375
2376 type -> initialized = 1;
2377
2378 if(type -> class == OBERON_TYPE_POINTER)
2379 {
2380 oberon_initialize_type(ctx, type -> base);
2381 oberon_generator_init_type(ctx, type);
2382 }
2383 else if(type -> class == OBERON_TYPE_ARRAY)
2384 {
2385 if(type -> size != 0)
2386 {
2387 if(type -> base -> class == OBERON_TYPE_ARRAY)
2388 {
2389 if(type -> base -> size == 0)
2390 {
2391 oberon_error(ctx, "open array not allowed as array element");
2392 }
2393 }
2394 }
2395
2396 oberon_initialize_type(ctx, type -> base);
2397 oberon_generator_init_type(ctx, type);
2398 }
2399 else if(type -> class == OBERON_TYPE_RECORD)
2400 {
2401 oberon_generator_init_type(ctx, type);
2402 oberon_initialize_record_fields(ctx, type);
2403 }
2404 else if(type -> class == OBERON_TYPE_PROCEDURE)
2405 {
2406 int num_fields = type -> num_decl;
2407 oberon_object_t * field = type -> decl;
2408 for(int i = 0; i < num_fields; i++)
2409 {
2410 oberon_initialize_object(ctx, field);
2411 field = field -> next;
2412 }
2413
2414 oberon_generator_init_type(ctx, type);
2415 }
2416 else
2417 {
2418 oberon_generator_init_type(ctx, type);
2419 }
2420 }
2421
2422 static void
2423 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
2424 {
2425 if(x -> initialized)
2426 {
2427 return;
2428 }
2429
2430 x -> initialized = 1;
2431
2432 switch(x -> class)
2433 {
2434 case OBERON_CLASS_TYPE:
2435 oberon_initialize_type(ctx, x -> type);
2436 break;
2437 case OBERON_CLASS_VAR:
2438 case OBERON_CLASS_FIELD:
2439 if(x -> type -> class == OBERON_TYPE_ARRAY)
2440 {
2441 if(x -> type -> size == 0)
2442 {
2443 oberon_error(ctx, "open array not allowed as variable or field");
2444 }
2445 }
2446 oberon_initialize_type(ctx, x -> type);
2447 oberon_generator_init_var(ctx, x);
2448 break;
2449 case OBERON_CLASS_PARAM:
2450 case OBERON_CLASS_VAR_PARAM:
2451 oberon_initialize_type(ctx, x -> type);
2452 oberon_generator_init_var(ctx, x);
2453 break;
2454 case OBERON_CLASS_CONST:
2455 case OBERON_CLASS_PROC:
2456 case OBERON_CLASS_MODULE:
2457 break;
2458 default:
2459 oberon_error(ctx, "oberon_initialize_object: wat");
2460 break;
2461 }
2462 }
2463
2464 static void
2465 oberon_initialize_decl(oberon_context_t * ctx)
2466 {
2467 oberon_object_t * x = ctx -> decl -> list;
2468
2469 while(x -> next)
2470 {
2471 oberon_initialize_object(ctx, x -> next);
2472 x = x -> next;
2473 }
2474 }
2475
2476 static void
2477 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
2478 {
2479 oberon_object_t * x = ctx -> decl -> list;
2480
2481 while(x -> next)
2482 {
2483 if(x -> next -> class == OBERON_CLASS_PROC)
2484 {
2485 if(x -> next -> linked == 0)
2486 {
2487 oberon_error(ctx, "unresolved forward declaration");
2488 }
2489 }
2490 x = x -> next;
2491 }
2492 }
2493
2494 static void
2495 oberon_decl_seq(oberon_context_t * ctx)
2496 {
2497 if(ctx -> token == CONST)
2498 {
2499 oberon_assert_token(ctx, CONST);
2500 while(ctx -> token == IDENT)
2501 {
2502 oberon_const_decl(ctx);
2503 oberon_assert_token(ctx, SEMICOLON);
2504 }
2505 }
2506
2507 if(ctx -> token == TYPE)
2508 {
2509 oberon_assert_token(ctx, TYPE);
2510 while(ctx -> token == IDENT)
2511 {
2512 oberon_type_decl(ctx);
2513 oberon_assert_token(ctx, SEMICOLON);
2514 }
2515 }
2516
2517 if(ctx -> token == VAR)
2518 {
2519 oberon_assert_token(ctx, VAR);
2520 while(ctx -> token == IDENT)
2521 {
2522 oberon_var_decl(ctx);
2523 oberon_assert_token(ctx, SEMICOLON);
2524 }
2525 }
2526
2527 oberon_prevent_recursive_decl(ctx);
2528 oberon_initialize_decl(ctx);
2529
2530 while(ctx -> token == PROCEDURE)
2531 {
2532 oberon_proc_decl(ctx);
2533 oberon_assert_token(ctx, SEMICOLON);
2534 }
2535
2536 oberon_prevent_undeclarated_procedures(ctx);
2537 }
2538
2539 static void
2540 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
2541 {
2542 if(dst -> read_only)
2543 {
2544 oberon_error(ctx, "read-only destination");
2545 }
2546
2547 oberon_autocast_to(ctx, src, dst -> result);
2548 oberon_generate_assign(ctx, src, dst);
2549 }
2550
2551 static void
2552 oberon_statement(oberon_context_t * ctx)
2553 {
2554 oberon_expr_t * item1;
2555 oberon_expr_t * item2;
2556
2557 if(ctx -> token == IDENT)
2558 {
2559 item1 = oberon_designator(ctx);
2560 if(ctx -> token == ASSIGN)
2561 {
2562 oberon_assert_token(ctx, ASSIGN);
2563 item2 = oberon_expr(ctx);
2564 oberon_assign(ctx, item2, item1);
2565 }
2566 else
2567 {
2568 oberon_opt_proc_parens(ctx, item1);
2569 }
2570 }
2571 else if(ctx -> token == RETURN)
2572 {
2573 oberon_assert_token(ctx, RETURN);
2574 if(ISEXPR(ctx -> token))
2575 {
2576 oberon_expr_t * expr;
2577 expr = oberon_expr(ctx);
2578 oberon_make_return(ctx, expr);
2579 }
2580 else
2581 {
2582 oberon_make_return(ctx, NULL);
2583 }
2584 }
2585 }
2586
2587 static void
2588 oberon_statement_seq(oberon_context_t * ctx)
2589 {
2590 oberon_statement(ctx);
2591 while(ctx -> token == SEMICOLON)
2592 {
2593 oberon_assert_token(ctx, SEMICOLON);
2594 oberon_statement(ctx);
2595 }
2596 }
2597
2598 static void
2599 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
2600 {
2601 oberon_module_t * m = ctx -> module_list;
2602 while(m && strcmp(m -> name, name) != 0)
2603 {
2604 m = m -> next;
2605 }
2606
2607 if(m == NULL)
2608 {
2609 const char * code;
2610 code = ctx -> import_module(name);
2611 if(code == NULL)
2612 {
2613 oberon_error(ctx, "no such module");
2614 }
2615
2616 m = oberon_compile_module(ctx, code);
2617 assert(m);
2618 }
2619
2620 if(m -> ready == 0)
2621 {
2622 oberon_error(ctx, "cyclic module import");
2623 }
2624
2625 oberon_object_t * ident;
2626 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, 0, 0);
2627 ident -> module = m;
2628 }
2629
2630 static void
2631 oberon_import_decl(oberon_context_t * ctx)
2632 {
2633 char * alias;
2634 char * name;
2635
2636 alias = name = oberon_assert_ident(ctx);
2637 if(ctx -> token == ASSIGN)
2638 {
2639 oberon_assert_token(ctx, ASSIGN);
2640 name = oberon_assert_ident(ctx);
2641 }
2642
2643 oberon_import_module(ctx, alias, name);
2644 }
2645
2646 static void
2647 oberon_import_list(oberon_context_t * ctx)
2648 {
2649 oberon_assert_token(ctx, IMPORT);
2650
2651 oberon_import_decl(ctx);
2652 while(ctx -> token == COMMA)
2653 {
2654 oberon_assert_token(ctx, COMMA);
2655 oberon_import_decl(ctx);
2656 }
2657
2658 oberon_assert_token(ctx, SEMICOLON);
2659 }
2660
2661 static void
2662 oberon_parse_module(oberon_context_t * ctx)
2663 {
2664 char * name1;
2665 char * name2;
2666 oberon_read_token(ctx);
2667
2668 oberon_assert_token(ctx, MODULE);
2669 name1 = oberon_assert_ident(ctx);
2670 oberon_assert_token(ctx, SEMICOLON);
2671 ctx -> mod -> name = name1;
2672
2673 if(ctx -> token == IMPORT)
2674 {
2675 oberon_import_list(ctx);
2676 }
2677
2678 oberon_decl_seq(ctx);
2679
2680 oberon_generate_begin_module(ctx);
2681 if(ctx -> token == BEGIN)
2682 {
2683 oberon_assert_token(ctx, BEGIN);
2684 oberon_statement_seq(ctx);
2685 }
2686 oberon_generate_end_module(ctx);
2687
2688 oberon_assert_token(ctx, END);
2689 name2 = oberon_assert_ident(ctx);
2690 oberon_assert_token(ctx, DOT);
2691
2692 if(strcmp(name1, name2) != 0)
2693 {
2694 oberon_error(ctx, "module name not matched");
2695 }
2696 }
2697
2698 // =======================================================================
2699 // LIBRARY
2700 // =======================================================================
2701
2702 static void
2703 register_default_types(oberon_context_t * ctx)
2704 {
2705 ctx -> void_type = oberon_new_type_ptr(OBERON_TYPE_VOID);
2706 oberon_generator_init_type(ctx, ctx -> void_type);
2707
2708 ctx -> void_ptr_type = oberon_new_type_ptr(OBERON_TYPE_POINTER);
2709 ctx -> void_ptr_type -> base = ctx -> void_type;
2710 oberon_generator_init_type(ctx, ctx -> void_ptr_type);
2711
2712 ctx -> int_type = oberon_new_type_integer(sizeof(int));
2713 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> int_type, 1);
2714
2715 ctx -> bool_type = oberon_new_type_boolean(sizeof(bool));
2716 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
2717
2718 ctx -> real_type = oberon_new_type_real(sizeof(float));
2719 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
2720 }
2721
2722 static void
2723 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
2724 {
2725 oberon_object_t * proc;
2726 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, 1, 0);
2727 proc -> sysproc = 1;
2728 proc -> genfunc = f;
2729 proc -> genproc = p;
2730 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
2731 }
2732
2733 static oberon_expr_t *
2734 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2735 {
2736 if(num_args < 1)
2737 {
2738 oberon_error(ctx, "too few arguments");
2739 }
2740
2741 if(num_args > 1)
2742 {
2743 oberon_error(ctx, "too mach arguments");
2744 }
2745
2746 oberon_expr_t * arg;
2747 arg = list_args;
2748
2749 oberon_type_t * result_type;
2750 result_type = arg -> result;
2751
2752 if(result_type -> class != OBERON_TYPE_INTEGER)
2753 {
2754 oberon_error(ctx, "ABS accepts only integers");
2755 }
2756
2757
2758 oberon_expr_t * expr;
2759 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
2760 return expr;
2761 }
2762
2763 static void
2764 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
2765 {
2766 if(num_args < 1)
2767 {
2768 oberon_error(ctx, "too few arguments");
2769 }
2770
2771 oberon_expr_t * dst;
2772 dst = list_args;
2773
2774 oberon_type_t * type;
2775 type = dst -> result;
2776
2777 if(type -> class != OBERON_TYPE_POINTER)
2778 {
2779 oberon_error(ctx, "not a pointer");
2780 }
2781
2782 type = type -> base;
2783
2784 oberon_expr_t * src;
2785 src = oberon_new_item(MODE_NEW, dst -> result, 0);
2786 src -> item.num_args = 0;
2787 src -> item.args = NULL;
2788
2789 int max_args = 1;
2790 if(type -> class == OBERON_TYPE_ARRAY)
2791 {
2792 if(type -> size == 0)
2793 {
2794 oberon_type_t * x = type;
2795 while(x -> class == OBERON_TYPE_ARRAY)
2796 {
2797 if(x -> size == 0)
2798 {
2799 max_args += 1;
2800 }
2801 x = x -> base;
2802 }
2803 }
2804
2805 if(num_args < max_args)
2806 {
2807 oberon_error(ctx, "too few arguments");
2808 }
2809
2810 if(num_args > max_args)
2811 {
2812 oberon_error(ctx, "too mach arguments");
2813 }
2814
2815 int num_sizes = max_args - 1;
2816 oberon_expr_t * size_list = list_args -> next;
2817
2818 oberon_expr_t * arg = size_list;
2819 for(int i = 0; i < max_args - 1; i++)
2820 {
2821 if(arg -> result -> class != OBERON_TYPE_INTEGER)
2822 {
2823 oberon_error(ctx, "size must be integer");
2824 }
2825 arg = arg -> next;
2826 }
2827
2828 src -> item.num_args = num_sizes;
2829 src -> item.args = size_list;
2830 }
2831 else if(type -> class != OBERON_TYPE_RECORD)
2832 {
2833 oberon_error(ctx, "oberon_make_new_call: wat");
2834 }
2835
2836 if(num_args > max_args)
2837 {
2838 oberon_error(ctx, "too mach arguments");
2839 }
2840
2841 oberon_assign(ctx, src, dst);
2842 }
2843
2844 oberon_context_t *
2845 oberon_create_context(ModuleImportCallback import_module)
2846 {
2847 oberon_context_t * ctx = calloc(1, sizeof *ctx);
2848
2849 oberon_scope_t * world_scope;
2850 world_scope = oberon_open_scope(ctx);
2851 ctx -> world_scope = world_scope;
2852
2853 ctx -> import_module = import_module;
2854
2855 oberon_generator_init_context(ctx);
2856
2857 register_default_types(ctx);
2858 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
2859 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
2860
2861 return ctx;
2862 }
2863
2864 void
2865 oberon_destroy_context(oberon_context_t * ctx)
2866 {
2867 oberon_generator_destroy_context(ctx);
2868 free(ctx);
2869 }
2870
2871 oberon_module_t *
2872 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
2873 {
2874 const char * code = ctx -> code;
2875 int code_index = ctx -> code_index;
2876 char c = ctx -> c;
2877 int token = ctx -> token;
2878 char * string = ctx -> string;
2879 int integer = ctx -> integer;
2880 oberon_scope_t * decl = ctx -> decl;
2881 oberon_module_t * mod = ctx -> mod;
2882
2883 oberon_scope_t * module_scope;
2884 module_scope = oberon_open_scope(ctx);
2885
2886 oberon_module_t * module;
2887 module = calloc(1, sizeof *module);
2888 module -> decl = module_scope;
2889 module -> next = ctx -> module_list;
2890
2891 ctx -> mod = module;
2892 ctx -> module_list = module;
2893
2894 oberon_init_scaner(ctx, newcode);
2895 oberon_parse_module(ctx);
2896
2897 module -> ready = 1;
2898
2899 ctx -> code = code;
2900 ctx -> code_index = code_index;
2901 ctx -> c = c;
2902 ctx -> token = token;
2903 ctx -> string = string;
2904 ctx -> integer = integer;
2905 ctx -> decl = decl;
2906 ctx -> mod = mod;
2907
2908 return module;
2909 }
Another attempt to make Oberon compiler
[25/02/2024 19:55:35]
DEADSOFTWARE 2012-2024