DEADSOFTWARE

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


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