DEADSOFTWARE

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