DEADSOFTWARE

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