DEADSOFTWARE
GIT / REPO / FRED-BOY

Projects / dsw-obn.git / blob


9738056b94124b347e771b1bb541364e83859ae6
[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 #include <math.h>
9
10 #include "../include/oberon.h"
11
12 #include "oberon-internals.h"
13 #include "generator.h"
14
15 enum {
16 EOF_ = 0,
17 IDENT,
18 MODULE,
19 SEMICOLON,
20 END,
21 DOT,
22 VAR,
23 COLON,
24 BEGIN,
25 ASSIGN,
26 INTEGER,
27 LPAREN,
28 RPAREN,
29 EQUAL,
30 NEQ,
31 LESS,
32 LEQ,
33 GREAT,
34 GEQ,
35 IN,
36 IS,
37 PLUS,
38 MINUS,
39 OR,
40 STAR,
41 SLASH,
42 DIV,
43 MOD,
44 AND,
45 NOT,
46 PROCEDURE,
47 COMMA,
48 RETURN,
49 CONST,
50 TYPE,
51 ARRAY,
52 OF,
53 LBRACK,
54 RBRACK,
55 RECORD,
56 POINTER,
57 TO,
58 UPARROW,
59 NIL,
60 IMPORT,
61 REAL,
62 CHAR,
63 STRING,
64 IF,
65 THEN,
66 ELSE,
67 ELSIF,
68 WHILE,
69 DO,
70 REPEAT,
71 UNTIL,
72 FOR,
73 BY,
74 LOOP,
75 EXIT,
76 LBRACE,
77 RBRACE,
78 DOTDOT,
79 CASE,
80 BAR,
81 WITH
82 };
83
84 // =======================================================================
85 // UTILS
86 // =======================================================================
87
88 static void
89 oberon_error(oberon_context_t * ctx, const char * fmt, ...)
90 {
91 va_list ptr;
92 va_start(ptr, fmt);
93 fprintf(stderr, "error: ");
94 vfprintf(stderr, fmt, ptr);
95 fprintf(stderr, "\n");
96 fprintf(stderr, " code_index = %i\n", ctx -> code_index);
97 fprintf(stderr, " c = %c\n", ctx -> c);
98 fprintf(stderr, " token = %i\n", ctx -> token);
99 va_end(ptr);
100 exit(1);
101 }
102
103 static oberon_type_t *
104 oberon_new_type_ptr(int class)
105 {
106 oberon_type_t * x = malloc(sizeof *x);
107 memset(x, 0, sizeof *x);
108 x -> class = class;
109 return x;
110 }
111
112 static oberon_type_t *
113 oberon_new_type_integer(int size)
114 {
115 oberon_type_t * x;
116 x = oberon_new_type_ptr(OBERON_TYPE_INTEGER);
117 x -> size = size;
118 return x;
119 }
120
121 static oberon_type_t *
122 oberon_new_type_boolean()
123 {
124 oberon_type_t * x;
125 x = oberon_new_type_ptr(OBERON_TYPE_BOOLEAN);
126 return x;
127 }
128
129 static oberon_type_t *
130 oberon_new_type_real(int size)
131 {
132 oberon_type_t * x;
133 x = oberon_new_type_ptr(OBERON_TYPE_REAL);
134 x -> size = size;
135 return x;
136 }
137
138 static oberon_type_t *
139 oberon_new_type_char(int size)
140 {
141 oberon_type_t * x;
142 x = oberon_new_type_ptr(OBERON_TYPE_CHAR);
143 x -> size = size;
144 return x;
145 }
146
147 static oberon_type_t *
148 oberon_new_type_string(int size)
149 {
150 oberon_type_t * x;
151 x = oberon_new_type_ptr(OBERON_TYPE_STRING);
152 x -> size = size;
153 return x;
154 }
155
156 static oberon_type_t *
157 oberon_new_type_set(int size)
158 {
159 oberon_type_t * x;
160 x = oberon_new_type_ptr(OBERON_TYPE_SET);
161 x -> size = size;
162 return x;
163 }
164
165 // =======================================================================
166 // TABLE
167 // =======================================================================
168
169 static oberon_scope_t *
170 oberon_open_scope(oberon_context_t * ctx)
171 {
172 oberon_scope_t * scope = calloc(1, sizeof *scope);
173 oberon_object_t * list = calloc(1, sizeof *list);
174
175 scope -> ctx = ctx;
176 scope -> list = list;
177 scope -> up = ctx -> decl;
178
179 if(scope -> up)
180 {
181 scope -> local = scope -> up -> local;
182 scope -> parent = scope -> up -> parent;
183 scope -> parent_type = scope -> up -> parent_type;
184 scope -> exit_label = scope -> up -> exit_label;
185 }
186
187 ctx -> decl = scope;
188 return scope;
189 }
190
191 static void
192 oberon_close_scope(oberon_scope_t * scope)
193 {
194 oberon_context_t * ctx = scope -> ctx;
195 ctx -> decl = scope -> up;
196 }
197
198 static oberon_object_t *
199 oberon_find_object_in_list(oberon_object_t * list, char * name)
200 {
201 oberon_object_t * x = list;
202 while(x -> next && strcmp(x -> next -> name, name) != 0)
203 {
204 x = x -> next;
205 }
206 return x -> next;
207 }
208
209 static oberon_object_t *
210 oberon_find_object(oberon_scope_t * scope, char * name, bool check_it)
211 {
212 oberon_object_t * result = NULL;
213
214 oberon_scope_t * s = scope;
215 while(result == NULL && s != NULL)
216 {
217 result = oberon_find_object_in_list(s -> list, name);
218 s = s -> up;
219 }
220
221 if(check_it && result == NULL)
222 {
223 oberon_error(scope -> ctx, "undefined ident %s", name);
224 }
225
226 return result;
227 }
228
229 static oberon_object_t *
230 oberon_create_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only)
231 {
232 oberon_object_t * newvar = malloc(sizeof *newvar);
233 memset(newvar, 0, sizeof *newvar);
234 newvar -> name = name;
235 newvar -> class = class;
236 newvar -> export = export;
237 newvar -> read_only = read_only;
238 newvar -> local = scope -> local;
239 newvar -> parent = scope -> parent;
240 newvar -> parent_type = scope -> parent_type;
241 newvar -> module = scope -> ctx -> mod;
242 return newvar;
243 }
244
245 static oberon_object_t *
246 oberon_define_object(oberon_scope_t * scope, char * name, int class, bool export, bool read_only, bool check_upscope)
247 {
248 if(check_upscope)
249 {
250 if(oberon_find_object(scope -> up, name, false))
251 {
252 oberon_error(scope -> ctx, "already defined");
253 }
254 }
255
256 oberon_object_t * x = scope -> list;
257 while(x -> next && strcmp(x -> next -> name, name) != 0)
258 {
259 x = x -> next;
260 }
261
262 if(x -> next)
263 {
264 oberon_error(scope -> ctx, "already defined");
265 }
266
267 oberon_object_t * newvar;
268 newvar = oberon_create_object(scope, name, class, export, read_only);
269 x -> next = newvar;
270
271 return newvar;
272 }
273
274 static oberon_object_t *
275 oberon_define_type(oberon_scope_t * scope, char * name, oberon_type_t * type, int export)
276 {
277 oberon_object_t * id;
278 id = oberon_define_object(scope, name, OBERON_CLASS_TYPE, export, false, false);
279 id -> type = type;
280 oberon_generator_init_type(scope -> ctx, type);
281 return id;
282 }
283
284 // =======================================================================
285 // SCANER
286 // =======================================================================
287
288 static void
289 oberon_get_char(oberon_context_t * ctx)
290 {
291 if(ctx -> code[ctx -> code_index])
292 {
293 ctx -> code_index += 1;
294 ctx -> c = ctx -> code[ctx -> code_index];
295 }
296 }
297
298 static void
299 oberon_init_scaner(oberon_context_t * ctx, const char * code)
300 {
301 ctx -> code = code;
302 ctx -> code_index = 0;
303 ctx -> c = ctx -> code[ctx -> code_index];
304 }
305
306 static void
307 oberon_read_ident(oberon_context_t * ctx)
308 {
309 int len = 0;
310 int i = ctx -> code_index;
311
312 int c = ctx -> code[i];
313 while(isalnum(c))
314 {
315 i += 1;
316 len += 1;
317 c = ctx -> code[i];
318 }
319
320 char * ident = malloc(len + 1);
321 memcpy(ident, &ctx->code[ctx->code_index], len);
322 ident[len] = 0;
323
324 ctx -> code_index = i;
325 ctx -> c = ctx -> code[i];
326 ctx -> string = ident;
327 ctx -> token = IDENT;
328
329 if(strcmp(ident, "MODULE") == 0)
330 {
331 ctx -> token = MODULE;
332 }
333 else if(strcmp(ident, "END") == 0)
334 {
335 ctx -> token = END;
336 }
337 else if(strcmp(ident, "VAR") == 0)
338 {
339 ctx -> token = VAR;
340 }
341 else if(strcmp(ident, "BEGIN") == 0)
342 {
343 ctx -> token = BEGIN;
344 }
345 else if(strcmp(ident, "OR") == 0)
346 {
347 ctx -> token = OR;
348 }
349 else if(strcmp(ident, "DIV") == 0)
350 {
351 ctx -> token = DIV;
352 }
353 else if(strcmp(ident, "MOD") == 0)
354 {
355 ctx -> token = MOD;
356 }
357 else if(strcmp(ident, "PROCEDURE") == 0)
358 {
359 ctx -> token = PROCEDURE;
360 }
361 else if(strcmp(ident, "RETURN") == 0)
362 {
363 ctx -> token = RETURN;
364 }
365 else if(strcmp(ident, "CONST") == 0)
366 {
367 ctx -> token = CONST;
368 }
369 else if(strcmp(ident, "TYPE") == 0)
370 {
371 ctx -> token = TYPE;
372 }
373 else if(strcmp(ident, "ARRAY") == 0)
374 {
375 ctx -> token = ARRAY;
376 }
377 else if(strcmp(ident, "OF") == 0)
378 {
379 ctx -> token = OF;
380 }
381 else if(strcmp(ident, "RECORD") == 0)
382 {
383 ctx -> token = RECORD;
384 }
385 else if(strcmp(ident, "POINTER") == 0)
386 {
387 ctx -> token = POINTER;
388 }
389 else if(strcmp(ident, "TO") == 0)
390 {
391 ctx -> token = TO;
392 }
393 else if(strcmp(ident, "NIL") == 0)
394 {
395 ctx -> token = NIL;
396 }
397 else if(strcmp(ident, "IMPORT") == 0)
398 {
399 ctx -> token = IMPORT;
400 }
401 else if(strcmp(ident, "IN") == 0)
402 {
403 ctx -> token = IN;
404 }
405 else if(strcmp(ident, "IS") == 0)
406 {
407 ctx -> token = IS;
408 }
409 else if(strcmp(ident, "IF") == 0)
410 {
411 ctx -> token = IF;
412 }
413 else if(strcmp(ident, "THEN") == 0)
414 {
415 ctx -> token = THEN;
416 }
417 else if(strcmp(ident, "ELSE") == 0)
418 {
419 ctx -> token = ELSE;
420 }
421 else if(strcmp(ident, "ELSIF") == 0)
422 {
423 ctx -> token = ELSIF;
424 }
425 else if(strcmp(ident, "WHILE") == 0)
426 {
427 ctx -> token = WHILE;
428 }
429 else if(strcmp(ident, "DO") == 0)
430 {
431 ctx -> token = DO;
432 }
433 else if(strcmp(ident, "REPEAT") == 0)
434 {
435 ctx -> token = REPEAT;
436 }
437 else if(strcmp(ident, "UNTIL") == 0)
438 {
439 ctx -> token = UNTIL;
440 }
441 else if(strcmp(ident, "FOR") == 0)
442 {
443 ctx -> token = FOR;
444 }
445 else if(strcmp(ident, "BY") == 0)
446 {
447 ctx -> token = BY;
448 }
449 else if(strcmp(ident, "LOOP") == 0)
450 {
451 ctx -> token = LOOP;
452 }
453 else if(strcmp(ident, "EXIT") == 0)
454 {
455 ctx -> token = EXIT;
456 }
457 else if(strcmp(ident, "CASE") == 0)
458 {
459 ctx -> token = CASE;
460 }
461 else if(strcmp(ident, "WITH") == 0)
462 {
463 ctx -> token = WITH;
464 }
465 }
466
467 #define ISHEXDIGIT(x) \
468 (((x) >= '0' && (x) <= '9') || ((x) >= 'A' && (x) <= 'F'))
469
470 static void
471 oberon_read_number(oberon_context_t * ctx)
472 {
473 long integer;
474 double real;
475 char * ident;
476 int start_i;
477 int exp_i;
478 int end_i;
479
480 /*
481 * mode = 0 == DEC
482 * mode = 1 == HEX
483 * mode = 2 == REAL
484 * mode = 3 == LONGREAL
485 * mode = 4 == CHAR
486 */
487 int mode = 0;
488 start_i = ctx -> code_index;
489
490 while(isdigit(ctx -> c))
491 {
492 oberon_get_char(ctx);
493 }
494
495 end_i = ctx -> code_index;
496
497 if(ISHEXDIGIT(ctx -> c))
498 {
499 mode = 1;
500 while(ISHEXDIGIT(ctx -> c))
501 {
502 oberon_get_char(ctx);
503 }
504
505 end_i = ctx -> code_index;
506
507 if(ctx -> c == 'H')
508 {
509 mode = 1;
510 oberon_get_char(ctx);
511 }
512 else if(ctx -> c == 'X')
513 {
514 mode = 4;
515 oberon_get_char(ctx);
516 }
517 else
518 {
519 oberon_error(ctx, "invalid hex number");
520 }
521 }
522 else if(ctx -> c == '.')
523 {
524 oberon_get_char(ctx);
525 if(ctx -> c == '.')
526 {
527 /* Чит: избегаем конфликта с DOTDOT */
528 ctx -> code_index -= 1;
529 }
530 else
531 {
532 mode = 2;
533
534 while(isdigit(ctx -> c))
535 {
536 oberon_get_char(ctx);
537 }
538
539 if(ctx -> c == 'E' || ctx -> c == 'D')
540 {
541 exp_i = ctx -> code_index;
542
543 if(ctx -> c == 'D')
544 {
545 mode = 3;
546 }
547
548 oberon_get_char(ctx);
549
550 if(ctx -> c == '+' || ctx -> c == '-')
551 {
552 oberon_get_char(ctx);
553 }
554
555 while(isdigit(ctx -> c))
556 {
557 oberon_get_char(ctx);
558 }
559 }
560 }
561 end_i = ctx -> code_index;
562 }
563
564 if(mode == 0)
565 {
566 if(ctx -> c == 'H')
567 {
568 mode = 1;
569 oberon_get_char(ctx);
570 }
571 else if(ctx -> c == 'X')
572 {
573 mode = 4;
574 oberon_get_char(ctx);
575 }
576 }
577
578 int len = end_i - start_i;
579 ident = malloc(len + 1);
580 memcpy(ident, &ctx -> code[start_i], len);
581 ident[len] = 0;
582
583 ctx -> longmode = false;
584 if(mode == 3)
585 {
586 int i = exp_i - start_i;
587 ident[i] = 'E';
588 ctx -> longmode = true;
589 }
590
591 switch(mode)
592 {
593 case 0:
594 integer = atol(ident);
595 real = integer;
596 ctx -> token = INTEGER;
597 break;
598 case 1:
599 sscanf(ident, "%lx", &integer);
600 real = integer;
601 ctx -> token = INTEGER;
602 break;
603 case 2:
604 case 3:
605 sscanf(ident, "%lf", &real);
606 ctx -> token = REAL;
607 break;
608 case 4:
609 sscanf(ident, "%lx", &integer);
610 real = integer;
611 ctx -> token = CHAR;
612 break;
613 default:
614 oberon_error(ctx, "oberon_read_number: wat");
615 break;
616 }
617
618 ctx -> string = ident;
619 ctx -> integer = integer;
620 ctx -> real = real;
621 }
622
623 static void
624 oberon_skip_space(oberon_context_t * ctx)
625 {
626 while(isspace(ctx -> c))
627 {
628 oberon_get_char(ctx);
629 }
630 }
631
632 static void
633 oberon_read_comment(oberon_context_t * ctx)
634 {
635 int nesting = 1;
636 while(nesting >= 1)
637 {
638 if(ctx -> c == '(')
639 {
640 oberon_get_char(ctx);
641 if(ctx -> c == '*')
642 {
643 oberon_get_char(ctx);
644 nesting += 1;
645 }
646 }
647 else if(ctx -> c == '*')
648 {
649 oberon_get_char(ctx);
650 if(ctx -> c == ')')
651 {
652 oberon_get_char(ctx);
653 nesting -= 1;
654 }
655 }
656 else if(ctx -> c == 0)
657 {
658 oberon_error(ctx, "unterminated comment");
659 }
660 else
661 {
662 oberon_get_char(ctx);
663 }
664 }
665 }
666
667 static void oberon_read_string(oberon_context_t * ctx)
668 {
669 int c = ctx -> c;
670 oberon_get_char(ctx);
671
672 int start = ctx -> code_index;
673
674 while(ctx -> c != 0 && ctx -> c != c)
675 {
676 oberon_get_char(ctx);
677 }
678
679 if(ctx -> c == 0)
680 {
681 oberon_error(ctx, "unterminated string");
682 }
683
684 int end = ctx -> code_index;
685
686 oberon_get_char(ctx);
687
688 char * string = calloc(1, end - start + 1);
689 strncpy(string, &ctx -> code[start], end - start);
690
691 ctx -> token = STRING;
692 ctx -> string = string;
693 }
694
695 static void oberon_read_token(oberon_context_t * ctx);
696
697 static void
698 oberon_read_symbol(oberon_context_t * ctx)
699 {
700 int c = ctx -> c;
701 switch(c)
702 {
703 case 0:
704 ctx -> token = EOF_;
705 break;
706 case ';':
707 ctx -> token = SEMICOLON;
708 oberon_get_char(ctx);
709 break;
710 case ':':
711 ctx -> token = COLON;
712 oberon_get_char(ctx);
713 if(ctx -> c == '=')
714 {
715 ctx -> token = ASSIGN;
716 oberon_get_char(ctx);
717 }
718 break;
719 case '.':
720 ctx -> token = DOT;
721 oberon_get_char(ctx);
722 if(ctx -> c == '.')
723 {
724 ctx -> token = DOTDOT;
725 oberon_get_char(ctx);
726 }
727 break;
728 case '(':
729 ctx -> token = LPAREN;
730 oberon_get_char(ctx);
731 if(ctx -> c == '*')
732 {
733 oberon_get_char(ctx);
734 oberon_read_comment(ctx);
735 oberon_read_token(ctx);
736 }
737 break;
738 case ')':
739 ctx -> token = RPAREN;
740 oberon_get_char(ctx);
741 break;
742 case '=':
743 ctx -> token = EQUAL;
744 oberon_get_char(ctx);
745 break;
746 case '#':
747 ctx -> token = NEQ;
748 oberon_get_char(ctx);
749 break;
750 case '<':
751 ctx -> token = LESS;
752 oberon_get_char(ctx);
753 if(ctx -> c == '=')
754 {
755 ctx -> token = LEQ;
756 oberon_get_char(ctx);
757 }
758 break;
759 case '>':
760 ctx -> token = GREAT;
761 oberon_get_char(ctx);
762 if(ctx -> c == '=')
763 {
764 ctx -> token = GEQ;
765 oberon_get_char(ctx);
766 }
767 break;
768 case '+':
769 ctx -> token = PLUS;
770 oberon_get_char(ctx);
771 break;
772 case '-':
773 ctx -> token = MINUS;
774 oberon_get_char(ctx);
775 break;
776 case '*':
777 ctx -> token = STAR;
778 oberon_get_char(ctx);
779 if(ctx -> c == ')')
780 {
781 oberon_get_char(ctx);
782 oberon_error(ctx, "unstarted comment");
783 }
784 break;
785 case '/':
786 ctx -> token = SLASH;
787 oberon_get_char(ctx);
788 break;
789 case '&':
790 ctx -> token = AND;
791 oberon_get_char(ctx);
792 break;
793 case '~':
794 ctx -> token = NOT;
795 oberon_get_char(ctx);
796 break;
797 case ',':
798 ctx -> token = COMMA;
799 oberon_get_char(ctx);
800 break;
801 case '[':
802 ctx -> token = LBRACK;
803 oberon_get_char(ctx);
804 break;
805 case ']':
806 ctx -> token = RBRACK;
807 oberon_get_char(ctx);
808 break;
809 case '^':
810 ctx -> token = UPARROW;
811 oberon_get_char(ctx);
812 break;
813 case '"':
814 oberon_read_string(ctx);
815 break;
816 case '\'':
817 oberon_read_string(ctx);
818 break;
819 case '{':
820 ctx -> token = LBRACE;
821 oberon_get_char(ctx);
822 break;
823 case '}':
824 ctx -> token = RBRACE;
825 oberon_get_char(ctx);
826 break;
827 case '|':
828 ctx -> token = BAR;
829 oberon_get_char(ctx);
830 break;
831 default:
832 oberon_error(ctx, "invalid char %c", ctx -> c);
833 break;
834 }
835 }
836
837 static void
838 oberon_read_token(oberon_context_t * ctx)
839 {
840 oberon_skip_space(ctx);
841
842 int c = ctx -> c;
843 if(isalpha(c))
844 {
845 oberon_read_ident(ctx);
846 }
847 else if(isdigit(c))
848 {
849 oberon_read_number(ctx);
850 }
851 else
852 {
853 oberon_read_symbol(ctx);
854 }
855 }
856
857 // =======================================================================
858 // EXPRESSION
859 // =======================================================================
860
861 static void oberon_expect_token(oberon_context_t * ctx, int token);
862 static oberon_expr_t * oberon_expr(oberon_context_t * ctx);
863 static void oberon_assert_token(oberon_context_t * ctx, int token);
864 static char * oberon_assert_ident(oberon_context_t * ctx);
865 static void oberon_type(oberon_context_t * ctx, oberon_type_t ** type);
866 static oberon_item_t * oberon_const_expr(oberon_context_t * ctx);
867 static oberon_expr_t * oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr);
868
869 static oberon_expr_t *
870 oberon_new_operator(int op, oberon_type_t * result, oberon_expr_t * left, oberon_expr_t * right)
871 {
872 oberon_oper_t * operator;
873 operator = malloc(sizeof *operator);
874 memset(operator, 0, sizeof *operator);
875
876 operator -> is_item = 0;
877 operator -> result = result;
878 operator -> read_only = 1;
879 operator -> op = op;
880 operator -> left = left;
881 operator -> right = right;
882
883 return (oberon_expr_t *) operator;
884 }
885
886 static oberon_expr_t *
887 oberon_new_item(int mode, oberon_type_t * result, int read_only)
888 {
889 oberon_item_t * item;
890 item = malloc(sizeof *item);
891 memset(item, 0, sizeof *item);
892
893 item -> is_item = 1;
894 item -> result = result;
895 item -> read_only = read_only;
896 item -> mode = mode;
897
898 return (oberon_expr_t *)item;
899 }
900
901 static oberon_expr_t *
902 oberon_make_unary_op(oberon_context_t * ctx, int token, oberon_expr_t * a)
903 {
904 oberon_expr_t * expr;
905 oberon_type_t * result;
906
907 result = a -> result;
908
909 if(token == MINUS)
910 {
911 if(result -> class == OBERON_TYPE_SET)
912 {
913 expr = oberon_new_operator(OP_COMPLEMENTATION, result, a, NULL);
914 }
915 else if(result -> class == OBERON_TYPE_INTEGER)
916 {
917 expr = oberon_new_operator(OP_UNARY_MINUS, result, a, NULL);
918 }
919 else
920 {
921 oberon_error(ctx, "incompatible operator type");
922 }
923 }
924 else if(token == NOT)
925 {
926 if(result -> class != OBERON_TYPE_BOOLEAN)
927 {
928 oberon_error(ctx, "incompatible operator type");
929 }
930
931 expr = oberon_new_operator(OP_LOGIC_NOT, result, a, NULL);
932 }
933 else
934 {
935 oberon_error(ctx, "oberon_make_unary_op: wat");
936 }
937
938 return expr;
939 }
940
941 static void
942 oberon_expr_list(oberon_context_t * ctx, int * num_expr, oberon_expr_t ** first, int const_expr)
943 {
944 oberon_expr_t * last;
945
946 *num_expr = 1;
947 if(const_expr)
948 {
949 *first = last = (oberon_expr_t *) oberon_const_expr(ctx);
950 }
951 else
952 {
953 *first = last = oberon_expr(ctx);
954 }
955 while(ctx -> token == COMMA)
956 {
957 oberon_assert_token(ctx, COMMA);
958 oberon_expr_t * current;
959
960 if(const_expr)
961 {
962 current = (oberon_expr_t *) oberon_const_expr(ctx);
963 }
964 else
965 {
966 current = oberon_expr(ctx);
967 }
968
969 last -> next = current;
970 last = current;
971 *num_expr += 1;
972 }
973 }
974
975 static oberon_expr_t *
976 oberon_cast_expr(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
977 {
978 return oberon_new_operator(OP_CAST, pref, expr, NULL);
979 }
980
981 static oberon_expr_t *
982 oberno_make_record_cast(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * rec)
983 {
984 oberon_type_t * from = expr -> result;
985 oberon_type_t * to = rec;
986
987 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
988 {
989 from = from -> base;
990 to = to -> base;
991 }
992
993 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
994 {
995 oberon_error(ctx, "must be record type");
996 }
997
998 return oberon_cast_expr(ctx, expr, rec);
999 }
1000
1001 static oberon_type_t *
1002 oberon_get_equal_expr_type(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
1003 {
1004 oberon_type_t * result;
1005 if(a -> class == OBERON_TYPE_REAL && b -> class == OBERON_TYPE_INTEGER)
1006 {
1007 result = a;
1008 }
1009 else if(b -> class == OBERON_TYPE_REAL && a -> class == OBERON_TYPE_INTEGER)
1010 {
1011 result = b;
1012 }
1013 else if(a -> class != b -> class)
1014 {
1015 oberon_error(ctx, "oberon_get_equal_expr_type: incompatible types");
1016 }
1017 else if(a -> size > b -> size)
1018 {
1019 result = a;
1020 }
1021 else
1022 {
1023 result = b;
1024 }
1025
1026 return result;
1027 }
1028
1029 static void
1030 oberon_check_record_compatibility(oberon_context_t * ctx, oberon_type_t * from, oberon_type_t * to)
1031 {
1032 if(from -> class == OBERON_TYPE_POINTER && to -> class == OBERON_TYPE_POINTER)
1033 {
1034 from = from -> base;
1035 to = to -> base;
1036 }
1037
1038 if(from -> class != OBERON_TYPE_RECORD || to -> class != OBERON_TYPE_RECORD)
1039 {
1040 oberon_error(ctx, "not a record");
1041 }
1042
1043 oberon_type_t * t = from;
1044 while(t != NULL && t != to)
1045 {
1046 t = t -> base;
1047 }
1048
1049 if(t == NULL)
1050 {
1051 oberon_error(ctx, "incompatible record types");
1052 }
1053 }
1054
1055 static void
1056 oberon_check_dst(oberon_context_t * ctx, oberon_expr_t * dst)
1057 {
1058 if(dst -> is_item == false)
1059 {
1060 oberon_error(ctx, "not variable");
1061 }
1062
1063 switch(dst -> item.mode)
1064 {
1065 case MODE_VAR:
1066 case MODE_CALL:
1067 case MODE_INDEX:
1068 case MODE_FIELD:
1069 case MODE_DEREF:
1070 case MODE_NEW:
1071 /* accept */
1072 break;
1073 default:
1074 oberon_error(ctx, "not variable");
1075 break;
1076 }
1077 }
1078
1079 static void
1080 oberon_check_src(oberon_context_t * ctx, oberon_expr_t * src)
1081 {
1082 if(src -> is_item)
1083 {
1084 if(src -> item.mode == MODE_TYPE)
1085 {
1086 oberon_error(ctx, "not variable");
1087 }
1088 }
1089 }
1090
1091 static oberon_expr_t *
1092 oberon_autocast_to(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * pref)
1093 {
1094 // Допускается:
1095 // Если классы типов равны
1096 // Если INTEGER переводится в REAL
1097 // Если STRING переводится в CHAR
1098 // Если STRING переводится в ARRAY OF CHAR
1099 // Если NIL переводится в POINTER
1100 // Если NIL переводится в PROCEDURE
1101
1102 oberon_check_src(ctx, expr);
1103
1104 bool error = false;
1105 if(pref -> class != expr -> result -> class)
1106 {
1107 if(expr -> result -> class == OBERON_TYPE_NIL)
1108 {
1109 if(pref -> class != OBERON_TYPE_POINTER
1110 && pref -> class != OBERON_TYPE_PROCEDURE)
1111 {
1112 error = true;
1113 }
1114 }
1115 else if(expr -> result -> class == OBERON_TYPE_STRING)
1116 {
1117 if(pref -> class == OBERON_TYPE_CHAR)
1118 {
1119 if(expr -> is_item && expr -> item.mode == MODE_STRING)
1120 {
1121 if(strlen(expr -> item.string) != 1)
1122 {
1123 error = true;
1124 }
1125 }
1126 else
1127 {
1128 error = true;
1129 }
1130 }
1131 else if(pref -> class == OBERON_TYPE_ARRAY)
1132 {
1133 if(pref -> base -> class != OBERON_TYPE_CHAR)
1134 {
1135 error = true;
1136 }
1137 }
1138 else
1139 {
1140 error = true;
1141 }
1142 }
1143 else if(expr -> result -> class == OBERON_TYPE_INTEGER)
1144 {
1145 if(pref -> class != OBERON_TYPE_REAL)
1146 {
1147 error = true;
1148 }
1149 }
1150 else
1151 {
1152 error = true;
1153 }
1154 }
1155
1156 if(error)
1157 {
1158 oberon_error(ctx, "oberon_autocast_to: incompatible types");
1159 }
1160
1161 if(pref -> class == OBERON_TYPE_CHAR)
1162 {
1163 if(expr -> result -> class == OBERON_TYPE_STRING)
1164 {
1165 int c = expr -> item.string[0];
1166 expr = oberon_new_item(MODE_CHAR, ctx -> char_type, true);
1167 expr -> item.integer = c;
1168 }
1169 }
1170 else if(pref -> class == OBERON_TYPE_INTEGER || pref -> class == OBERON_TYPE_REAL)
1171 {
1172 if(expr -> result -> size > pref -> size)
1173 {
1174 oberon_error(ctx, "incompatible size");
1175 }
1176 else
1177 {
1178 expr = oberon_cast_expr(ctx, expr, pref);
1179 }
1180 }
1181 else if(pref -> class == OBERON_TYPE_RECORD)
1182 {
1183 oberon_check_record_compatibility(ctx, expr -> result, pref);
1184 expr = oberno_make_record_cast(ctx, expr, pref);
1185 }
1186 else if(pref -> class == OBERON_TYPE_POINTER)
1187 {
1188 assert(pref -> base);
1189 if(expr -> result -> class == OBERON_TYPE_NIL)
1190 {
1191 // do nothing
1192 }
1193 else if(expr -> result -> base -> class == OBERON_TYPE_RECORD)
1194 {
1195 oberon_check_record_compatibility(ctx, expr -> result, pref);
1196 expr = oberno_make_record_cast(ctx, expr, pref);
1197 }
1198 else if(expr -> result -> base != pref -> base)
1199 {
1200 oberon_error(ctx, "incompatible pointer types");
1201 }
1202 }
1203
1204 return expr;
1205 }
1206
1207 static void
1208 oberon_autocast_binary_op(oberon_context_t * ctx, oberon_expr_t ** ea, oberon_expr_t ** eb)
1209 {
1210 oberon_type_t * a = (*ea) -> result;
1211 oberon_type_t * b = (*eb) -> result;
1212 oberon_type_t * preq = oberon_get_equal_expr_type(ctx, a, b);
1213 *ea = oberon_autocast_to(ctx, *ea, preq);
1214 *eb = oberon_autocast_to(ctx, *eb, preq);
1215 }
1216
1217 static void
1218 oberon_autocast_call(oberon_context_t * ctx, oberon_item_t * desig)
1219 {
1220 if(desig -> mode != MODE_CALL)
1221 {
1222 oberon_error(ctx, "expected mode CALL");
1223 }
1224
1225 oberon_type_t * fn = desig -> parent -> result;
1226 int num_args = desig -> num_args;
1227 int num_decl = fn -> num_decl;
1228
1229 if(num_args < num_decl)
1230 {
1231 oberon_error(ctx, "too few arguments");
1232 }
1233 else if(num_args > num_decl)
1234 {
1235 oberon_error(ctx, "too many arguments");
1236 }
1237
1238 /* Делаем проверку на запись и делаем автокаст */
1239 oberon_expr_t * casted[num_args];
1240 oberon_expr_t * arg = desig -> args;
1241 oberon_object_t * param = fn -> decl;
1242 for(int i = 0; i < num_args; i++)
1243 {
1244 if(param -> class == OBERON_CLASS_VAR_PARAM)
1245 {
1246 if(arg -> result != param -> type)
1247 {
1248 oberon_error(ctx, "incompatible type");
1249 }
1250 if(arg -> read_only)
1251 {
1252 oberon_error(ctx, "assign to read-only var");
1253 }
1254 casted[i] = arg;
1255 }
1256 else
1257 {
1258 casted[i] = oberon_autocast_to(ctx, arg, param -> type);
1259 }
1260
1261 arg = arg -> next;
1262 param = param -> next;
1263 }
1264
1265 /* Создаём новый список выражений */
1266 if(num_args > 0)
1267 {
1268 arg = casted[0];
1269 for(int i = 0; i < num_args - 1; i++)
1270 {
1271 casted[i] -> next = casted[i + 1];
1272 }
1273 desig -> args = arg;
1274 }
1275 }
1276
1277 static oberon_expr_t *
1278 oberon_make_call_func(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1279 {
1280 oberon_type_t * signature = item -> result;
1281 if(signature -> class != OBERON_TYPE_PROCEDURE)
1282 {
1283 oberon_error(ctx, "not a procedure");
1284 }
1285
1286 oberon_expr_t * call;
1287
1288 if(signature -> sysproc)
1289 {
1290 if(signature -> genfunc == NULL)
1291 {
1292 oberon_error(ctx, "not a function-procedure");
1293 }
1294
1295 call = signature -> genfunc(ctx, num_args, list_args);
1296 }
1297 else
1298 {
1299 if(signature -> base -> class == OBERON_TYPE_NOTYPE)
1300 {
1301 oberon_error(ctx, "attempt to call procedure in expression");
1302 }
1303
1304 call = oberon_new_item(MODE_CALL, signature -> base, true);
1305 call -> item.parent = item;
1306 call -> item.num_args = num_args;
1307 call -> item.args = list_args;
1308 oberon_autocast_call(ctx, (oberon_item_t *) call);
1309 }
1310
1311 return call;
1312 }
1313
1314 static void
1315 oberon_make_call_proc(oberon_context_t * ctx, oberon_item_t * item, int num_args, oberon_expr_t * list_args)
1316 {
1317 oberon_type_t * signature = item -> result;
1318 if(signature -> class != OBERON_TYPE_PROCEDURE)
1319 {
1320 oberon_error(ctx, "not a procedure");
1321 }
1322
1323 oberon_expr_t * call;
1324
1325 if(signature -> sysproc)
1326 {
1327 if(signature -> genproc == NULL)
1328 {
1329 oberon_error(ctx, "not a procedure");
1330 }
1331
1332 signature -> genproc(ctx, num_args, list_args);
1333 }
1334 else
1335 {
1336 if(signature -> base -> class != OBERON_TYPE_NOTYPE)
1337 {
1338 oberon_error(ctx, "attempt to call function as non-typed procedure");
1339 }
1340
1341 call = oberon_new_item(MODE_CALL, signature -> base, true);
1342 call -> item.parent = item;
1343 call -> item.num_args = num_args;
1344 call -> item.args = list_args;
1345 oberon_autocast_call(ctx, (oberon_item_t *) call);
1346 oberon_generate_call_proc(ctx, call);
1347 }
1348 }
1349
1350 #define ISEXPR(x) \
1351 (((x) == PLUS) \
1352 || ((x) == MINUS) \
1353 || ((x) == IDENT) \
1354 || ((x) == INTEGER) \
1355 || ((x) == REAL) \
1356 || ((x) == CHAR) \
1357 || ((x) == STRING) \
1358 || ((x) == NIL) \
1359 || ((x) == LPAREN) \
1360 || ((x) == NOT))
1361
1362 static oberon_expr_t *
1363 oberno_make_dereferencing(oberon_context_t * ctx, oberon_expr_t * expr)
1364 {
1365 if(expr -> result -> class != OBERON_TYPE_POINTER)
1366 {
1367 oberon_error(ctx, "not a pointer");
1368 }
1369
1370 assert(expr -> is_item);
1371
1372 oberon_expr_t * selector;
1373 selector = oberon_new_item(MODE_DEREF, expr -> result -> base, expr -> read_only);
1374 selector -> item.parent = (oberon_item_t *) expr;
1375
1376 return selector;
1377 }
1378
1379 static oberon_expr_t *
1380 oberon_make_array_selector(oberon_context_t * ctx, oberon_expr_t * desig, oberon_expr_t * index)
1381 {
1382 if(desig -> result -> class == OBERON_TYPE_POINTER)
1383 {
1384 desig = oberno_make_dereferencing(ctx, desig);
1385 }
1386
1387 assert(desig -> is_item);
1388
1389 if(desig -> result -> class != OBERON_TYPE_ARRAY)
1390 {
1391 oberon_error(ctx, "not array");
1392 }
1393
1394 oberon_type_t * base;
1395 base = desig -> result -> base;
1396
1397 if(index -> result -> class != OBERON_TYPE_INTEGER)
1398 {
1399 oberon_error(ctx, "index must be integer");
1400 }
1401
1402 // Статическая проверка границ массива
1403 if(desig -> result -> size != 0)
1404 {
1405 if(index -> is_item)
1406 {
1407 if(index -> item.mode == MODE_INTEGER)
1408 {
1409 int arr_size = desig -> result -> size;
1410 int index_int = index -> item.integer;
1411 if(index_int < 0 || index_int > arr_size - 1)
1412 {
1413 oberon_error(ctx, "not in range (dimension size 0..%i)", arr_size - 1);
1414 }
1415 }
1416 }
1417 }
1418
1419 oberon_expr_t * selector;
1420 selector = oberon_new_item(MODE_INDEX, base, desig -> read_only);
1421 selector -> item.parent = (oberon_item_t *) desig;
1422 selector -> item.num_args = 1;
1423 selector -> item.args = index;
1424
1425 return selector;
1426 }
1427
1428 static oberon_expr_t *
1429 oberon_make_record_selector(oberon_context_t * ctx, oberon_expr_t * expr, char * name)
1430 {
1431 if(expr -> result -> class == OBERON_TYPE_POINTER)
1432 {
1433 expr = oberno_make_dereferencing(ctx, expr);
1434 }
1435
1436 assert(expr -> is_item);
1437
1438 if(expr -> result -> class != OBERON_TYPE_RECORD)
1439 {
1440 oberon_error(ctx, "not record");
1441 }
1442
1443 oberon_type_t * rec = expr -> result;
1444
1445 oberon_object_t * field;
1446 field = oberon_find_object(rec -> scope, name, true);
1447
1448 if(field -> export == 0)
1449 {
1450 if(field -> module != ctx -> mod)
1451 {
1452 oberon_error(ctx, "field not exported");
1453 }
1454 }
1455
1456 int read_only = expr -> read_only;
1457 if(field -> read_only)
1458 {
1459 if(field -> module != ctx -> mod)
1460 {
1461 read_only = 1;
1462 }
1463 }
1464
1465 oberon_expr_t * selector;
1466 selector = oberon_new_item(MODE_FIELD, field -> type, read_only);
1467 selector -> item.var = field;
1468 selector -> item.parent = (oberon_item_t *) expr;
1469
1470 return selector;
1471 }
1472
1473 #define ISSELECTOR(x) \
1474 (((x) == LBRACK) \
1475 || ((x) == DOT) \
1476 || ((x) == UPARROW) \
1477 || ((x) == LPAREN))
1478
1479 static oberon_object_t *
1480 oberon_qualident(oberon_context_t * ctx, char ** xname, int check)
1481 {
1482 char * name;
1483 oberon_object_t * x;
1484
1485 name = oberon_assert_ident(ctx);
1486 x = oberon_find_object(ctx -> decl, name, check);
1487
1488 if(x != NULL)
1489 {
1490 if(x -> class == OBERON_CLASS_MODULE)
1491 {
1492 oberon_assert_token(ctx, DOT);
1493 name = oberon_assert_ident(ctx);
1494 /* Наличие объектов в левых модулях всегда проверяется */
1495 x = oberon_find_object(x -> module -> decl, name, 1);
1496
1497 if(x -> export == 0)
1498 {
1499 oberon_error(ctx, "not exported");
1500 }
1501 }
1502 }
1503
1504 if(xname)
1505 {
1506 *xname = name;
1507 }
1508
1509 return x;
1510 }
1511
1512 static oberon_expr_t *
1513 oberon_ident_item(oberon_context_t * ctx, char * name)
1514 {
1515 bool read_only;
1516 oberon_object_t * x;
1517 oberon_expr_t * expr;
1518
1519 x = oberon_find_object(ctx -> decl, name, true);
1520
1521 read_only = false;
1522 if(x -> class == OBERON_CLASS_CONST || x -> class == OBERON_CLASS_PROC)
1523 {
1524 read_only = true;
1525 }
1526
1527 expr = oberon_new_item(MODE_VAR, x -> type, read_only);
1528 expr -> item.var = x;
1529 return expr;
1530 }
1531
1532 static oberon_expr_t *
1533 oberon_qualident_expr(oberon_context_t * ctx)
1534 {
1535 oberon_object_t * var;
1536 oberon_expr_t * expr;
1537
1538 var = oberon_qualident(ctx, NULL, 1);
1539
1540 int read_only = 0;
1541 if(var -> read_only)
1542 {
1543 if(var -> module != ctx -> mod)
1544 {
1545 read_only = 1;
1546 }
1547 }
1548
1549 switch(var -> class)
1550 {
1551 case OBERON_CLASS_CONST:
1552 // TODO copy value
1553 expr = (oberon_expr_t *) var -> value;
1554 break;
1555 case OBERON_CLASS_TYPE:
1556 expr = oberon_new_item(MODE_TYPE, var -> type, read_only);
1557 break;
1558 case OBERON_CLASS_VAR:
1559 case OBERON_CLASS_VAR_PARAM:
1560 case OBERON_CLASS_PARAM:
1561 expr = oberon_new_item(MODE_VAR, var -> type, read_only);
1562 break;
1563 case OBERON_CLASS_PROC:
1564 expr = oberon_new_item(MODE_VAR, var -> type, true);
1565 break;
1566 default:
1567 oberon_error(ctx, "invalid designator");
1568 break;
1569 }
1570
1571 expr -> item.var = var;
1572
1573 return expr;
1574 }
1575
1576 static void
1577 oberon_check_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_type_t * type)
1578 {
1579 /* Охрана типа применима, если */
1580 /* 1. v - параметр-переменная типа запись, или v - указатель, и если */
1581 /* 2. T - расширение статического типа v */
1582
1583 if(expr -> is_item
1584 && expr -> item.mode == MODE_VAR
1585 && expr -> item.var -> class == OBERON_CLASS_VAR_PARAM)
1586 {
1587 // accept
1588 }
1589 else if(expr -> result -> class == OBERON_TYPE_POINTER
1590 || expr -> result -> class == OBERON_TYPE_RECORD)
1591 {
1592 // accept
1593 }
1594 else
1595 {
1596 oberon_error(ctx, "guard type used only with var-param or pointers");
1597 }
1598
1599 oberon_check_record_compatibility(ctx, type, expr -> result);
1600 }
1601
1602 static oberon_expr_t *
1603 oberon_make_type_guard(oberon_context_t * ctx, oberon_expr_t * expr, oberon_object_t * objtype)
1604 {
1605 oberon_type_t * type;
1606
1607 if(objtype -> class != OBERON_CLASS_TYPE)
1608 {
1609 oberon_error(ctx, "must be type");
1610 }
1611 type = objtype -> type;
1612
1613 oberon_check_type_guard(ctx, expr, type);
1614 return oberno_make_record_cast(ctx, expr, objtype -> type);
1615 }
1616
1617 static oberon_expr_t *
1618 oberon_designator(oberon_context_t * ctx)
1619 {
1620 char * name;
1621 oberon_expr_t * expr;
1622 oberon_object_t * objtype;
1623
1624 expr = oberon_qualident_expr(ctx);
1625
1626 while(expr -> result -> class != OBERON_TYPE_PROCEDURE && ISSELECTOR(ctx -> token))
1627 {
1628 switch(ctx -> token)
1629 {
1630 case DOT:
1631 oberon_assert_token(ctx, DOT);
1632 name = oberon_assert_ident(ctx);
1633 expr = oberon_make_record_selector(ctx, expr, name);
1634 break;
1635 case LBRACK:
1636 oberon_assert_token(ctx, LBRACK);
1637 int num_indexes = 0;
1638 oberon_expr_t * indexes = NULL;
1639 oberon_expr_list(ctx, &num_indexes, &indexes, 0);
1640 oberon_assert_token(ctx, RBRACK);
1641
1642 for(int i = 0; i < num_indexes; i++)
1643 {
1644 expr = oberon_make_array_selector(ctx, expr, indexes);
1645 indexes = indexes -> next;
1646 }
1647 break;
1648 case UPARROW:
1649 oberon_assert_token(ctx, UPARROW);
1650 expr = oberno_make_dereferencing(ctx, expr);
1651 break;
1652 case LPAREN:
1653 oberon_assert_token(ctx, LPAREN);
1654 objtype = oberon_qualident(ctx, NULL, true);
1655 oberon_assert_token(ctx, RPAREN);
1656 expr = oberon_make_type_guard(ctx, expr, objtype);
1657 break;
1658 default:
1659 oberon_error(ctx, "oberon_designator: wat");
1660 break;
1661 }
1662 }
1663
1664 return expr;
1665 }
1666
1667 static oberon_expr_t *
1668 oberon_opt_func_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1669 {
1670 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1671 if(ctx -> token == LPAREN)
1672 {
1673 oberon_assert_token(ctx, LPAREN);
1674
1675 int num_args = 0;
1676 oberon_expr_t * arguments = NULL;
1677
1678 if(ISEXPR(ctx -> token))
1679 {
1680 oberon_expr_list(ctx, &num_args, &arguments, 0);
1681 }
1682
1683 assert(expr -> is_item == 1);
1684 expr = oberon_make_call_func(ctx, (oberon_item_t *) expr, num_args, arguments);
1685
1686 oberon_assert_token(ctx, RPAREN);
1687 }
1688
1689 return expr;
1690 }
1691
1692 static void
1693 oberon_opt_proc_parens(oberon_context_t * ctx, oberon_expr_t * expr)
1694 {
1695 assert(expr -> is_item);
1696
1697 int num_args = 0;
1698 oberon_expr_t * arguments = NULL;
1699
1700 if(ctx -> token == LPAREN)
1701 {
1702 oberon_assert_token(ctx, LPAREN);
1703
1704 if(ISEXPR(ctx -> token))
1705 {
1706 oberon_expr_list(ctx, &num_args, &arguments, 0);
1707 }
1708
1709 oberon_assert_token(ctx, RPAREN);
1710 }
1711
1712 /* Вызов происходит даже без скобок */
1713 oberon_make_call_proc(ctx, (oberon_item_t *) expr, num_args, arguments);
1714 }
1715
1716 static oberon_type_t *
1717 oberon_get_type_of_int_value(oberon_context_t * ctx, int64_t i)
1718 {
1719 if(i >= -128 && i <= 127)
1720 {
1721 return ctx -> byte_type;
1722 }
1723 else if(i >= -32768 && i <= 32767)
1724 {
1725 return ctx -> shortint_type;
1726 }
1727 else if(i >= -2147483648 && i <= 2147483647)
1728 {
1729 return ctx -> int_type;
1730 }
1731 else
1732 {
1733 return ctx -> longint_type;
1734 }
1735 }
1736
1737 static oberon_expr_t *
1738 oberon_integer_item(oberon_context_t * ctx, int64_t i)
1739 {
1740 oberon_expr_t * expr;
1741 oberon_type_t * result;
1742 result = oberon_get_type_of_int_value(ctx, i);
1743 expr = oberon_new_item(MODE_INTEGER, result, true);
1744 expr -> item.integer = i;
1745 return expr;
1746 }
1747
1748 static oberon_expr_t *
1749 oberon_element(oberon_context_t * ctx)
1750 {
1751 oberon_expr_t * e1;
1752 oberon_expr_t * e2;
1753
1754 e1 = oberon_expr(ctx);
1755 if(e1 -> result -> class != OBERON_TYPE_INTEGER)
1756 {
1757 oberon_error(ctx, "expected integer");
1758 }
1759
1760 e2 = NULL;
1761 if(ctx -> token == DOTDOT)
1762 {
1763 oberon_assert_token(ctx, DOTDOT);
1764 e2 = oberon_expr(ctx);
1765 if(e2 -> result -> class != OBERON_TYPE_INTEGER)
1766 {
1767 oberon_error(ctx, "expected integer");
1768 }
1769 }
1770
1771 oberon_expr_t * set;
1772 set = oberon_new_operator(OP_RANGE, ctx -> set_type, e1, e2);
1773 return set;
1774 }
1775
1776 static oberon_expr_t *
1777 oberon_set(oberon_context_t * ctx)
1778 {
1779 oberon_expr_t * set;
1780 oberon_expr_t * elements;
1781 set = oberon_new_item(MODE_SET, ctx -> set_type, true);
1782 set -> item.integer = 0;
1783
1784 oberon_assert_token(ctx, LBRACE);
1785 if(ISEXPR(ctx -> token))
1786 {
1787 elements = oberon_element(ctx);
1788 set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements);
1789 while(ctx -> token == COMMA)
1790 {
1791 oberon_assert_token(ctx, COMMA);
1792 elements = oberon_element(ctx);
1793 set = oberon_new_operator(OP_UNION, ctx -> set_type, set, elements);
1794 }
1795 }
1796 oberon_assert_token(ctx, RBRACE);
1797
1798 return set;
1799 }
1800
1801 static oberon_expr_t *
1802 oberon_make_boolean(oberon_context_t * ctx, bool cond)
1803 {
1804 oberon_expr_t * expr;
1805 expr = oberon_new_item(MODE_BOOLEAN, ctx -> bool_type, true);
1806 expr -> item.integer = cond;
1807 return expr;
1808 }
1809
1810 static oberon_expr_t *
1811 oberon_factor(oberon_context_t * ctx)
1812 {
1813 oberon_expr_t * expr;
1814 oberon_type_t * result;
1815
1816 switch(ctx -> token)
1817 {
1818 case IDENT:
1819 expr = oberon_designator(ctx);
1820 expr = oberon_opt_func_parens(ctx, expr);
1821 break;
1822 case INTEGER:
1823 expr = oberon_integer_item(ctx, ctx -> integer);
1824 oberon_assert_token(ctx, INTEGER);
1825 break;
1826 case CHAR:
1827 result = ctx -> char_type;
1828 expr = oberon_new_item(MODE_CHAR, result, true);
1829 expr -> item.integer = ctx -> integer;
1830 oberon_assert_token(ctx, CHAR);
1831 break;
1832 case STRING:
1833 result = ctx -> string_type;
1834 expr = oberon_new_item(MODE_STRING, result, true);
1835 expr -> item.string = ctx -> string;
1836 oberon_assert_token(ctx, STRING);
1837 break;
1838 case REAL:
1839 result = (ctx -> longmode) ? (ctx -> longreal_type) : (ctx -> real_type);
1840 expr = oberon_new_item(MODE_REAL, result, 1);
1841 expr -> item.real = ctx -> real;
1842 oberon_assert_token(ctx, REAL);
1843 break;
1844 case LBRACE:
1845 expr = oberon_set(ctx);
1846 break;
1847 case LPAREN:
1848 oberon_assert_token(ctx, LPAREN);
1849 expr = oberon_expr(ctx);
1850 oberon_assert_token(ctx, RPAREN);
1851 break;
1852 case NOT:
1853 oberon_assert_token(ctx, NOT);
1854 expr = oberon_factor(ctx);
1855 expr = oberon_make_unary_op(ctx, NOT, expr);
1856 break;
1857 case NIL:
1858 oberon_assert_token(ctx, NIL);
1859 expr = oberon_new_item(MODE_NIL, ctx -> nil_type, true);
1860 break;
1861 default:
1862 oberon_error(ctx, "invalid expression");
1863 }
1864
1865 return expr;
1866 }
1867
1868 static void
1869 oberon_autocast_to_real(oberon_context_t * ctx, oberon_expr_t ** e)
1870 {
1871 oberon_expr_t * expr = *e;
1872 if(expr -> result -> class == OBERON_TYPE_INTEGER)
1873 {
1874 if(expr -> result -> size <= ctx -> real_type -> size)
1875 {
1876 *e = oberon_cast_expr(ctx, expr, ctx -> real_type);
1877 }
1878 else
1879 {
1880 *e = oberon_cast_expr(ctx, expr, ctx -> longreal_type);
1881 }
1882 }
1883 else if(expr -> result -> class != OBERON_TYPE_REAL)
1884 {
1885 oberon_error(ctx, "required numeric type");
1886 }
1887 }
1888
1889 static bool
1890 oberon_is_numeric_type(oberon_type_t * t)
1891 {
1892 return (t -> class == OBERON_TYPE_INTEGER) || (t -> class == OBERON_TYPE_REAL);
1893 }
1894
1895 static bool
1896 oberon_is_char_type(oberon_type_t * t)
1897 {
1898 return (t -> class == OBERON_TYPE_CHAR);
1899 }
1900
1901 static bool
1902 oberon_is_string_type(oberon_type_t * t)
1903 {
1904 return (t -> class == OBERON_TYPE_STRING)
1905 || (t -> class == OBERON_TYPE_ARRAY && t -> base -> class == OBERON_TYPE_CHAR);
1906 }
1907
1908 static bool
1909 oberon_is_boolean_type(oberon_type_t * t)
1910 {
1911 return (t -> class == OBERON_TYPE_BOOLEAN);
1912 }
1913
1914 static bool
1915 oberon_is_set_type(oberon_type_t * t)
1916 {
1917 return (t -> class == OBERON_TYPE_SET);
1918 }
1919
1920 static bool
1921 oberon_is_pointer_type(oberon_type_t * t)
1922 {
1923 return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL);
1924 }
1925
1926 static bool
1927 oberon_is_procedure_type(oberon_type_t * t)
1928 {
1929 return (t -> class == OBERON_TYPE_POINTER) || (t -> class == OBERON_TYPE_NIL);
1930 }
1931
1932 static oberon_expr_t *
1933 oberon_make_bin_op(oberon_context_t * ctx, int token, oberon_expr_t * a, oberon_expr_t * b)
1934 {
1935 oberon_expr_t * expr;
1936 oberon_type_t * result;
1937
1938 bool error = false;
1939 if(token == IN)
1940 {
1941 if(a -> result -> class != OBERON_TYPE_INTEGER)
1942 {
1943 oberon_error(ctx, "must be integer");
1944 }
1945
1946 if(b -> result -> class != OBERON_TYPE_SET)
1947 {
1948 oberon_error(ctx, "must be set");
1949 }
1950
1951 result = ctx -> bool_type;
1952 expr = oberon_new_operator(OP_IN, result, a, b);
1953 }
1954 else if(token == IS)
1955 {
1956 if(b -> is_item == false || b -> item.mode != MODE_TYPE)
1957 {
1958 oberon_error(ctx, "requires type");
1959 }
1960
1961 result = ctx -> bool_type;
1962 oberon_check_type_guard(ctx, a, b -> result);
1963 expr = oberon_new_operator(OP_IS, result, a, b);
1964 }
1965 else if((token >= EQUAL && token <= GEQ) || token == OR || token == AND)
1966 {
1967 if(token >= LESS && token <= GEQ)
1968 {
1969 if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result))
1970 {
1971 // accept
1972 }
1973 else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result))
1974 {
1975 // accept
1976 }
1977 else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result))
1978 {
1979 // accept
1980 }
1981 else
1982 {
1983 oberon_error(ctx, "invalid comparation");
1984 }
1985 }
1986 else if(token == EQUAL || token == NEQ)
1987 {
1988 if(oberon_is_numeric_type(a -> result) && oberon_is_numeric_type(b -> result))
1989 {
1990 // accept
1991 }
1992 else if(oberon_is_char_type(a -> result) && oberon_is_char_type(b -> result))
1993 {
1994 // accept
1995 }
1996 else if(oberon_is_string_type(a -> result) && oberon_is_string_type(b -> result))
1997 {
1998 // accept
1999 }
2000 else if(oberon_is_boolean_type(a -> result) && oberon_is_boolean_type(b -> result))
2001 {
2002 // accept
2003 }
2004 else if(oberon_is_set_type(a -> result) && oberon_is_set_type(b -> result))
2005 {
2006 // accept
2007 }
2008 else if(oberon_is_pointer_type(a -> result) && oberon_is_pointer_type(b -> result))
2009 {
2010 // accept
2011 }
2012 else if(oberon_is_procedure_type(a -> result) && oberon_is_procedure_type(b -> result))
2013 {
2014 // accept
2015 }
2016 else
2017 {
2018 oberon_error(ctx, "invalid comparation");
2019 }
2020 }
2021 else if(token == AND || token == OR)
2022 {
2023 if(!oberon_is_boolean_type(a -> result) || !oberon_is_boolean_type(b -> result))
2024 {
2025 oberon_error(ctx, "invalid comparation");
2026 }
2027 }
2028 else
2029 {
2030 oberon_error(ctx, "wat");
2031 }
2032
2033 oberon_autocast_binary_op(ctx, &a, &b);
2034 result = ctx -> bool_type;
2035
2036 if(token == EQUAL)
2037 {
2038 expr = oberon_new_operator(OP_EQ, result, a, b);
2039 }
2040 else if(token == NEQ)
2041 {
2042 expr = oberon_new_operator(OP_NEQ, result, a, b);
2043 }
2044 else if(token == LESS)
2045 {
2046 expr = oberon_new_operator(OP_LSS, result, a, b);
2047 }
2048 else if(token == LEQ)
2049 {
2050 expr = oberon_new_operator(OP_LEQ, result, a, b);
2051 }
2052 else if(token == GREAT)
2053 {
2054 expr = oberon_new_operator(OP_GRT, result, a, b);
2055 }
2056 else if(token == GEQ)
2057 {
2058 expr = oberon_new_operator(OP_GEQ, result, a, b);
2059 }
2060 else if(token == OR)
2061 {
2062 expr = oberon_new_operator(OP_LOGIC_OR, result, a, b);
2063 }
2064 else if(token == AND)
2065 {
2066 expr = oberon_new_operator(OP_LOGIC_AND, result, a, b);
2067 }
2068 else
2069 {
2070 oberon_error(ctx, "oberon_make_bin_op: bool wat");
2071 }
2072 }
2073 else if(token == SLASH)
2074 {
2075 if(a -> result -> class == OBERON_TYPE_SET
2076 || b -> result -> class == OBERON_TYPE_SET)
2077 {
2078 oberon_autocast_binary_op(ctx, &a, &b);
2079 result = a -> result;
2080 expr = oberon_new_operator(OP_SYM_DIFFERENCE, result, a, b);
2081 }
2082 else
2083 {
2084 oberon_autocast_to_real(ctx, &a);
2085 oberon_autocast_to_real(ctx, &b);
2086 oberon_autocast_binary_op(ctx, &a, &b);
2087 result = a -> result;
2088 expr = oberon_new_operator(OP_DIV, result, a, b);
2089 }
2090 }
2091 else if(token == DIV)
2092 {
2093 if(a -> result -> class != OBERON_TYPE_INTEGER
2094 || b -> result -> class != OBERON_TYPE_INTEGER)
2095 {
2096 oberon_error(ctx, "operator DIV requires integer type");
2097 }
2098
2099 oberon_autocast_binary_op(ctx, &a, &b);
2100 expr = oberon_new_operator(OP_DIV, a -> result, a, b);
2101 }
2102 else
2103 {
2104 oberon_autocast_binary_op(ctx, &a, &b);
2105 result = a -> result;
2106 if(result -> class == OBERON_TYPE_SET)
2107 {
2108 switch(token)
2109 {
2110 case PLUS:
2111 expr = oberon_new_operator(OP_UNION, result, a, b);
2112 break;
2113 case MINUS:
2114 expr = oberon_new_operator(OP_DIFFERENCE, result, a, b);
2115 break;
2116 case STAR:
2117 expr = oberon_new_operator(OP_INTERSECTION, result, a, b);
2118 break;
2119 default:
2120 error = true;
2121 break;
2122 }
2123 }
2124 else if(result -> class == OBERON_TYPE_INTEGER
2125 || result -> class == OBERON_TYPE_REAL)
2126 {
2127 switch(token)
2128 {
2129 case PLUS:
2130 expr = oberon_new_operator(OP_ADD, result, a, b);
2131 break;
2132 case MINUS:
2133 expr = oberon_new_operator(OP_SUB, result, a, b);
2134 break;
2135 case STAR:
2136 expr = oberon_new_operator(OP_MUL, result, a, b);
2137 break;
2138 case MOD:
2139 expr = oberon_new_operator(OP_MOD, result, a, b);
2140 break;
2141 default:
2142 error = true;
2143 break;
2144 }
2145 }
2146 else
2147 {
2148 error = true;
2149 }
2150 }
2151
2152 if(error)
2153 {
2154 oberon_error(ctx, "invalid operation");
2155 }
2156
2157 return expr;
2158 }
2159
2160 #define ISMULOP(x) \
2161 ((x) >= STAR && (x) <= AND)
2162
2163 static oberon_expr_t *
2164 oberon_term_expr(oberon_context_t * ctx)
2165 {
2166 oberon_expr_t * expr;
2167
2168 expr = oberon_factor(ctx);
2169 while(ISMULOP(ctx -> token))
2170 {
2171 int token = ctx -> token;
2172 oberon_read_token(ctx);
2173
2174 oberon_expr_t * inter = oberon_factor(ctx);
2175 expr = oberon_make_bin_op(ctx, token, expr, inter);
2176 }
2177
2178 return expr;
2179 }
2180
2181 #define ISADDOP(x) \
2182 ((x) >= PLUS && (x) <= OR)
2183
2184 static oberon_expr_t *
2185 oberon_simple_expr(oberon_context_t * ctx)
2186 {
2187 oberon_expr_t * expr;
2188
2189 int minus = 0;
2190 if(ctx -> token == PLUS)
2191 {
2192 minus = 0;
2193 oberon_assert_token(ctx, PLUS);
2194 }
2195 else if(ctx -> token == MINUS)
2196 {
2197 minus = 1;
2198 oberon_assert_token(ctx, MINUS);
2199 }
2200
2201 expr = oberon_term_expr(ctx);
2202
2203 if(minus)
2204 {
2205 expr = oberon_make_unary_op(ctx, MINUS, expr);
2206 }
2207
2208 while(ISADDOP(ctx -> token))
2209 {
2210 int token = ctx -> token;
2211 oberon_read_token(ctx);
2212
2213 oberon_expr_t * inter = oberon_term_expr(ctx);
2214 expr = oberon_make_bin_op(ctx, token, expr, inter);
2215 }
2216
2217 return expr;
2218 }
2219
2220 #define ISRELATION(x) \
2221 ((x) >= EQUAL && (x) <= IS)
2222
2223 static oberon_expr_t *
2224 oberon_expr(oberon_context_t * ctx)
2225 {
2226 oberon_expr_t * expr;
2227
2228 expr = oberon_simple_expr(ctx);
2229 while(ISRELATION(ctx -> token))
2230 {
2231 int token = ctx -> token;
2232 oberon_read_token(ctx);
2233
2234 oberon_expr_t * inter = oberon_simple_expr(ctx);
2235 expr = oberon_make_bin_op(ctx, token, expr, inter);
2236 }
2237
2238 return expr;
2239 }
2240
2241 static void
2242 oberon_check_const(oberon_context_t * ctx, oberon_expr_t * expr)
2243 {
2244 if(expr -> is_item == 0)
2245 {
2246 oberon_error(ctx, "const expression are required");
2247 }
2248
2249 switch(expr -> item.mode)
2250 {
2251 case MODE_INTEGER:
2252 case MODE_BOOLEAN:
2253 case MODE_NIL:
2254 case MODE_REAL:
2255 case MODE_CHAR:
2256 case MODE_STRING:
2257 case MODE_TYPE:
2258 /* accept */
2259 break;
2260 default:
2261 oberon_error(ctx, "const expression are required");
2262 break;
2263 }
2264 }
2265
2266 static oberon_item_t *
2267 oberon_const_expr(oberon_context_t * ctx)
2268 {
2269 oberon_expr_t * expr;
2270 expr = oberon_expr(ctx);
2271 oberon_check_const(ctx, expr);
2272 return (oberon_item_t *) expr;
2273 }
2274
2275 // =======================================================================
2276 // PARSER
2277 // =======================================================================
2278
2279 static void oberon_decl_seq(oberon_context_t * ctx);
2280 static void oberon_statement_seq(oberon_context_t * ctx);
2281 static void oberon_initialize_decl(oberon_context_t * ctx);
2282
2283 static void
2284 oberon_expect_token(oberon_context_t * ctx, int token)
2285 {
2286 if(ctx -> token != token)
2287 {
2288 oberon_error(ctx, "unexpected token %i (%i)", ctx -> token, token);
2289 }
2290 }
2291
2292 static void
2293 oberon_assert_token(oberon_context_t * ctx, int token)
2294 {
2295 oberon_expect_token(ctx, token);
2296 oberon_read_token(ctx);
2297 }
2298
2299 static char *
2300 oberon_assert_ident(oberon_context_t * ctx)
2301 {
2302 oberon_expect_token(ctx, IDENT);
2303 char * ident = ctx -> string;
2304 oberon_read_token(ctx);
2305 return ident;
2306 }
2307
2308 static void
2309 oberon_def(oberon_context_t * ctx, int * export, int * read_only)
2310 {
2311 switch(ctx -> token)
2312 {
2313 case STAR:
2314 oberon_assert_token(ctx, STAR);
2315 *export = 1;
2316 *read_only = 0;
2317 break;
2318 case MINUS:
2319 oberon_assert_token(ctx, MINUS);
2320 *export = 1;
2321 *read_only = 1;
2322 break;
2323 default:
2324 *export = 0;
2325 *read_only = 0;
2326 break;
2327 }
2328 }
2329
2330 static oberon_object_t *
2331 oberon_ident_def(oberon_context_t * ctx, int class, bool check_upscope)
2332 {
2333 char * name;
2334 int export;
2335 int read_only;
2336 oberon_object_t * x;
2337
2338 name = oberon_assert_ident(ctx);
2339 oberon_def(ctx, &export, &read_only);
2340
2341 x = oberon_define_object(ctx -> decl, name, class, export, read_only, check_upscope);
2342 return x;
2343 }
2344
2345 static void
2346 oberon_ident_list(oberon_context_t * ctx, int class, bool check_upscope, int * num, oberon_object_t ** list)
2347 {
2348 *num = 1;
2349 *list = oberon_ident_def(ctx, class, check_upscope);
2350 while(ctx -> token == COMMA)
2351 {
2352 oberon_assert_token(ctx, COMMA);
2353 oberon_ident_def(ctx, class, check_upscope);
2354 *num += 1;
2355 }
2356 }
2357
2358 static void
2359 oberon_var_decl(oberon_context_t * ctx)
2360 {
2361 int num;
2362 oberon_object_t * list;
2363 oberon_type_t * type;
2364 type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2365
2366 oberon_ident_list(ctx, OBERON_CLASS_VAR, false, &num, &list);
2367 oberon_assert_token(ctx, COLON);
2368 oberon_type(ctx, &type);
2369
2370 oberon_object_t * var = list;
2371 for(int i = 0; i < num; i++)
2372 {
2373 var -> type = type;
2374 var = var -> next;
2375 }
2376 }
2377
2378 static oberon_object_t *
2379 oberon_fp_section(oberon_context_t * ctx, int * num_decl)
2380 {
2381 int class = OBERON_CLASS_PARAM;
2382 if(ctx -> token == VAR)
2383 {
2384 oberon_read_token(ctx);
2385 class = OBERON_CLASS_VAR_PARAM;
2386 }
2387
2388 int num;
2389 oberon_object_t * list;
2390 oberon_ident_list(ctx, class, false, &num, &list);
2391
2392 oberon_assert_token(ctx, COLON);
2393
2394 oberon_type_t * type;
2395 type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2396 oberon_type(ctx, &type);
2397
2398 oberon_object_t * param = list;
2399 for(int i = 0; i < num; i++)
2400 {
2401 param -> type = type;
2402 param = param -> next;
2403 }
2404
2405 *num_decl += num;
2406 return list;
2407 }
2408
2409 #define ISFPSECTION \
2410 ((ctx -> token == VAR) || (ctx -> token == IDENT))
2411
2412 static void
2413 oberon_formal_pars(oberon_context_t * ctx, oberon_type_t * signature)
2414 {
2415 oberon_assert_token(ctx, LPAREN);
2416
2417 if(ISFPSECTION)
2418 {
2419 signature -> decl = oberon_fp_section(ctx, &signature -> num_decl);
2420 while(ctx -> token == SEMICOLON)
2421 {
2422 oberon_assert_token(ctx, SEMICOLON);
2423 oberon_fp_section(ctx, &signature -> num_decl);
2424 }
2425 }
2426
2427 oberon_assert_token(ctx, RPAREN);
2428
2429 if(ctx -> token == COLON)
2430 {
2431 oberon_assert_token(ctx, COLON);
2432
2433 oberon_object_t * typeobj;
2434 typeobj = oberon_qualident(ctx, NULL, 1);
2435 if(typeobj -> class != OBERON_CLASS_TYPE)
2436 {
2437 oberon_error(ctx, "function result is not type");
2438 }
2439 signature -> base = typeobj -> type;
2440 }
2441 }
2442
2443 static void
2444 oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type)
2445 {
2446 oberon_type_t * signature;
2447 signature = *type;
2448 signature -> class = OBERON_TYPE_PROCEDURE;
2449 signature -> num_decl = 0;
2450 signature -> base = ctx -> notype_type;
2451 signature -> decl = NULL;
2452
2453 if(ctx -> token == LPAREN)
2454 {
2455 oberon_formal_pars(ctx, signature);
2456 }
2457 }
2458
2459 static void
2460 oberon_compare_signatures(oberon_context_t * ctx, oberon_type_t * a, oberon_type_t * b)
2461 {
2462 if(a -> num_decl != b -> num_decl)
2463 {
2464 oberon_error(ctx, "number parameters not matched");
2465 }
2466
2467 int num_param = a -> num_decl;
2468 oberon_object_t * param_a = a -> decl;
2469 oberon_object_t * param_b = b -> decl;
2470 for(int i = 0; i < num_param; i++)
2471 {
2472 if(strcmp(param_a -> name, param_b -> name) != 0)
2473 {
2474 oberon_error(ctx, "param %i name not matched", i + 1);
2475 }
2476
2477 if(param_a -> type != param_b -> type)
2478 {
2479 oberon_error(ctx, "param %i type not matched", i + 1);
2480 }
2481
2482 param_a = param_a -> next;
2483 param_b = param_b -> next;
2484 }
2485 }
2486
2487 static void
2488 oberon_make_return(oberon_context_t * ctx, oberon_expr_t * expr)
2489 {
2490 oberon_object_t * proc = ctx -> decl -> parent;
2491 oberon_type_t * result_type = proc -> type -> base;
2492
2493 if(result_type -> class == OBERON_TYPE_NOTYPE)
2494 {
2495 if(expr != NULL)
2496 {
2497 oberon_error(ctx, "procedure has no result type");
2498 }
2499 }
2500 else
2501 {
2502 if(expr == NULL)
2503 {
2504 oberon_error(ctx, "procedure requires expression on result");
2505 }
2506
2507 expr = oberon_autocast_to(ctx, expr, result_type);
2508 }
2509
2510 proc -> has_return = 1;
2511
2512 oberon_generate_return(ctx, expr);
2513 }
2514
2515 static void
2516 oberon_proc_decl_body(oberon_context_t * ctx, oberon_object_t * proc)
2517 {
2518 oberon_assert_token(ctx, SEMICOLON);
2519
2520 ctx -> decl = proc -> scope;
2521
2522 oberon_decl_seq(ctx);
2523
2524 oberon_generate_begin_proc(ctx, proc);
2525
2526 if(ctx -> token == BEGIN)
2527 {
2528 oberon_assert_token(ctx, BEGIN);
2529 oberon_statement_seq(ctx);
2530 }
2531
2532 oberon_assert_token(ctx, END);
2533 char * name = oberon_assert_ident(ctx);
2534 if(strcmp(name, proc -> name) != 0)
2535 {
2536 oberon_error(ctx, "procedure name not matched");
2537 }
2538
2539 if(proc -> type -> base -> class == OBERON_TYPE_NOTYPE
2540 && proc -> has_return == 0)
2541 {
2542 oberon_make_return(ctx, NULL);
2543 }
2544
2545 if(proc -> has_return == 0)
2546 {
2547 oberon_error(ctx, "procedure requires return");
2548 }
2549
2550 oberon_generate_end_proc(ctx);
2551 oberon_close_scope(ctx -> decl);
2552 }
2553
2554 static void
2555 oberon_proc_decl(oberon_context_t * ctx)
2556 {
2557 oberon_assert_token(ctx, PROCEDURE);
2558
2559 int forward = 0;
2560 if(ctx -> token == UPARROW)
2561 {
2562 oberon_assert_token(ctx, UPARROW);
2563 forward = 1;
2564 }
2565
2566 char * name;
2567 int export;
2568 int read_only;
2569 name = oberon_assert_ident(ctx);
2570 oberon_def(ctx, &export, &read_only);
2571
2572 oberon_scope_t * proc_scope;
2573 proc_scope = oberon_open_scope(ctx);
2574 ctx -> decl -> local = 1;
2575
2576 oberon_type_t * signature;
2577 signature = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2578 oberon_opt_formal_pars(ctx, &signature);
2579
2580 //oberon_initialize_decl(ctx);
2581 oberon_generator_init_type(ctx, signature);
2582 oberon_close_scope(ctx -> decl);
2583
2584 oberon_object_t * proc;
2585 proc = oberon_find_object(ctx -> decl, name, 0);
2586 if(proc == NULL)
2587 {
2588 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, export, read_only, false);
2589 proc -> type = signature;
2590 proc -> scope = proc_scope;
2591 oberon_generator_init_proc(ctx, proc);
2592 }
2593 else
2594 {
2595 if(proc -> class != OBERON_CLASS_PROC)
2596 {
2597 oberon_error(ctx, "mult definition");
2598 }
2599
2600 if(forward == 0)
2601 {
2602 if(proc -> linked)
2603 {
2604 oberon_error(ctx, "mult procedure definition");
2605 }
2606 }
2607
2608 if(proc -> export != export || proc -> read_only != read_only)
2609 {
2610 oberon_error(ctx, "export type not matched");
2611 }
2612
2613 oberon_compare_signatures(ctx, proc -> type, signature);
2614 }
2615
2616 proc_scope -> parent = proc;
2617 oberon_object_t * param = proc_scope -> list -> next;
2618 while(param)
2619 {
2620 param -> parent = proc;
2621 param = param -> next;
2622 }
2623
2624 if(forward == 0)
2625 {
2626 proc -> linked = 1;
2627 oberon_proc_decl_body(ctx, proc);
2628 }
2629 }
2630
2631 static void
2632 oberon_const_decl(oberon_context_t * ctx)
2633 {
2634 oberon_item_t * value;
2635 oberon_object_t * constant;
2636
2637 constant = oberon_ident_def(ctx, OBERON_CLASS_CONST, false);
2638 oberon_assert_token(ctx, EQUAL);
2639 value = oberon_const_expr(ctx);
2640 constant -> value = value;
2641 }
2642
2643 static void
2644 oberon_make_array_type(oberon_context_t * ctx, oberon_expr_t * size, oberon_type_t * base, oberon_type_t ** type)
2645 {
2646 if(size -> is_item == 0)
2647 {
2648 oberon_error(ctx, "requires constant");
2649 }
2650
2651 if(size -> item.mode != MODE_INTEGER)
2652 {
2653 oberon_error(ctx, "requires integer constant");
2654 }
2655
2656 oberon_type_t * arr;
2657 arr = *type;
2658 arr -> class = OBERON_TYPE_ARRAY;
2659 arr -> size = size -> item.integer;
2660 arr -> base = base;
2661 }
2662
2663 static void
2664 oberon_qualident_type(oberon_context_t * ctx, oberon_type_t ** type)
2665 {
2666 char * name;
2667 oberon_object_t * to;
2668
2669 to = oberon_qualident(ctx, &name, 0);
2670
2671 //name = oberon_assert_ident(ctx);
2672 //to = oberon_find_object(ctx -> decl, name, 0);
2673
2674 if(to != NULL)
2675 {
2676 if(to -> class != OBERON_CLASS_TYPE)
2677 {
2678 oberon_error(ctx, "not a type");
2679 }
2680 }
2681 else
2682 {
2683 to = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, false, false, false);
2684 to -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2685 }
2686
2687 *type = to -> type;
2688 }
2689
2690 static void oberon_opt_formal_pars(oberon_context_t * ctx, oberon_type_t ** type);
2691
2692 /*
2693 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2694 */
2695
2696 static void
2697 oberon_make_multiarray(oberon_context_t * ctx, oberon_expr_t * sizes, oberon_type_t * base, oberon_type_t ** type)
2698 {
2699 if(sizes == NULL)
2700 {
2701 *type = base;
2702 return;
2703 }
2704
2705 oberon_type_t * dim;
2706 dim = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2707
2708 oberon_make_multiarray(ctx, sizes -> next, base, &dim);
2709
2710 oberon_make_array_type(ctx, sizes, dim, type);
2711 }
2712
2713 static void
2714 oberon_make_open_array(oberon_context_t * ctx, oberon_type_t * base, oberon_type_t * type)
2715 {
2716 type -> class = OBERON_TYPE_ARRAY;
2717 type -> size = 0;
2718 type -> base = base;
2719 }
2720
2721 static void
2722 oberon_field_list(oberon_context_t * ctx, oberon_type_t * rec, oberon_scope_t * modscope)
2723 {
2724 if(ctx -> token == IDENT)
2725 {
2726 int num;
2727 oberon_object_t * list;
2728 oberon_type_t * type;
2729 type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2730
2731 oberon_ident_list(ctx, OBERON_CLASS_FIELD, true, &num, &list);
2732 oberon_assert_token(ctx, COLON);
2733
2734 oberon_scope_t * current = ctx -> decl;
2735 ctx -> decl = modscope;
2736 oberon_type(ctx, &type);
2737 ctx -> decl = current;
2738
2739 oberon_object_t * field = list;
2740 for(int i = 0; i < num; i++)
2741 {
2742 field -> type = type;
2743 field = field -> next;
2744 }
2745
2746 rec -> num_decl += num;
2747 }
2748 }
2749
2750 static void
2751 oberon_type_record_body(oberon_context_t * ctx, oberon_type_t * rec)
2752 {
2753 oberon_scope_t * modscope = ctx -> mod -> decl;
2754 oberon_scope_t * oldscope = ctx -> decl;
2755 ctx -> decl = modscope;
2756
2757 if(ctx -> token == LPAREN)
2758 {
2759 oberon_assert_token(ctx, LPAREN);
2760
2761 oberon_object_t * typeobj;
2762 typeobj = oberon_qualident(ctx, NULL, true);
2763
2764 if(typeobj -> class != OBERON_CLASS_TYPE)
2765 {
2766 oberon_error(ctx, "base must be type");
2767 }
2768
2769 oberon_type_t * base = typeobj -> type;
2770 if(base -> class == OBERON_TYPE_POINTER)
2771 {
2772 base = base -> base;
2773 }
2774
2775 if(base -> class != OBERON_TYPE_RECORD)
2776 {
2777 oberon_error(ctx, "base must be record type");
2778 }
2779
2780 rec -> base = base;
2781 ctx -> decl = base -> scope;
2782
2783 oberon_assert_token(ctx, RPAREN);
2784 }
2785 else
2786 {
2787 ctx -> decl = NULL;
2788 }
2789
2790 oberon_scope_t * this_scope;
2791 this_scope = oberon_open_scope(ctx);
2792 this_scope -> local = true;
2793 this_scope -> parent = NULL;
2794 this_scope -> parent_type = rec;
2795
2796 oberon_field_list(ctx, rec, modscope);
2797 while(ctx -> token == SEMICOLON)
2798 {
2799 oberon_assert_token(ctx, SEMICOLON);
2800 oberon_field_list(ctx, rec, modscope);
2801 }
2802
2803 rec -> scope = this_scope;
2804 rec -> decl = this_scope -> list -> next;
2805 ctx -> decl = oldscope;
2806 }
2807
2808 static void
2809 oberon_type(oberon_context_t * ctx, oberon_type_t ** type)
2810 {
2811 if(ctx -> token == IDENT)
2812 {
2813 oberon_qualident_type(ctx, type);
2814 }
2815 else if(ctx -> token == ARRAY)
2816 {
2817 oberon_assert_token(ctx, ARRAY);
2818
2819 int num_sizes = 0;
2820 oberon_expr_t * sizes;
2821
2822 if(ISEXPR(ctx -> token))
2823 {
2824 oberon_expr_list(ctx, &num_sizes, &sizes, 1);
2825 }
2826
2827 oberon_assert_token(ctx, OF);
2828
2829 oberon_type_t * base;
2830 base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2831 oberon_type(ctx, &base);
2832
2833 if(num_sizes == 0)
2834 {
2835 oberon_make_open_array(ctx, base, *type);
2836 }
2837 else
2838 {
2839 oberon_make_multiarray(ctx, sizes, base, type);
2840 }
2841 }
2842 else if(ctx -> token == RECORD)
2843 {
2844 oberon_type_t * rec;
2845 rec = *type;
2846 rec -> class = OBERON_TYPE_RECORD;
2847 rec -> module = ctx -> mod;
2848
2849 oberon_assert_token(ctx, RECORD);
2850 oberon_type_record_body(ctx, rec);
2851 oberon_assert_token(ctx, END);
2852
2853 *type = rec;
2854 }
2855 else if(ctx -> token == POINTER)
2856 {
2857 oberon_assert_token(ctx, POINTER);
2858 oberon_assert_token(ctx, TO);
2859
2860 oberon_type_t * base;
2861 base = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2862 oberon_type(ctx, &base);
2863
2864 oberon_type_t * ptr;
2865 ptr = *type;
2866 ptr -> class = OBERON_TYPE_POINTER;
2867 ptr -> base = base;
2868 }
2869 else if(ctx -> token == PROCEDURE)
2870 {
2871 oberon_open_scope(ctx);
2872 oberon_assert_token(ctx, PROCEDURE);
2873 oberon_opt_formal_pars(ctx, type);
2874 oberon_close_scope(ctx -> decl);
2875 }
2876 else
2877 {
2878 oberon_error(ctx, "invalid type declaration");
2879 }
2880 }
2881
2882 static void
2883 oberon_type_decl(oberon_context_t * ctx)
2884 {
2885 char * name;
2886 oberon_object_t * newtype;
2887 oberon_type_t * type;
2888 int export;
2889 int read_only;
2890
2891 name = oberon_assert_ident(ctx);
2892 oberon_def(ctx, &export, &read_only);
2893
2894 newtype = oberon_find_object(ctx -> decl, name, 0);
2895 if(newtype == NULL)
2896 {
2897 newtype = oberon_define_object(ctx -> decl, name, OBERON_CLASS_TYPE, export, read_only, false);
2898 newtype -> type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
2899 assert(newtype -> type);
2900 }
2901 else
2902 {
2903 if(newtype -> class != OBERON_CLASS_TYPE)
2904 {
2905 oberon_error(ctx, "mult definition");
2906 }
2907
2908 if(newtype -> linked)
2909 {
2910 oberon_error(ctx, "mult definition - already linked");
2911 }
2912
2913 newtype -> export = export;
2914 newtype -> read_only = read_only;
2915 }
2916
2917 oberon_assert_token(ctx, EQUAL);
2918
2919 type = newtype -> type;
2920 oberon_type(ctx, &type);
2921
2922 if(type -> class == OBERON_TYPE_NOTYPE)
2923 {
2924 oberon_error(ctx, "recursive alias declaration");
2925 }
2926
2927 newtype -> type = type;
2928 newtype -> linked = 1;
2929 }
2930
2931 static void oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x);
2932 static void oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type);
2933
2934 static void
2935 oberon_prevent_recursive_pointer(oberon_context_t * ctx, oberon_type_t * type)
2936 {
2937 if(type -> class != OBERON_TYPE_POINTER
2938 && type -> class != OBERON_TYPE_ARRAY)
2939 {
2940 return;
2941 }
2942
2943 if(type -> recursive)
2944 {
2945 oberon_error(ctx, "recursive pointer declaration");
2946 }
2947
2948 if(type -> class == OBERON_TYPE_POINTER
2949 && type -> base -> class == OBERON_TYPE_POINTER)
2950 {
2951 oberon_error(ctx, "attempt to make pointer to pointer");
2952 }
2953
2954 type -> recursive = 1;
2955
2956 oberon_prevent_recursive_pointer(ctx, type -> base);
2957
2958 type -> recursive = 0;
2959 }
2960
2961 static void
2962 oberon_prevent_recursive_record(oberon_context_t * ctx, oberon_type_t * type)
2963 {
2964 if(type -> class != OBERON_TYPE_RECORD)
2965 {
2966 return;
2967 }
2968
2969 if(type -> recursive)
2970 {
2971 oberon_error(ctx, "recursive record declaration");
2972 }
2973
2974 type -> recursive = 1;
2975
2976 if(type -> base)
2977 {
2978 oberon_prevent_recursive_record(ctx, type -> base);
2979 }
2980
2981 int num_fields = type -> num_decl;
2982 oberon_object_t * field = type -> decl;
2983 for(int i = 0; i < num_fields; i++)
2984 {
2985 oberon_prevent_recursive_object(ctx, field);
2986 field = field -> next;
2987 }
2988
2989 type -> recursive = 0;
2990 }
2991 static void
2992 oberon_prevent_recursive_procedure(oberon_context_t * ctx, oberon_type_t * type)
2993 {
2994 if(type -> class != OBERON_TYPE_PROCEDURE)
2995 {
2996 return;
2997 }
2998
2999 if(type -> recursive)
3000 {
3001 oberon_error(ctx, "recursive procedure declaration");
3002 }
3003
3004 type -> recursive = 1;
3005
3006 int num_fields = type -> num_decl;
3007 oberon_object_t * field = type -> decl;
3008 for(int i = 0; i < num_fields; i++)
3009 {
3010 oberon_prevent_recursive_object(ctx, field);
3011 field = field -> next;
3012 }
3013
3014 type -> recursive = 0;
3015 }
3016
3017 static void
3018 oberon_prevent_recursive_array(oberon_context_t * ctx, oberon_type_t * type)
3019 {
3020 if(type -> class != OBERON_TYPE_ARRAY)
3021 {
3022 return;
3023 }
3024
3025 if(type -> recursive)
3026 {
3027 oberon_error(ctx, "recursive array declaration");
3028 }
3029
3030 type -> recursive = 1;
3031
3032 oberon_prevent_recursive_type(ctx, type -> base);
3033
3034 type -> recursive = 0;
3035 }
3036
3037 static void
3038 oberon_prevent_recursive_type(oberon_context_t * ctx, oberon_type_t * type)
3039 {
3040 if(type -> class == OBERON_TYPE_POINTER)
3041 {
3042 oberon_prevent_recursive_pointer(ctx, type);
3043 }
3044 else if(type -> class == OBERON_TYPE_RECORD)
3045 {
3046 oberon_prevent_recursive_record(ctx, type);
3047 }
3048 else if(type -> class == OBERON_TYPE_ARRAY)
3049 {
3050 oberon_prevent_recursive_array(ctx, type);
3051 }
3052 else if(type -> class == OBERON_TYPE_PROCEDURE)
3053 {
3054 oberon_prevent_recursive_procedure(ctx, type);
3055 }
3056 }
3057
3058 static void
3059 oberon_prevent_recursive_object(oberon_context_t * ctx, oberon_object_t * x)
3060 {
3061 switch(x -> class)
3062 {
3063 case OBERON_CLASS_VAR:
3064 case OBERON_CLASS_TYPE:
3065 case OBERON_CLASS_PARAM:
3066 case OBERON_CLASS_VAR_PARAM:
3067 case OBERON_CLASS_FIELD:
3068 oberon_prevent_recursive_type(ctx, x -> type);
3069 break;
3070 case OBERON_CLASS_CONST:
3071 case OBERON_CLASS_PROC:
3072 case OBERON_CLASS_MODULE:
3073 break;
3074 default:
3075 oberon_error(ctx, "oberon_prevent_recursive_object: wat");
3076 break;
3077 }
3078 }
3079
3080 static void
3081 oberon_prevent_recursive_decl(oberon_context_t * ctx)
3082 {
3083 oberon_object_t * x = ctx -> decl -> list -> next;
3084
3085 while(x)
3086 {
3087 oberon_prevent_recursive_object(ctx, x);
3088 x = x -> next;
3089 }
3090 }
3091
3092 static void oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x);
3093 static void oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type);
3094
3095 static void
3096 oberon_initialize_record_fields(oberon_context_t * ctx, oberon_type_t * type)
3097 {
3098 if(type -> class != OBERON_TYPE_RECORD)
3099 {
3100 return;
3101 }
3102
3103 int num_fields = type -> num_decl;
3104 oberon_object_t * field = type -> decl;
3105 for(int i = 0; i < num_fields; i++)
3106 {
3107 if(field -> type -> class == OBERON_TYPE_POINTER)
3108 {
3109 oberon_initialize_type(ctx, field -> type);
3110 }
3111
3112 oberon_initialize_object(ctx, field);
3113 field = field -> next;
3114 }
3115
3116 oberon_generator_init_record(ctx, type);
3117 }
3118
3119 static void
3120 oberon_initialize_type(oberon_context_t * ctx, oberon_type_t * type)
3121 {
3122 if(type -> class == OBERON_TYPE_NOTYPE)
3123 {
3124 oberon_error(ctx, "undeclarated type");
3125 }
3126
3127 if(type -> initialized)
3128 {
3129 return;
3130 }
3131
3132 type -> initialized = 1;
3133
3134 if(type -> class == OBERON_TYPE_POINTER)
3135 {
3136 oberon_initialize_type(ctx, type -> base);
3137 oberon_generator_init_type(ctx, type);
3138 }
3139 else if(type -> class == OBERON_TYPE_ARRAY)
3140 {
3141 if(type -> size != 0)
3142 {
3143 if(type -> base -> class == OBERON_TYPE_ARRAY)
3144 {
3145 if(type -> base -> size == 0)
3146 {
3147 oberon_error(ctx, "open array not allowed as array element");
3148 }
3149 }
3150 }
3151
3152 oberon_initialize_type(ctx, type -> base);
3153 oberon_generator_init_type(ctx, type);
3154 }
3155 else if(type -> class == OBERON_TYPE_RECORD)
3156 {
3157 oberon_generator_init_type(ctx, type);
3158 oberon_initialize_record_fields(ctx, type);
3159 }
3160 else if(type -> class == OBERON_TYPE_PROCEDURE)
3161 {
3162 int num_fields = type -> num_decl;
3163 oberon_object_t * field = type -> decl;
3164 for(int i = 0; i < num_fields; i++)
3165 {
3166 oberon_initialize_object(ctx, field);
3167 field = field -> next;
3168 }
3169
3170 oberon_generator_init_type(ctx, type);
3171 }
3172 else
3173 {
3174 oberon_generator_init_type(ctx, type);
3175 }
3176 }
3177
3178 static void
3179 oberon_initialize_object(oberon_context_t * ctx, oberon_object_t * x)
3180 {
3181 if(x -> initialized)
3182 {
3183 return;
3184 }
3185
3186 x -> initialized = 1;
3187
3188 switch(x -> class)
3189 {
3190 case OBERON_CLASS_TYPE:
3191 oberon_initialize_type(ctx, x -> type);
3192 break;
3193 case OBERON_CLASS_VAR:
3194 case OBERON_CLASS_FIELD:
3195 if(x -> type -> class == OBERON_TYPE_ARRAY)
3196 {
3197 if(x -> type -> size == 0)
3198 {
3199 oberon_error(ctx, "open array not allowed as variable or field");
3200 }
3201 }
3202 oberon_initialize_type(ctx, x -> type);
3203 oberon_generator_init_var(ctx, x);
3204 break;
3205 case OBERON_CLASS_PARAM:
3206 case OBERON_CLASS_VAR_PARAM:
3207 oberon_initialize_type(ctx, x -> type);
3208 oberon_generator_init_var(ctx, x);
3209 break;
3210 case OBERON_CLASS_CONST:
3211 case OBERON_CLASS_PROC:
3212 case OBERON_CLASS_MODULE:
3213 break;
3214 default:
3215 oberon_error(ctx, "oberon_initialize_object: wat");
3216 break;
3217 }
3218 }
3219
3220 static void
3221 oberon_initialize_decl(oberon_context_t * ctx)
3222 {
3223 oberon_object_t * x = ctx -> decl -> list;
3224
3225 while(x -> next)
3226 {
3227 oberon_initialize_object(ctx, x -> next);
3228 x = x -> next;
3229 }
3230 }
3231
3232 static void
3233 oberon_prevent_undeclarated_procedures(oberon_context_t * ctx)
3234 {
3235 oberon_object_t * x = ctx -> decl -> list;
3236
3237 while(x -> next)
3238 {
3239 if(x -> next -> class == OBERON_CLASS_PROC)
3240 {
3241 if(x -> next -> linked == 0)
3242 {
3243 oberon_error(ctx, "unresolved forward declaration");
3244 }
3245 }
3246 x = x -> next;
3247 }
3248 }
3249
3250 static void
3251 oberon_decl_seq(oberon_context_t * ctx)
3252 {
3253 if(ctx -> token == CONST)
3254 {
3255 oberon_assert_token(ctx, CONST);
3256 while(ctx -> token == IDENT)
3257 {
3258 oberon_const_decl(ctx);
3259 oberon_assert_token(ctx, SEMICOLON);
3260 }
3261 }
3262
3263 if(ctx -> token == TYPE)
3264 {
3265 oberon_assert_token(ctx, TYPE);
3266 while(ctx -> token == IDENT)
3267 {
3268 oberon_type_decl(ctx);
3269 oberon_assert_token(ctx, SEMICOLON);
3270 }
3271 }
3272
3273 if(ctx -> token == VAR)
3274 {
3275 oberon_assert_token(ctx, VAR);
3276 while(ctx -> token == IDENT)
3277 {
3278 oberon_var_decl(ctx);
3279 oberon_assert_token(ctx, SEMICOLON);
3280 }
3281 }
3282
3283 oberon_prevent_recursive_decl(ctx);
3284 oberon_initialize_decl(ctx);
3285
3286 while(ctx -> token == PROCEDURE)
3287 {
3288 oberon_proc_decl(ctx);
3289 oberon_assert_token(ctx, SEMICOLON);
3290 }
3291
3292 oberon_prevent_undeclarated_procedures(ctx);
3293 }
3294
3295 static oberon_expr_t *
3296 oberon_make_temp_var_item(oberon_context_t * ctx, oberon_type_t * type)
3297 {
3298 oberon_object_t * x;
3299 oberon_expr_t * expr;
3300
3301 x = oberon_create_object(ctx -> decl, "TEMP", OBERON_CLASS_VAR, false, false);
3302 x -> local = true;
3303 x -> type = type;
3304 oberon_generator_init_temp_var(ctx, x);
3305
3306 expr = oberon_new_item(MODE_VAR, type, false);
3307 expr -> item.var = x;
3308 return expr;
3309 }
3310
3311 static void
3312 oberon_statement_seq(oberon_context_t * ctx);
3313
3314 static void
3315 oberon_assign(oberon_context_t * ctx, oberon_expr_t * src, oberon_expr_t * dst)
3316 {
3317 if(dst -> read_only)
3318 {
3319 oberon_error(ctx, "read-only destination");
3320 }
3321
3322 oberon_check_dst(ctx, dst);
3323 src = oberon_autocast_to(ctx, src, dst -> result);
3324 oberon_generate_assign(ctx, src, dst);
3325 }
3326
3327 static oberon_expr_t *
3328 oberon_case_labels(oberon_context_t * ctx, oberon_expr_t * val)
3329 {
3330 oberon_expr_t * e1;
3331 oberon_expr_t * e2;
3332 oberon_expr_t * cond;
3333 oberon_expr_t * cond2;
3334
3335 e1 = (oberon_expr_t *) oberon_const_expr(ctx);
3336 oberon_autocast_to(ctx, e1, val -> result);
3337
3338 e2 = NULL;
3339 if(ctx -> token == DOTDOT)
3340 {
3341 oberon_assert_token(ctx, DOTDOT);
3342 e2 = (oberon_expr_t *) oberon_const_expr(ctx);
3343 oberon_autocast_to(ctx, e2, val -> result);
3344 }
3345
3346 if(e2 == NULL)
3347 {
3348 /* val == e1 */
3349 cond = oberon_make_bin_op(ctx, EQUAL, val, e1);
3350 }
3351 else
3352 {
3353 /* val >= e1 && val <= e2 */
3354 cond = oberon_make_bin_op(ctx, GEQ, val, e1);
3355 cond2 = oberon_make_bin_op(ctx, LEQ, val, e2);
3356 cond = oberon_make_bin_op(ctx, AND, cond, cond2);
3357 }
3358
3359 return cond;
3360 }
3361
3362 static void
3363 oberon_case(oberon_context_t * ctx, oberon_expr_t * val, gen_label_t * end)
3364 {
3365 oberon_expr_t * cond;
3366 oberon_expr_t * cond2;
3367 gen_label_t * this_end;
3368
3369 if(ISEXPR(ctx -> token))
3370 {
3371 this_end = oberon_generator_reserve_label(ctx);
3372
3373 cond = oberon_case_labels(ctx, val);
3374 while(ctx -> token == COMMA)
3375 {
3376 oberon_assert_token(ctx, COMMA);
3377 /* cond || cond2 */
3378 cond2 = oberon_case_labels(ctx, val);
3379 cond = oberon_make_bin_op(ctx, OR, cond, cond2);
3380 }
3381 oberon_assert_token(ctx, COLON);
3382
3383 oberon_generate_branch(ctx, cond, false, this_end);
3384 oberon_statement_seq(ctx);
3385 oberon_generate_goto(ctx, end);
3386
3387 oberon_generate_label(ctx, this_end);
3388 }
3389 }
3390
3391 static void
3392 oberon_case_statement(oberon_context_t * ctx)
3393 {
3394 oberon_expr_t * val;
3395 oberon_expr_t * expr;
3396 gen_label_t * end;
3397
3398 end = oberon_generator_reserve_label(ctx);
3399
3400 oberon_assert_token(ctx, CASE);
3401 expr = oberon_expr(ctx);
3402 val = oberon_make_temp_var_item(ctx, expr -> result);
3403 oberon_assign(ctx, expr, val);
3404 oberon_assert_token(ctx, OF);
3405 oberon_case(ctx, val, end);
3406 while(ctx -> token == BAR)
3407 {
3408 oberon_assert_token(ctx, BAR);
3409 oberon_case(ctx, val, end);
3410 }
3411
3412 if(ctx -> token == ELSE)
3413 {
3414 oberon_assert_token(ctx, ELSE);
3415 oberon_statement_seq(ctx);
3416 }
3417
3418 oberon_generate_label(ctx, end);
3419 oberon_assert_token(ctx, END);
3420 }
3421
3422 static void
3423 oberon_with_guard_do(oberon_context_t * ctx, gen_label_t * end)
3424 {
3425 oberon_expr_t * val;
3426 oberon_expr_t * var;
3427 oberon_expr_t * type;
3428 oberon_expr_t * cond;
3429 oberon_expr_t * cast;
3430 oberon_type_t * old_type;
3431 gen_var_t * old_var;
3432 gen_label_t * this_end;
3433
3434 this_end = oberon_generator_reserve_label(ctx);
3435
3436 var = oberon_qualident_expr(ctx);
3437 oberon_assert_token(ctx, COLON);
3438 type = oberon_qualident_expr(ctx);
3439 cond = oberon_make_bin_op(ctx, IS, var, type);
3440
3441 oberon_assert_token(ctx, DO);
3442 oberon_generate_branch(ctx, cond, false, this_end);
3443
3444 /* Сохраняем ссылку во временной переменной */
3445 val = oberon_make_temp_var_item(ctx, type -> result);
3446 cast = oberno_make_record_cast(ctx, var, type -> result);
3447 oberon_assign(ctx, cast, val);
3448 /* Подменяем тип у оригинальной переменной */
3449 old_type = var -> item.var -> type;
3450 var -> item.var -> type = type -> result;
3451 /* Подменяем ссылку на переменную */
3452 old_var = var -> item.var -> gen_var;
3453 var -> item.var -> gen_var = val -> item.var -> gen_var;
3454
3455 oberon_statement_seq(ctx);
3456 oberon_generate_goto(ctx, end);
3457 oberon_generate_label(ctx, this_end);
3458
3459 /* Возвращаем исходное состояние */
3460 var -> item.var -> gen_var = old_var;
3461 var -> item.var -> type = old_type;
3462 }
3463
3464 static void
3465 oberon_with_statement(oberon_context_t * ctx)
3466 {
3467 gen_label_t * end;
3468 end = oberon_generator_reserve_label(ctx);
3469
3470 oberon_assert_token(ctx, WITH);
3471 oberon_with_guard_do(ctx, end);
3472 while(ctx -> token == BAR)
3473 {
3474 oberon_assert_token(ctx, BAR);
3475 oberon_with_guard_do(ctx, end);
3476 }
3477
3478 if(ctx -> token == ELSE)
3479 {
3480 oberon_assert_token(ctx, ELSE);
3481 oberon_statement_seq(ctx);
3482 }
3483
3484 oberon_generate_label(ctx, end);
3485 oberon_assert_token(ctx, END);
3486 }
3487
3488 static void
3489 oberon_statement(oberon_context_t * ctx)
3490 {
3491 oberon_expr_t * item1;
3492 oberon_expr_t * item2;
3493
3494 if(ctx -> token == IDENT)
3495 {
3496 item1 = oberon_designator(ctx);
3497 if(ctx -> token == ASSIGN)
3498 {
3499 oberon_assert_token(ctx, ASSIGN);
3500 item2 = oberon_expr(ctx);
3501 oberon_assign(ctx, item2, item1);
3502 }
3503 else
3504 {
3505 oberon_opt_proc_parens(ctx, item1);
3506 }
3507 }
3508 else if(ctx -> token == IF)
3509 {
3510 gen_label_t * end;
3511 gen_label_t * els;
3512 oberon_expr_t * cond;
3513
3514 els = oberon_generator_reserve_label(ctx);
3515 end = oberon_generator_reserve_label(ctx);
3516
3517 oberon_assert_token(ctx, IF);
3518 cond = oberon_expr(ctx);
3519 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3520 {
3521 oberon_error(ctx, "condition must be boolean");
3522 }
3523 oberon_assert_token(ctx, THEN);
3524 oberon_generate_branch(ctx, cond, false, els);
3525 oberon_statement_seq(ctx);
3526 oberon_generate_goto(ctx, end);
3527 oberon_generate_label(ctx, els);
3528
3529 while(ctx -> token == ELSIF)
3530 {
3531 els = oberon_generator_reserve_label(ctx);
3532
3533 oberon_assert_token(ctx, ELSIF);
3534 cond = oberon_expr(ctx);
3535 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3536 {
3537 oberon_error(ctx, "condition must be boolean");
3538 }
3539 oberon_assert_token(ctx, THEN);
3540 oberon_generate_branch(ctx, cond, false, els);
3541 oberon_statement_seq(ctx);
3542 oberon_generate_goto(ctx, end);
3543 oberon_generate_label(ctx, els);
3544 }
3545
3546 if(ctx -> token == ELSE)
3547 {
3548 oberon_assert_token(ctx, ELSE);
3549 oberon_statement_seq(ctx);
3550 }
3551
3552 oberon_generate_label(ctx, end);
3553 oberon_assert_token(ctx, END);
3554 }
3555 else if(ctx -> token == WHILE)
3556 {
3557 gen_label_t * begin;
3558 gen_label_t * end;
3559 oberon_expr_t * cond;
3560
3561 begin = oberon_generator_reserve_label(ctx);
3562 end = oberon_generator_reserve_label(ctx);
3563
3564 oberon_assert_token(ctx, WHILE);
3565 oberon_generate_label(ctx, begin);
3566 cond = oberon_expr(ctx);
3567 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3568 {
3569 oberon_error(ctx, "condition must be boolean");
3570 }
3571 oberon_generate_branch(ctx, cond, false, end);
3572
3573 oberon_assert_token(ctx, DO);
3574 oberon_statement_seq(ctx);
3575 oberon_generate_goto(ctx, begin);
3576
3577 oberon_assert_token(ctx, END);
3578 oberon_generate_label(ctx, end);
3579 }
3580 else if(ctx -> token == REPEAT)
3581 {
3582 gen_label_t * begin;
3583 oberon_expr_t * cond;
3584
3585 begin = oberon_generator_reserve_label(ctx);
3586 oberon_generate_label(ctx, begin);
3587 oberon_assert_token(ctx, REPEAT);
3588
3589 oberon_statement_seq(ctx);
3590
3591 oberon_assert_token(ctx, UNTIL);
3592
3593 cond = oberon_expr(ctx);
3594 if(cond -> result -> class != OBERON_TYPE_BOOLEAN)
3595 {
3596 oberon_error(ctx, "condition must be boolean");
3597 }
3598
3599 oberon_generate_branch(ctx, cond, true, begin);
3600 }
3601 else if(ctx -> token == FOR)
3602 {
3603 oberon_expr_t * from;
3604 oberon_expr_t * index;
3605 oberon_expr_t * to;
3606 oberon_expr_t * bound;
3607 oberon_expr_t * by;
3608 oberon_expr_t * cond;
3609 oberon_expr_t * count;
3610 gen_label_t * begin;
3611 gen_label_t * end;
3612 char * iname;
3613 int op;
3614
3615 begin = oberon_generator_reserve_label(ctx);
3616 end = oberon_generator_reserve_label(ctx);
3617
3618 oberon_assert_token(ctx, FOR);
3619 iname = oberon_assert_ident(ctx);
3620 index = oberon_ident_item(ctx, iname);
3621 oberon_assert_token(ctx, ASSIGN);
3622 from = oberon_expr(ctx);
3623 oberon_assign(ctx, from, index);
3624 oberon_assert_token(ctx, TO);
3625 bound = oberon_make_temp_var_item(ctx, index -> result);
3626 to = oberon_expr(ctx);
3627 oberon_assign(ctx, to, bound);
3628 if(ctx -> token == BY)
3629 {
3630 oberon_assert_token(ctx, BY);
3631 by = (oberon_expr_t *) oberon_const_expr(ctx);
3632 }
3633 else
3634 {
3635 by = oberon_integer_item(ctx, 1);
3636 }
3637
3638 if(by -> result -> class != OBERON_TYPE_INTEGER)
3639 {
3640 oberon_error(ctx, "must be integer");
3641 }
3642
3643 if(by -> item.integer > 0)
3644 {
3645 op = LEQ;
3646 }
3647 else if(by -> item.integer < 0)
3648 {
3649 op = GEQ;
3650 }
3651 else
3652 {
3653 oberon_error(ctx, "zero step not allowed");
3654 }
3655
3656 oberon_assert_token(ctx, DO);
3657 oberon_generate_label(ctx, begin);
3658 cond = oberon_make_bin_op(ctx, op, index, bound);
3659 oberon_generate_branch(ctx, cond, false, end);
3660 oberon_statement_seq(ctx);
3661 count = oberon_make_bin_op(ctx, PLUS, index, by);
3662 oberon_assign(ctx, count, index);
3663 oberon_generate_goto(ctx, begin);
3664 oberon_generate_label(ctx, end);
3665 oberon_assert_token(ctx, END);
3666 }
3667 else if(ctx -> token == LOOP)
3668 {
3669 gen_label_t * begin;
3670 gen_label_t * end;
3671
3672 begin = oberon_generator_reserve_label(ctx);
3673 end = oberon_generator_reserve_label(ctx);
3674
3675 oberon_open_scope(ctx);
3676 oberon_assert_token(ctx, LOOP);
3677 oberon_generate_label(ctx, begin);
3678 ctx -> decl -> exit_label = end;
3679 oberon_statement_seq(ctx);
3680 oberon_generate_goto(ctx, begin);
3681 oberon_generate_label(ctx, end);
3682 oberon_assert_token(ctx, END);
3683 oberon_close_scope(ctx -> decl);
3684 }
3685 else if(ctx -> token == EXIT)
3686 {
3687 oberon_assert_token(ctx, EXIT);
3688 if(ctx -> decl -> exit_label == NULL)
3689 {
3690 oberon_error(ctx, "not in LOOP-END");
3691 }
3692 oberon_generate_goto(ctx, ctx -> decl -> exit_label);
3693 }
3694 else if(ctx -> token == CASE)
3695 {
3696 oberon_case_statement(ctx);
3697 }
3698 else if(ctx -> token == WITH)
3699 {
3700 oberon_with_statement(ctx);
3701 }
3702 else if(ctx -> token == RETURN)
3703 {
3704 oberon_assert_token(ctx, RETURN);
3705 if(ISEXPR(ctx -> token))
3706 {
3707 oberon_expr_t * expr;
3708 expr = oberon_expr(ctx);
3709 oberon_make_return(ctx, expr);
3710 }
3711 else
3712 {
3713 oberon_make_return(ctx, NULL);
3714 }
3715 }
3716 }
3717
3718 static void
3719 oberon_statement_seq(oberon_context_t * ctx)
3720 {
3721 oberon_statement(ctx);
3722 while(ctx -> token == SEMICOLON)
3723 {
3724 oberon_assert_token(ctx, SEMICOLON);
3725 oberon_statement(ctx);
3726 }
3727 }
3728
3729 static void
3730 oberon_import_module(oberon_context_t * ctx, char * alias, char * name)
3731 {
3732 oberon_module_t * m = ctx -> module_list;
3733 while(m && strcmp(m -> name, name) != 0)
3734 {
3735 m = m -> next;
3736 }
3737
3738 if(m == NULL)
3739 {
3740 const char * code;
3741 code = ctx -> import_module(name);
3742 if(code == NULL)
3743 {
3744 oberon_error(ctx, "no such module");
3745 }
3746
3747 m = oberon_compile_module(ctx, code);
3748 assert(m);
3749 }
3750
3751 if(m -> ready == 0)
3752 {
3753 oberon_error(ctx, "cyclic module import");
3754 }
3755
3756 oberon_object_t * ident;
3757 ident = oberon_define_object(ctx -> decl, alias, OBERON_CLASS_MODULE, false, false, false);
3758 ident -> module = m;
3759 }
3760
3761 static void
3762 oberon_import_decl(oberon_context_t * ctx)
3763 {
3764 char * alias;
3765 char * name;
3766
3767 alias = name = oberon_assert_ident(ctx);
3768 if(ctx -> token == ASSIGN)
3769 {
3770 oberon_assert_token(ctx, ASSIGN);
3771 name = oberon_assert_ident(ctx);
3772 }
3773
3774 oberon_import_module(ctx, alias, name);
3775 }
3776
3777 static void
3778 oberon_import_list(oberon_context_t * ctx)
3779 {
3780 oberon_assert_token(ctx, IMPORT);
3781
3782 oberon_import_decl(ctx);
3783 while(ctx -> token == COMMA)
3784 {
3785 oberon_assert_token(ctx, COMMA);
3786 oberon_import_decl(ctx);
3787 }
3788
3789 oberon_assert_token(ctx, SEMICOLON);
3790 }
3791
3792 static void
3793 oberon_parse_module(oberon_context_t * ctx)
3794 {
3795 char * name1;
3796 char * name2;
3797 oberon_read_token(ctx);
3798
3799 oberon_assert_token(ctx, MODULE);
3800 name1 = oberon_assert_ident(ctx);
3801 oberon_assert_token(ctx, SEMICOLON);
3802 ctx -> mod -> name = name1;
3803
3804 oberon_generator_init_module(ctx, ctx -> mod);
3805
3806 if(ctx -> token == IMPORT)
3807 {
3808 oberon_import_list(ctx);
3809 }
3810
3811 oberon_decl_seq(ctx);
3812
3813 oberon_generate_begin_module(ctx);
3814 if(ctx -> token == BEGIN)
3815 {
3816 oberon_assert_token(ctx, BEGIN);
3817 oberon_statement_seq(ctx);
3818 }
3819 oberon_generate_end_module(ctx);
3820
3821 oberon_assert_token(ctx, END);
3822 name2 = oberon_assert_ident(ctx);
3823 oberon_expect_token(ctx, DOT);
3824
3825 if(strcmp(name1, name2) != 0)
3826 {
3827 oberon_error(ctx, "module name not matched");
3828 }
3829
3830 oberon_generator_fini_module(ctx -> mod);
3831 }
3832
3833 // =======================================================================
3834 // LIBRARY
3835 // =======================================================================
3836
3837 static void
3838 register_default_types(oberon_context_t * ctx)
3839 {
3840 ctx -> notype_type = oberon_new_type_ptr(OBERON_TYPE_NOTYPE);
3841 oberon_generator_init_type(ctx, ctx -> notype_type);
3842
3843 ctx -> nil_type = oberon_new_type_ptr(OBERON_TYPE_NIL);
3844 oberon_generator_init_type(ctx, ctx -> nil_type);
3845
3846 ctx -> string_type = oberon_new_type_string(1);
3847 oberon_generator_init_type(ctx, ctx -> string_type);
3848
3849 ctx -> bool_type = oberon_new_type_boolean();
3850 oberon_define_type(ctx -> world_scope, "BOOLEAN", ctx -> bool_type, 1);
3851
3852 ctx -> char_type = oberon_new_type_char(1);
3853 oberon_define_type(ctx -> world_scope, "CHAR", ctx -> char_type, 1);
3854
3855 ctx -> byte_type = oberon_new_type_integer(1);
3856 oberon_define_type(ctx -> world_scope, "SHORTINT", ctx -> byte_type, 1);
3857
3858 ctx -> shortint_type = oberon_new_type_integer(2);
3859 oberon_define_type(ctx -> world_scope, "INTEGER", ctx -> shortint_type, 1);
3860
3861 ctx -> int_type = oberon_new_type_integer(4);
3862 oberon_define_type(ctx -> world_scope, "LONGINT", ctx -> int_type, 1);
3863
3864 ctx -> longint_type = oberon_new_type_integer(8);
3865 oberon_define_type(ctx -> world_scope, "HUGEINT", ctx -> longint_type, 1);
3866
3867 ctx -> real_type = oberon_new_type_real(4);
3868 oberon_define_type(ctx -> world_scope, "REAL", ctx -> real_type, 1);
3869
3870 ctx -> longreal_type = oberon_new_type_real(8);
3871 oberon_define_type(ctx -> world_scope, "LONGREAL", ctx -> longreal_type, 1);
3872
3873 ctx -> set_type = oberon_new_type_set(4);
3874 oberon_define_type(ctx -> world_scope, "SET", ctx -> set_type, 1);
3875 }
3876
3877 static void
3878 oberon_new_intrinsic(oberon_context_t * ctx, char * name, GenerateFuncCallback f, GenerateProcCallback p)
3879 {
3880 oberon_object_t * proc;
3881 proc = oberon_define_object(ctx -> decl, name, OBERON_CLASS_PROC, true, false, false);
3882 proc -> type = oberon_new_type_ptr(OBERON_TYPE_PROCEDURE);
3883 proc -> type -> sysproc = true;
3884 proc -> type -> genfunc = f;
3885 proc -> type -> genproc = p;
3886 }
3887
3888 static oberon_expr_t *
3889 oberon_make_min_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3890 {
3891 if(num_args < 1)
3892 {
3893 oberon_error(ctx, "too few arguments");
3894 }
3895
3896 if(num_args > 1)
3897 {
3898 oberon_error(ctx, "too mach arguments");
3899 }
3900
3901 oberon_expr_t * arg;
3902 arg = list_args;
3903
3904 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3905 {
3906 oberon_error(ctx, "MIN accept only type");
3907 }
3908
3909 oberon_expr_t * expr;
3910 int bits = arg -> result -> size * 8;
3911 switch(arg -> result -> class)
3912 {
3913 case OBERON_TYPE_INTEGER:
3914 expr = oberon_integer_item(ctx, -powl(2, bits - 1));
3915 break;
3916 case OBERON_TYPE_SET:
3917 expr = oberon_integer_item(ctx, 0);
3918 break;
3919 default:
3920 oberon_error(ctx, "allowed only basic types");
3921 break;
3922 }
3923
3924 return expr;
3925 }
3926
3927 static oberon_expr_t *
3928 oberon_make_max_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3929 {
3930 if(num_args < 1)
3931 {
3932 oberon_error(ctx, "too few arguments");
3933 }
3934
3935 if(num_args > 1)
3936 {
3937 oberon_error(ctx, "too mach arguments");
3938 }
3939
3940 oberon_expr_t * arg;
3941 arg = list_args;
3942
3943 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3944 {
3945 oberon_error(ctx, "MAX accept only type");
3946 }
3947
3948 oberon_expr_t * expr;
3949 int bits = arg -> result -> size * 8;
3950 switch(arg -> result -> class)
3951 {
3952 case OBERON_TYPE_INTEGER:
3953 expr = oberon_integer_item(ctx, powl(2, bits - 1) - 1);
3954 break;
3955 case OBERON_TYPE_SET:
3956 expr = oberon_integer_item(ctx, bits);
3957 break;
3958 default:
3959 oberon_error(ctx, "allowed only basic types");
3960 break;
3961 }
3962
3963 return expr;
3964 }
3965
3966 static oberon_expr_t *
3967 oberon_make_size_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
3968 {
3969 if(num_args < 1)
3970 {
3971 oberon_error(ctx, "too few arguments");
3972 }
3973
3974 if(num_args > 1)
3975 {
3976 oberon_error(ctx, "too mach arguments");
3977 }
3978
3979 oberon_expr_t * arg;
3980 arg = list_args;
3981
3982 if(!arg -> is_item || arg -> item.mode != MODE_TYPE)
3983 {
3984 oberon_error(ctx, "SIZE accept only type");
3985 }
3986
3987 int size;
3988 oberon_expr_t * expr;
3989 oberon_type_t * type = arg -> result;
3990 switch(type -> class)
3991 {
3992 case OBERON_TYPE_INTEGER:
3993 case OBERON_TYPE_BOOLEAN:
3994 case OBERON_TYPE_REAL:
3995 case OBERON_TYPE_CHAR:
3996 case OBERON_TYPE_SET:
3997 size = type -> size;
3998 break;
3999 default:
4000 oberon_error(ctx, "TODO SIZE");
4001 break;
4002 }
4003
4004 expr = oberon_integer_item(ctx, size);
4005 return expr;
4006 }
4007
4008 static oberon_expr_t *
4009 oberon_make_abs_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
4010 {
4011 if(num_args < 1)
4012 {
4013 oberon_error(ctx, "too few arguments");
4014 }
4015
4016 if(num_args > 1)
4017 {
4018 oberon_error(ctx, "too mach arguments");
4019 }
4020
4021 oberon_expr_t * arg;
4022 arg = list_args;
4023 oberon_check_src(ctx, arg);
4024
4025 oberon_type_t * result_type;
4026 result_type = arg -> result;
4027
4028 if(result_type -> class != OBERON_TYPE_INTEGER)
4029 {
4030 oberon_error(ctx, "ABS accepts only integers");
4031 }
4032
4033 oberon_expr_t * expr;
4034 expr = oberon_new_operator(OP_ABS, result_type, arg, NULL);
4035 return expr;
4036 }
4037
4038 static void
4039 oberon_make_new_call(oberon_context_t * ctx, int num_args, oberon_expr_t * list_args)
4040 {
4041 if(num_args < 1)
4042 {
4043 oberon_error(ctx, "too few arguments");
4044 }
4045
4046
4047 oberon_expr_t * dst;
4048 dst = list_args;
4049 oberon_check_dst(ctx, dst);
4050
4051 oberon_type_t * type;
4052 type = dst -> result;
4053
4054 if(type -> class != OBERON_TYPE_POINTER)
4055 {
4056 oberon_error(ctx, "not a pointer");
4057 }
4058
4059 type = type -> base;
4060
4061 oberon_expr_t * src;
4062 src = oberon_new_item(MODE_NEW, dst -> result, 0);
4063 src -> item.num_args = 0;
4064 src -> item.args = NULL;
4065
4066 int max_args = 1;
4067 if(type -> class == OBERON_TYPE_ARRAY)
4068 {
4069 if(type -> size == 0)
4070 {
4071 oberon_type_t * x = type;
4072 while(x -> class == OBERON_TYPE_ARRAY)
4073 {
4074 if(x -> size == 0)
4075 {
4076 max_args += 1;
4077 }
4078 x = x -> base;
4079 }
4080 }
4081
4082 if(num_args < max_args)
4083 {
4084 oberon_error(ctx, "too few arguments");
4085 }
4086
4087 if(num_args > max_args)
4088 {
4089 oberon_error(ctx, "too mach arguments");
4090 }
4091
4092 int num_sizes = max_args - 1;
4093 oberon_expr_t * size_list = list_args -> next;
4094
4095 oberon_expr_t * arg = size_list;
4096 for(int i = 0; i < max_args - 1; i++)
4097 {
4098 oberon_check_src(ctx, arg);
4099 if(arg -> result -> class != OBERON_TYPE_INTEGER)
4100 {
4101 oberon_error(ctx, "size must be integer");
4102 }
4103 arg = arg -> next;
4104 }
4105
4106 src -> item.num_args = num_sizes;
4107 src -> item.args = size_list;
4108 }
4109 else if(type -> class != OBERON_TYPE_RECORD)
4110 {
4111 oberon_error(ctx, "oberon_make_new_call: wat");
4112 }
4113
4114 if(num_args > max_args)
4115 {
4116 oberon_error(ctx, "too mach arguments");
4117 }
4118
4119 oberon_assign(ctx, src, dst);
4120 }
4121
4122 static void
4123 oberon_new_const(oberon_context_t * ctx, char * name, oberon_expr_t * expr)
4124 {
4125 oberon_object_t * constant;
4126 constant = oberon_define_object(ctx -> decl, name, OBERON_CLASS_CONST, true, false, false);
4127 oberon_check_const(ctx, expr);
4128 constant -> value = (oberon_item_t *) expr;
4129 }
4130
4131 oberon_context_t *
4132 oberon_create_context(ModuleImportCallback import_module)
4133 {
4134 oberon_context_t * ctx = calloc(1, sizeof *ctx);
4135
4136 oberon_scope_t * world_scope;
4137 world_scope = oberon_open_scope(ctx);
4138 ctx -> world_scope = world_scope;
4139
4140 ctx -> import_module = import_module;
4141
4142 oberon_generator_init_context(ctx);
4143
4144 register_default_types(ctx);
4145
4146 /* Constants */
4147 oberon_new_const(ctx, "TRUE", oberon_make_boolean(ctx, true));
4148 oberon_new_const(ctx, "FALSE", oberon_make_boolean(ctx, false));
4149
4150 /* Functions */
4151 oberon_new_intrinsic(ctx, "ABS", oberon_make_abs_call, NULL);
4152 oberon_new_intrinsic(ctx, "MIN", oberon_make_min_call, NULL);
4153 oberon_new_intrinsic(ctx, "MAX", oberon_make_max_call, NULL);
4154 oberon_new_intrinsic(ctx, "SIZE", oberon_make_size_call, NULL);
4155
4156 /* Procedures */
4157 oberon_new_intrinsic(ctx, "NEW", NULL, oberon_make_new_call);
4158
4159 return ctx;
4160 }
4161
4162 void
4163 oberon_destroy_context(oberon_context_t * ctx)
4164 {
4165 oberon_generator_destroy_context(ctx);
4166 free(ctx);
4167 }
4168
4169 oberon_module_t *
4170 oberon_compile_module(oberon_context_t * ctx, const char * newcode)
4171 {
4172 const char * code = ctx -> code;
4173 int code_index = ctx -> code_index;
4174 char c = ctx -> c;
4175 int token = ctx -> token;
4176 char * string = ctx -> string;
4177 int integer = ctx -> integer;
4178 int real = ctx -> real;
4179 bool longmode = ctx -> longmode;
4180 oberon_scope_t * decl = ctx -> decl;
4181 oberon_module_t * mod = ctx -> mod;
4182
4183 oberon_scope_t * module_scope;
4184 module_scope = oberon_open_scope(ctx);
4185
4186 oberon_module_t * module;
4187 module = calloc(1, sizeof *module);
4188 module -> decl = module_scope;
4189 module -> next = ctx -> module_list;
4190
4191 ctx -> mod = module;
4192 ctx -> module_list = module;
4193
4194 oberon_init_scaner(ctx, newcode);
4195 oberon_parse_module(ctx);
4196
4197 module -> ready = 1;
4198
4199 ctx -> code = code;
4200 ctx -> code_index = code_index;
4201 ctx -> c = c;
4202 ctx -> token = token;
4203 ctx -> string = string;
4204 ctx -> integer = integer;
4205 ctx -> real = real;
4206 ctx -> longmode = longmode;
4207 ctx -> decl = decl;
4208 ctx -> mod = mod;
4209
4210 return module;
4211 }
Another attempt to make Oberon compiler
DEADSOFTWARE 2012-2025