59 // =======================================================================
61 // =======================================================================
64 oberon_error(oberon_context_t
* ctx
, const char * 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
);
78 static oberon_type_t
*
79 oberon_new_type_ptr(int class)
81 oberon_type_t
* x
= malloc(sizeof *x
);
82 memset(x
, 0, sizeof *x
);
87 static oberon_type_t
*
88 oberon_new_type_integer(int size
)
91 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
96 static oberon_type_t
*
97 oberon_new_type_boolean(int size
)
100 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
105 // =======================================================================
107 // =======================================================================
109 static oberon_scope_t
*
110 oberon_open_scope(oberon_context_t
* ctx
)
112 oberon_scope_t
* scope
= calloc(1, sizeof *scope
);
113 oberon_object_t
* list
= calloc(1, sizeof *list
);
116 scope
-> list
= list
;
117 scope
-> up
= ctx
-> decl
;
121 scope
-> parent
= scope
-> up
-> parent
;
122 scope
-> local
= scope
-> up
-> local
;
130 oberon_close_scope(oberon_scope_t
* scope
)
132 oberon_context_t
* ctx
= scope
-> ctx
;
133 ctx
-> decl
= scope
-> up
;
136 static oberon_object_t
*
137 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class, int export
, int read_only
)
139 oberon_object_t
* x
= scope
-> list
;
140 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
147 oberon_error(scope
-> ctx
, "already defined");
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
;
165 oberon_define_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
, oberon_type_t
* type
)
167 // TODO check base fields
169 oberon_object_t
* x
= rec
-> decl
;
170 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
177 oberon_error(ctx
, "multiple definition");
180 oberon_object_t
* field
= malloc(sizeof *field
);
181 memset(field
, 0, sizeof *field
);
182 field
-> name
= name
;
183 field
-> class = OBERON_CLASS_FIELD
;
184 field
-> type
= type
;
186 field
-> parent
= NULL
;
188 rec
-> num_decl
+= 1;
192 static oberon_object_t
*
193 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
195 oberon_object_t
* x
= list
;
196 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
203 static oberon_object_t
*
204 oberon_find_object(oberon_scope_t
* scope
, char * name
, int check_it
)
206 oberon_object_t
* result
= NULL
;
208 oberon_scope_t
* s
= scope
;
209 while(result
== NULL
&& s
!= NULL
)
211 result
= oberon_find_object_in_list(s
-> list
, name
);
215 if(check_it
&& result
== NULL
)
217 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
223 static oberon_object_t
*
224 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
226 oberon_object_t
* x
= rec
-> decl
;
227 for(int i
= 0; i
< rec
-> num_decl
; i
++)
229 if(strcmp(x
-> name
, name
) == 0)
236 oberon_error(ctx
, "field not defined");
241 static oberon_object_t
*
242 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
, int export
, int read_only
)
244 oberon_object_t
* id
;
245 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
247 oberon_generator_init_type(scope
-> ctx
, type
);
251 static oberon_object_t
*
252 oberon_define_var(oberon_scope_t
* scope
, int class, char * name
, oberon_type_t
* type
, int export
, int read_only
)
254 oberon_object_t
* var
;
255 var
= oberon_define_object(scope
, name
, class, export
, read_only
);
260 // =======================================================================
262 // =======================================================================
265 oberon_get_char(oberon_context_t
* ctx
)
267 ctx
-> code_index
+= 1;
268 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
272 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
275 ctx
-> code_index
= 0;
276 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
280 oberon_read_ident(oberon_context_t
* ctx
)
283 int i
= ctx
-> code_index
;
285 int c
= ctx
-> code
[i
];
293 char * ident
= malloc(len
+ 1);
294 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
297 ctx
-> code_index
= i
;
298 ctx
-> c
= ctx
-> code
[i
];
299 ctx
-> string
= ident
;
300 ctx
-> token
= IDENT
;
302 if(strcmp(ident
, "MODULE") == 0)
304 ctx
-> token
= MODULE
;
306 else if(strcmp(ident
, "END") == 0)
310 else if(strcmp(ident
, "VAR") == 0)
314 else if(strcmp(ident
, "BEGIN") == 0)
316 ctx
-> token
= BEGIN
;
318 else if(strcmp(ident
, "TRUE") == 0)
322 else if(strcmp(ident
, "FALSE") == 0)
324 ctx
-> token
= FALSE
;
326 else if(strcmp(ident
, "OR") == 0)
330 else if(strcmp(ident
, "DIV") == 0)
334 else if(strcmp(ident
, "MOD") == 0)
338 else if(strcmp(ident
, "PROCEDURE") == 0)
340 ctx
-> token
= PROCEDURE
;
342 else if(strcmp(ident
, "RETURN") == 0)
344 ctx
-> token
= RETURN
;
346 else if(strcmp(ident
, "CONST") == 0)
348 ctx
-> token
= CONST
;
350 else if(strcmp(ident
, "TYPE") == 0)
354 else if(strcmp(ident
, "ARRAY") == 0)
356 ctx
-> token
= ARRAY
;
358 else if(strcmp(ident
, "OF") == 0)
362 else if(strcmp(ident
, "RECORD") == 0)
364 ctx
-> token
= RECORD
;
366 else if(strcmp(ident
, "POINTER") == 0)
368 ctx
-> token
= POINTER
;
370 else if(strcmp(ident
, "TO") == 0)
374 else if(strcmp(ident
, "NIL") == 0)
378 else if(strcmp(ident
, "IMPORT") == 0)
380 ctx
-> token
= IMPORT
;
385 oberon_read_integer(oberon_context_t
* ctx
)
388 int i
= ctx
-> code_index
;
390 int c
= ctx
-> code
[i
];
398 char * ident
= malloc(len
+ 2);
399 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
402 ctx
-> code_index
= i
;
403 ctx
-> c
= ctx
-> code
[i
];
404 ctx
-> string
= ident
;
405 ctx
-> integer
= atoi(ident
);
406 ctx
-> token
= INTEGER
;
410 oberon_skip_space(oberon_context_t
* ctx
)
412 while(isspace(ctx
-> c
))
414 oberon_get_char(ctx
);
419 oberon_read_symbol(oberon_context_t
* ctx
)
428 ctx
-> token
= SEMICOLON
;
429 oberon_get_char(ctx
);
432 ctx
-> token
= COLON
;
433 oberon_get_char(ctx
);
436 ctx
-> token
= ASSIGN
;
437 oberon_get_char(ctx
);
442 oberon_get_char(ctx
);
445 ctx
-> token
= LPAREN
;
446 oberon_get_char(ctx
);
449 ctx
-> token
= RPAREN
;
450 oberon_get_char(ctx
);
453 ctx
-> token
= EQUAL
;
454 oberon_get_char(ctx
);
458 oberon_get_char(ctx
);
462 oberon_get_char(ctx
);
466 oberon_get_char(ctx
);
470 ctx
-> token
= GREAT
;
471 oberon_get_char(ctx
);
475 oberon_get_char(ctx
);
480 oberon_get_char(ctx
);
483 ctx
-> token
= MINUS
;
484 oberon_get_char(ctx
);
488 oberon_get_char(ctx
);
491 ctx
-> token
= SLASH
;
492 oberon_get_char(ctx
);
496 oberon_get_char(ctx
);
500 oberon_get_char(ctx
);
503 ctx
-> token
= COMMA
;
504 oberon_get_char(ctx
);
507 ctx
-> token
= LBRACE
;
508 oberon_get_char(ctx
);
511 ctx
-> token
= RBRACE
;
512 oberon_get_char(ctx
);
515 ctx
-> token
= UPARROW
;
516 oberon_get_char(ctx
);
519 oberon_error(ctx
, "invalid char");
525 oberon_read_token(oberon_context_t
* ctx
)
527 oberon_skip_space(ctx
);
532 oberon_read_ident(ctx
);
536 oberon_read_integer(ctx
);
540 oberon_read_symbol(ctx
);
544 // =======================================================================
546 // =======================================================================
548 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
549 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
550 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
551 static char * oberon_assert_ident(oberon_context_t
* ctx
);
552 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
553 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
555 static oberon_expr_t
*
556 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
558 oberon_oper_t
* operator;
559 operator = malloc(sizeof *operator);
560 memset(operator, 0, sizeof *operator);
562 operator -> is_item
= 0;
563 operator -> result
= result
;
565 operator -> left
= left
;
566 operator -> right
= right
;
568 return (oberon_expr_t
*) operator;
571 static oberon_expr_t
*
572 oberon_new_item(int mode
, oberon_type_t
* result
)
574 oberon_item_t
* item
;
575 item
= malloc(sizeof *item
);
576 memset(item
, 0, sizeof *item
);
579 item
-> result
= result
;
582 return (oberon_expr_t
*)item
;
585 static oberon_expr_t
*
586 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
588 oberon_expr_t
* expr
;
589 oberon_type_t
* result
;
591 result
= a
-> result
;
595 if(result
-> class != OBERON_TYPE_INTEGER
)
597 oberon_error(ctx
, "incompatible operator type");
600 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
602 else if(token
== NOT
)
604 if(result
-> class != OBERON_TYPE_BOOLEAN
)
606 oberon_error(ctx
, "incompatible operator type");
609 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
613 oberon_error(ctx
, "oberon_make_unary_op: wat");
620 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
622 oberon_expr_t
* last
;
625 *first
= last
= oberon_expr(ctx
);
626 while(ctx
-> token
== COMMA
)
628 oberon_assert_token(ctx
, COMMA
);
629 oberon_expr_t
* current
;
633 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
637 current
= oberon_expr(ctx
);
640 last
-> next
= current
;
646 static oberon_expr_t
*
647 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
649 if(pref
-> class != expr
-> result
-> class)
651 oberon_error(ctx
, "incompatible types");
654 if(pref
-> class == OBERON_TYPE_INTEGER
)
656 if(expr
-> result
-> class > pref
-> class)
658 oberon_error(ctx
, "incompatible size");
661 else if(pref
-> class == OBERON_TYPE_RECORD
)
663 if(expr
-> result
!= pref
)
665 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
666 oberon_error(ctx
, "incompatible record types");
669 else if(pref
-> class == OBERON_TYPE_POINTER
)
671 if(expr
-> result
-> base
!= pref
-> base
)
673 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
675 oberon_error(ctx
, "incompatible pointer types");
686 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
688 if(desig
-> is_item
== 0)
690 oberon_error(ctx
, "expected item");
693 if(desig
-> item
.mode
!= MODE_CALL
)
695 oberon_error(ctx
, "expected mode CALL");
698 if(desig
-> item
.var
-> type
-> class != OBERON_TYPE_PROCEDURE
)
700 oberon_error(ctx
, "only procedures can be called");
703 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
704 int num_args
= desig
-> item
.num_args
;
705 int num_decl
= fn
-> num_decl
;
707 if(num_args
< num_decl
)
709 oberon_error(ctx
, "too few arguments");
711 else if(num_args
> num_decl
)
713 oberon_error(ctx
, "too many arguments");
716 oberon_expr_t
* arg
= desig
-> item
.args
;
717 oberon_object_t
* param
= fn
-> decl
;
718 for(int i
= 0; i
< num_args
; i
++)
720 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
724 switch(arg
-> item
.mode
)
729 // Допустимо разыменование?
733 oberon_error(ctx
, "var-parameter accept only variables");
738 oberon_autocast_to(ctx
, arg
, param
-> type
);
740 param
= param
-> next
;
744 static oberon_expr_t
*
745 oberon_make_call_func(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
747 switch(proc
-> class)
749 case OBERON_CLASS_PROC
:
750 if(proc
-> class != OBERON_CLASS_PROC
)
752 oberon_error(ctx
, "not a procedure");
755 case OBERON_CLASS_VAR
:
756 case OBERON_CLASS_VAR_PARAM
:
757 case OBERON_CLASS_PARAM
:
758 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
760 oberon_error(ctx
, "not a procedure");
764 oberon_error(ctx
, "not a procedure");
768 oberon_expr_t
* call
;
772 if(proc
-> genfunc
== NULL
)
774 oberon_error(ctx
, "not a function-procedure");
777 call
= proc
-> genfunc(ctx
, num_args
, list_args
);
781 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
)
783 oberon_error(ctx
, "attempt to call procedure in expression");
786 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
);
787 call
-> item
.var
= proc
;
788 call
-> item
.num_args
= num_args
;
789 call
-> item
.args
= list_args
;
790 oberon_autocast_call(ctx
, call
);
797 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
799 switch(proc
-> class)
801 case OBERON_CLASS_PROC
:
802 if(proc
-> class != OBERON_CLASS_PROC
)
804 oberon_error(ctx
, "not a procedure");
807 case OBERON_CLASS_VAR
:
808 case OBERON_CLASS_VAR_PARAM
:
809 case OBERON_CLASS_PARAM
:
810 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
812 oberon_error(ctx
, "not a procedure");
816 oberon_error(ctx
, "not a procedure");
822 if(proc
-> genproc
== NULL
)
824 oberon_error(ctx
, "requres non-typed procedure");
827 proc
-> genproc(ctx
, num_args
, list_args
);
831 if(proc
-> type
-> base
-> class != OBERON_TYPE_VOID
)
833 oberon_error(ctx
, "attempt to call function as non-typed procedure");
836 oberon_expr_t
* call
;
837 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
);
838 call
-> item
.var
= proc
;
839 call
-> item
.num_args
= num_args
;
840 call
-> item
.args
= list_args
;
841 oberon_autocast_call(ctx
, call
);
842 oberon_generate_call_proc(ctx
, call
);
850 || ((x) == INTEGER) \
856 static oberon_expr_t
*
857 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
859 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
861 oberon_error(ctx
, "not a pointer");
864 assert(expr
-> is_item
);
866 oberon_expr_t
* selector
;
867 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
);
868 selector
-> item
.parent
= (oberon_item_t
*) expr
;
873 static oberon_expr_t
*
874 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
876 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
878 desig
= oberno_make_dereferencing(ctx
, desig
);
881 assert(desig
-> is_item
);
883 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
885 oberon_error(ctx
, "not array");
888 oberon_type_t
* base
;
889 base
= desig
-> result
-> base
;
891 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
893 oberon_error(ctx
, "index must be integer");
896 // Статическая проверка границ массива
899 if(index
-> item
.mode
== MODE_INTEGER
)
901 int arr_size
= desig
-> result
-> size
;
902 int index_int
= index
-> item
.integer
;
903 if(index_int
< 0 || index_int
> arr_size
- 1)
905 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
910 oberon_expr_t
* selector
;
911 selector
= oberon_new_item(MODE_INDEX
, base
);
912 selector
-> item
.parent
= (oberon_item_t
*) desig
;
913 selector
-> item
.num_args
= 1;
914 selector
-> item
.args
= index
;
919 static oberon_expr_t
*
920 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
922 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
924 expr
= oberno_make_dereferencing(ctx
, expr
);
927 assert(expr
-> is_item
== 1);
929 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
931 oberon_error(ctx
, "not record");
934 oberon_type_t
* rec
= expr
-> result
;
936 oberon_object_t
* field
;
937 field
= oberon_find_field(ctx
, rec
, name
);
939 oberon_expr_t
* selector
;
940 selector
= oberon_new_item(MODE_FIELD
, field
-> type
);
941 selector
-> item
.var
= field
;
942 selector
-> item
.parent
= (oberon_item_t
*) expr
;
947 #define ISSELECTOR(x) \
952 static oberon_object_t
*
953 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
958 name
= oberon_assert_ident(ctx
);
959 x
= oberon_find_object(ctx
-> decl
, name
, check
);
963 if(x
-> class == OBERON_CLASS_MODULE
)
965 oberon_assert_token(ctx
, DOT
);
966 name
= oberon_assert_ident(ctx
);
967 /* Наличие объектов в левых модулях всегда проверяется */
968 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
972 oberon_error(ctx
, "not exported");
985 static oberon_expr_t
*
986 oberon_designator(oberon_context_t
* ctx
)
989 oberon_object_t
* var
;
990 oberon_expr_t
* expr
;
992 var
= oberon_qualident(ctx
, NULL
, 1);
996 case OBERON_CLASS_CONST
:
998 expr
= (oberon_expr_t
*) var
-> value
;
1000 case OBERON_CLASS_VAR
:
1001 case OBERON_CLASS_VAR_PARAM
:
1002 case OBERON_CLASS_PARAM
:
1003 case OBERON_CLASS_PROC
:
1004 expr
= oberon_new_item(MODE_VAR
, var
-> type
);
1007 oberon_error(ctx
, "invalid designator");
1010 expr
-> item
.var
= var
;
1012 while(ISSELECTOR(ctx
-> token
))
1014 switch(ctx
-> token
)
1017 oberon_assert_token(ctx
, DOT
);
1018 name
= oberon_assert_ident(ctx
);
1019 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1022 oberon_assert_token(ctx
, LBRACE
);
1023 int num_indexes
= 0;
1024 oberon_expr_t
* indexes
= NULL
;
1025 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1026 oberon_assert_token(ctx
, RBRACE
);
1028 for(int i
= 0; i
< num_indexes
; i
++)
1030 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1031 indexes
= indexes
-> next
;
1035 oberon_assert_token(ctx
, UPARROW
);
1036 expr
= oberno_make_dereferencing(ctx
, expr
);
1039 oberon_error(ctx
, "oberon_designator: wat");
1046 static oberon_expr_t
*
1047 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1049 assert(expr
-> is_item
== 1);
1051 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1052 if(ctx
-> token
== LPAREN
)
1054 oberon_assert_token(ctx
, LPAREN
);
1057 oberon_expr_t
* arguments
= NULL
;
1059 if(ISEXPR(ctx
-> token
))
1061 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1064 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1066 oberon_assert_token(ctx
, RPAREN
);
1073 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1075 assert(expr
-> is_item
== 1);
1078 oberon_expr_t
* arguments
= NULL
;
1080 if(ctx
-> token
== LPAREN
)
1082 oberon_assert_token(ctx
, LPAREN
);
1084 if(ISEXPR(ctx
-> token
))
1086 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1089 oberon_assert_token(ctx
, RPAREN
);
1092 /* Вызов происходит даже без скобок */
1093 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1096 static oberon_expr_t
*
1097 oberon_factor(oberon_context_t
* ctx
)
1099 oberon_expr_t
* expr
;
1101 switch(ctx
-> token
)
1104 expr
= oberon_designator(ctx
);
1105 expr
= oberon_opt_func_parens(ctx
, expr
);
1108 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
);
1109 expr
-> item
.integer
= ctx
-> integer
;
1110 oberon_assert_token(ctx
, INTEGER
);
1113 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
1114 expr
-> item
.boolean
= 1;
1115 oberon_assert_token(ctx
, TRUE
);
1118 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
1119 expr
-> item
.boolean
= 0;
1120 oberon_assert_token(ctx
, FALSE
);
1123 oberon_assert_token(ctx
, LPAREN
);
1124 expr
= oberon_expr(ctx
);
1125 oberon_assert_token(ctx
, RPAREN
);
1128 oberon_assert_token(ctx
, NOT
);
1129 expr
= oberon_factor(ctx
);
1130 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1133 oberon_assert_token(ctx
, NIL
);
1134 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
);
1137 oberon_error(ctx
, "invalid expression");
1144 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1145 * 1. Классы обоих типов должны быть одинаковы
1146 * 2. В качестве результата должен быть выбран больший тип.
1147 * 3. Если размер результат не должен быть меньше чем базовый int
1151 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
1153 if((a
-> class) != (b
-> class))
1155 oberon_error(ctx
, "incompatible types");
1158 if((a
-> size
) > (b
-> size
))
1167 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
1169 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
1171 *result
= ctx
-> int_type
;
1175 /* TODO: cast types */
1178 #define ITMAKESBOOLEAN(x) \
1179 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1181 #define ITUSEONLYINTEGER(x) \
1182 ((x) >= LESS && (x) <= GEQ)
1184 #define ITUSEONLYBOOLEAN(x) \
1185 (((x) == OR) || ((x) == AND))
1187 static oberon_expr_t
*
1188 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1190 oberon_expr_t
* expr
;
1191 oberon_type_t
* result
;
1193 if(ITMAKESBOOLEAN(token
))
1195 if(ITUSEONLYINTEGER(token
))
1197 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1198 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1200 oberon_error(ctx
, "used only with integer types");
1203 else if(ITUSEONLYBOOLEAN(token
))
1205 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1206 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1208 oberon_error(ctx
, "used only with boolean type");
1212 result
= ctx
-> bool_type
;
1216 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1218 else if(token
== NEQ
)
1220 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1222 else if(token
== LESS
)
1224 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1226 else if(token
== LEQ
)
1228 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1230 else if(token
== GREAT
)
1232 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1234 else if(token
== GEQ
)
1236 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1238 else if(token
== OR
)
1240 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1242 else if(token
== AND
)
1244 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1248 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1253 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1257 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1259 else if(token
== MINUS
)
1261 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1263 else if(token
== STAR
)
1265 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1267 else if(token
== SLASH
)
1269 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1271 else if(token
== DIV
)
1273 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1275 else if(token
== MOD
)
1277 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1281 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1288 #define ISMULOP(x) \
1289 ((x) >= STAR && (x) <= AND)
1291 static oberon_expr_t
*
1292 oberon_term_expr(oberon_context_t
* ctx
)
1294 oberon_expr_t
* expr
;
1296 expr
= oberon_factor(ctx
);
1297 while(ISMULOP(ctx
-> token
))
1299 int token
= ctx
-> token
;
1300 oberon_read_token(ctx
);
1302 oberon_expr_t
* inter
= oberon_factor(ctx
);
1303 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1309 #define ISADDOP(x) \
1310 ((x) >= PLUS && (x) <= OR)
1312 static oberon_expr_t
*
1313 oberon_simple_expr(oberon_context_t
* ctx
)
1315 oberon_expr_t
* expr
;
1318 if(ctx
-> token
== PLUS
)
1321 oberon_assert_token(ctx
, PLUS
);
1323 else if(ctx
-> token
== MINUS
)
1326 oberon_assert_token(ctx
, MINUS
);
1329 expr
= oberon_term_expr(ctx
);
1330 while(ISADDOP(ctx
-> token
))
1332 int token
= ctx
-> token
;
1333 oberon_read_token(ctx
);
1335 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1336 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1341 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1347 #define ISRELATION(x) \
1348 ((x) >= EQUAL && (x) <= GEQ)
1350 static oberon_expr_t
*
1351 oberon_expr(oberon_context_t
* ctx
)
1353 oberon_expr_t
* expr
;
1355 expr
= oberon_simple_expr(ctx
);
1356 while(ISRELATION(ctx
-> token
))
1358 int token
= ctx
-> token
;
1359 oberon_read_token(ctx
);
1361 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1362 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1368 static oberon_item_t
*
1369 oberon_const_expr(oberon_context_t
* ctx
)
1371 oberon_expr_t
* expr
;
1372 expr
= oberon_expr(ctx
);
1374 if(expr
-> is_item
== 0)
1376 oberon_error(ctx
, "const expression are required");
1379 return (oberon_item_t
*) expr
;
1382 // =======================================================================
1384 // =======================================================================
1386 static void oberon_decl_seq(oberon_context_t
* ctx
);
1387 static void oberon_statement_seq(oberon_context_t
* ctx
);
1388 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1391 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1393 if(ctx
-> token
!= token
)
1395 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1400 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1402 oberon_expect_token(ctx
, token
);
1403 oberon_read_token(ctx
);
1407 oberon_assert_ident(oberon_context_t
* ctx
)
1409 oberon_expect_token(ctx
, IDENT
);
1410 char * ident
= ctx
-> string
;
1411 oberon_read_token(ctx
);
1416 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1418 switch(ctx
-> token
)
1421 oberon_assert_token(ctx
, STAR
);
1426 oberon_assert_token(ctx
, MINUS
);
1437 static oberon_object_t
*
1438 oberon_ident_def(oberon_context_t
* ctx
, int class)
1443 oberon_object_t
* x
;
1445 name
= oberon_assert_ident(ctx
);
1446 oberon_def(ctx
, &export
, &read_only
);
1448 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
);
1453 oberon_var_decl(oberon_context_t
* ctx
)
1455 oberon_object_t
* var
;
1456 oberon_type_t
* type
;
1457 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1459 var
= oberon_ident_def(ctx
, OBERON_CLASS_VAR
);
1460 oberon_assert_token(ctx
, COLON
);
1461 oberon_type(ctx
, &type
);
1465 static oberon_object_t
*
1466 oberon_make_param(oberon_context_t
* ctx
, int token
, char * name
, oberon_type_t
* type
)
1468 oberon_object_t
* param
;
1472 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR_PARAM
, name
, type
, 0, 0);
1474 else if(token
== IDENT
)
1476 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_PARAM
, name
, type
, 0, 0);
1480 oberon_error(ctx
, "oberon_make_param: wat");
1486 static oberon_object_t
*
1487 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1489 int modifer_token
= ctx
-> token
;
1490 if(ctx
-> token
== VAR
)
1492 oberon_read_token(ctx
);
1496 name
= oberon_assert_ident(ctx
);
1498 oberon_assert_token(ctx
, COLON
);
1500 oberon_type_t
* type
;
1501 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1502 oberon_type(ctx
, &type
);
1504 oberon_object_t
* first
;
1505 first
= oberon_make_param(ctx
, modifer_token
, name
, type
);
1511 #define ISFPSECTION \
1512 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1515 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1517 oberon_assert_token(ctx
, LPAREN
);
1521 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1522 while(ctx
-> token
== SEMICOLON
)
1524 oberon_assert_token(ctx
, SEMICOLON
);
1525 oberon_fp_section(ctx
, &signature
-> num_decl
);
1529 oberon_assert_token(ctx
, RPAREN
);
1531 if(ctx
-> token
== COLON
)
1533 oberon_assert_token(ctx
, COLON
);
1535 oberon_object_t
* typeobj
;
1536 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1537 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1539 oberon_error(ctx
, "function result is not type");
1541 signature
-> base
= typeobj
-> type
;
1546 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1548 oberon_type_t
* signature
;
1550 signature
-> class = OBERON_TYPE_PROCEDURE
;
1551 signature
-> num_decl
= 0;
1552 signature
-> base
= ctx
-> void_type
;
1553 signature
-> decl
= NULL
;
1555 if(ctx
-> token
== LPAREN
)
1557 oberon_formal_pars(ctx
, signature
);
1562 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1564 if(a
-> num_decl
!= b
-> num_decl
)
1566 oberon_error(ctx
, "number parameters not matched");
1569 int num_param
= a
-> num_decl
;
1570 oberon_object_t
* param_a
= a
-> decl
;
1571 oberon_object_t
* param_b
= b
-> decl
;
1572 for(int i
= 0; i
< num_param
; i
++)
1574 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1576 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1579 if(param_a
-> type
!= param_b
-> type
)
1581 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1584 param_a
= param_a
-> next
;
1585 param_b
= param_b
-> next
;
1590 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1592 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1593 oberon_type_t
* result_type
= proc
-> type
-> base
;
1595 if(result_type
-> class == OBERON_TYPE_VOID
)
1599 oberon_error(ctx
, "procedure has no result type");
1606 oberon_error(ctx
, "procedure requires expression on result");
1609 oberon_autocast_to(ctx
, expr
, result_type
);
1612 proc
-> has_return
= 1;
1614 oberon_generate_return(ctx
, expr
);
1618 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1620 oberon_assert_token(ctx
, SEMICOLON
);
1622 ctx
-> decl
= proc
-> scope
;
1624 oberon_decl_seq(ctx
);
1626 oberon_generate_begin_proc(ctx
, proc
);
1628 if(ctx
-> token
== BEGIN
)
1630 oberon_assert_token(ctx
, BEGIN
);
1631 oberon_statement_seq(ctx
);
1634 oberon_assert_token(ctx
, END
);
1635 char * name
= oberon_assert_ident(ctx
);
1636 if(strcmp(name
, proc
-> name
) != 0)
1638 oberon_error(ctx
, "procedure name not matched");
1641 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1642 && proc
-> has_return
== 0)
1644 oberon_make_return(ctx
, NULL
);
1647 if(proc
-> has_return
== 0)
1649 oberon_error(ctx
, "procedure requires return");
1652 oberon_generate_end_proc(ctx
);
1653 oberon_close_scope(ctx
-> decl
);
1657 oberon_proc_decl(oberon_context_t
* ctx
)
1659 oberon_assert_token(ctx
, PROCEDURE
);
1662 if(ctx
-> token
== UPARROW
)
1664 oberon_assert_token(ctx
, UPARROW
);
1671 name
= oberon_assert_ident(ctx
);
1672 oberon_def(ctx
, &export
, &read_only
);
1674 oberon_scope_t
* proc_scope
;
1675 proc_scope
= oberon_open_scope(ctx
);
1676 ctx
-> decl
-> local
= 1;
1678 oberon_type_t
* signature
;
1679 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1680 oberon_opt_formal_pars(ctx
, &signature
);
1682 oberon_initialize_decl(ctx
);
1683 oberon_generator_init_type(ctx
, signature
);
1684 oberon_close_scope(ctx
-> decl
);
1686 oberon_object_t
* proc
;
1687 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1690 if(proc
-> class != OBERON_CLASS_PROC
)
1692 oberon_error(ctx
, "mult definition");
1699 oberon_error(ctx
, "mult procedure definition");
1703 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
1705 oberon_error(ctx
, "export type not matched");
1708 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1712 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
);
1713 proc
-> type
= signature
;
1714 proc
-> scope
= proc_scope
;
1715 oberon_generator_init_proc(ctx
, proc
);
1718 proc
-> scope
-> parent
= proc
;
1723 oberon_proc_decl_body(ctx
, proc
);
1728 oberon_const_decl(oberon_context_t
* ctx
)
1730 oberon_item_t
* value
;
1731 oberon_object_t
* constant
;
1733 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
);
1734 oberon_assert_token(ctx
, EQUAL
);
1735 value
= oberon_const_expr(ctx
);
1736 constant
-> value
= value
;
1740 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
1742 if(size
-> is_item
== 0)
1744 oberon_error(ctx
, "requires constant");
1747 if(size
-> item
.mode
!= MODE_INTEGER
)
1749 oberon_error(ctx
, "requires integer constant");
1752 oberon_type_t
* arr
;
1754 arr
-> class = OBERON_TYPE_ARRAY
;
1755 arr
-> size
= size
-> item
.integer
;
1760 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1762 if(ctx
-> token
== IDENT
)
1765 oberon_type_t
* type
;
1766 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1768 name
= oberon_assert_ident(ctx
);
1769 oberon_assert_token(ctx
, COLON
);
1770 oberon_type(ctx
, &type
);
1771 oberon_define_field(ctx
, rec
, name
, type
);
1776 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1779 oberon_object_t
* to
;
1781 to
= oberon_qualident(ctx
, &name
, 0);
1783 //name = oberon_assert_ident(ctx);
1784 //to = oberon_find_object(ctx -> decl, name, 0);
1788 if(to
-> class != OBERON_CLASS_TYPE
)
1790 oberon_error(ctx
, "not a type");
1795 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, 0, 0);
1796 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1802 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
1805 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1809 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
1817 oberon_type_t
* dim
;
1818 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1820 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
1822 oberon_make_array_type(ctx
, sizes
, dim
, type
);
1826 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1828 if(ctx
-> token
== IDENT
)
1830 oberon_qualident_type(ctx
, type
);
1832 else if(ctx
-> token
== ARRAY
)
1834 oberon_assert_token(ctx
, ARRAY
);
1837 oberon_expr_t
* sizes
;
1838 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
1840 oberon_assert_token(ctx
, OF
);
1842 oberon_type_t
* base
;
1843 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1844 oberon_type(ctx
, &base
);
1846 oberon_make_multiarray(ctx
, sizes
, base
, type
);
1848 else if(ctx
-> token
== RECORD
)
1850 oberon_type_t
* rec
;
1852 rec
-> class = OBERON_TYPE_RECORD
;
1853 oberon_object_t
* list
= malloc(sizeof *list
);
1854 memset(list
, 0, sizeof *list
);
1855 rec
-> num_decl
= 0;
1859 oberon_assert_token(ctx
, RECORD
);
1860 oberon_field_list(ctx
, rec
);
1861 while(ctx
-> token
== SEMICOLON
)
1863 oberon_assert_token(ctx
, SEMICOLON
);
1864 oberon_field_list(ctx
, rec
);
1866 oberon_assert_token(ctx
, END
);
1868 rec
-> decl
= rec
-> decl
-> next
;
1871 else if(ctx
-> token
== POINTER
)
1873 oberon_assert_token(ctx
, POINTER
);
1874 oberon_assert_token(ctx
, TO
);
1876 oberon_type_t
* base
;
1877 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1878 oberon_type(ctx
, &base
);
1880 oberon_type_t
* ptr
;
1882 ptr
-> class = OBERON_TYPE_POINTER
;
1885 else if(ctx
-> token
== PROCEDURE
)
1887 oberon_open_scope(ctx
);
1888 oberon_assert_token(ctx
, PROCEDURE
);
1889 oberon_opt_formal_pars(ctx
, type
);
1890 oberon_close_scope(ctx
-> decl
);
1894 oberon_error(ctx
, "invalid type declaration");
1899 oberon_type_decl(oberon_context_t
* ctx
)
1902 oberon_object_t
* newtype
;
1903 oberon_type_t
* type
;
1907 name
= oberon_assert_ident(ctx
);
1908 oberon_def(ctx
, &export
, &read_only
);
1910 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
1913 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
1914 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1915 assert(newtype
-> type
);
1919 if(newtype
-> class != OBERON_CLASS_TYPE
)
1921 oberon_error(ctx
, "mult definition");
1924 if(newtype
-> linked
)
1926 oberon_error(ctx
, "mult definition - already linked");
1929 newtype
-> export
= export
;
1930 newtype
-> read_only
= read_only
;
1933 oberon_assert_token(ctx
, EQUAL
);
1935 type
= newtype
-> type
;
1936 oberon_type(ctx
, &type
);
1938 if(type
-> class == OBERON_TYPE_VOID
)
1940 oberon_error(ctx
, "recursive alias declaration");
1943 newtype
-> type
= type
;
1944 newtype
-> linked
= 1;
1947 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
1948 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
1951 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
1953 if(type
-> class != OBERON_TYPE_POINTER
1954 && type
-> class != OBERON_TYPE_ARRAY
)
1959 if(type
-> recursive
)
1961 oberon_error(ctx
, "recursive pointer declaration");
1964 if(type
-> base
-> class == OBERON_TYPE_POINTER
)
1966 oberon_error(ctx
, "attempt to make pointer to pointer");
1969 type
-> recursive
= 1;
1971 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
1973 type
-> recursive
= 0;
1977 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
1979 if(type
-> class != OBERON_TYPE_RECORD
)
1984 if(type
-> recursive
)
1986 oberon_error(ctx
, "recursive record declaration");
1989 type
-> recursive
= 1;
1991 int num_fields
= type
-> num_decl
;
1992 oberon_object_t
* field
= type
-> decl
;
1993 for(int i
= 0; i
< num_fields
; i
++)
1995 oberon_prevent_recursive_object(ctx
, field
);
1996 field
= field
-> next
;
1999 type
-> recursive
= 0;
2002 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2004 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2009 if(type
-> recursive
)
2011 oberon_error(ctx
, "recursive procedure declaration");
2014 type
-> recursive
= 1;
2016 int num_fields
= type
-> num_decl
;
2017 oberon_object_t
* field
= type
-> decl
;
2018 for(int i
= 0; i
< num_fields
; i
++)
2020 oberon_prevent_recursive_object(ctx
, field
);
2021 field
= field
-> next
;
2024 type
-> recursive
= 0;
2028 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2030 if(type
-> class != OBERON_TYPE_ARRAY
)
2035 if(type
-> recursive
)
2037 oberon_error(ctx
, "recursive array declaration");
2040 type
-> recursive
= 1;
2042 oberon_prevent_recursive_type(ctx
, type
-> base
);
2044 type
-> recursive
= 0;
2048 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2050 if(type
-> class == OBERON_TYPE_POINTER
)
2052 oberon_prevent_recursive_pointer(ctx
, type
);
2054 else if(type
-> class == OBERON_TYPE_RECORD
)
2056 oberon_prevent_recursive_record(ctx
, type
);
2058 else if(type
-> class == OBERON_TYPE_ARRAY
)
2060 oberon_prevent_recursive_array(ctx
, type
);
2062 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2064 oberon_prevent_recursive_procedure(ctx
, type
);
2069 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2073 case OBERON_CLASS_VAR
:
2074 case OBERON_CLASS_TYPE
:
2075 case OBERON_CLASS_PARAM
:
2076 case OBERON_CLASS_VAR_PARAM
:
2077 case OBERON_CLASS_FIELD
:
2078 oberon_prevent_recursive_type(ctx
, x
-> type
);
2080 case OBERON_CLASS_CONST
:
2081 case OBERON_CLASS_PROC
:
2082 case OBERON_CLASS_MODULE
:
2085 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2091 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2093 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2097 oberon_prevent_recursive_object(ctx
, x
);
2102 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2103 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2106 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2108 if(type
-> class != OBERON_TYPE_RECORD
)
2113 int num_fields
= type
-> num_decl
;
2114 oberon_object_t
* field
= type
-> decl
;
2115 for(int i
= 0; i
< num_fields
; i
++)
2117 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2119 oberon_initialize_type(ctx
, field
-> type
);
2122 oberon_initialize_object(ctx
, field
);
2123 field
= field
-> next
;
2126 oberon_generator_init_record(ctx
, type
);
2130 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2132 if(type
-> class == OBERON_TYPE_VOID
)
2134 oberon_error(ctx
, "undeclarated type");
2137 if(type
-> initialized
)
2142 type
-> initialized
= 1;
2144 if(type
-> class == OBERON_TYPE_POINTER
)
2146 oberon_initialize_type(ctx
, type
-> base
);
2147 oberon_generator_init_type(ctx
, type
);
2149 else if(type
-> class == OBERON_TYPE_ARRAY
)
2151 oberon_initialize_type(ctx
, type
-> base
);
2152 oberon_generator_init_type(ctx
, type
);
2154 else if(type
-> class == OBERON_TYPE_RECORD
)
2156 oberon_generator_init_type(ctx
, type
);
2157 oberon_initialize_record_fields(ctx
, type
);
2159 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2161 int num_fields
= type
-> num_decl
;
2162 oberon_object_t
* field
= type
-> decl
;
2163 for(int i
= 0; i
< num_fields
; i
++)
2165 oberon_initialize_object(ctx
, field
);
2166 field
= field
-> next
;
2169 oberon_generator_init_type(ctx
, type
);
2173 oberon_generator_init_type(ctx
, type
);
2178 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2180 if(x
-> initialized
)
2185 x
-> initialized
= 1;
2189 case OBERON_CLASS_TYPE
:
2190 oberon_initialize_type(ctx
, x
-> type
);
2192 case OBERON_CLASS_VAR
:
2193 case OBERON_CLASS_PARAM
:
2194 case OBERON_CLASS_VAR_PARAM
:
2195 case OBERON_CLASS_FIELD
:
2196 oberon_initialize_type(ctx
, x
-> type
);
2197 oberon_generator_init_var(ctx
, x
);
2199 case OBERON_CLASS_CONST
:
2200 case OBERON_CLASS_PROC
:
2201 case OBERON_CLASS_MODULE
:
2204 oberon_error(ctx
, "oberon_initialize_object: wat");
2210 oberon_initialize_decl(oberon_context_t
* ctx
)
2212 oberon_object_t
* x
= ctx
-> decl
-> list
;
2216 oberon_initialize_object(ctx
, x
-> next
);
2222 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2224 oberon_object_t
* x
= ctx
-> decl
-> list
;
2228 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2230 if(x
-> next
-> linked
== 0)
2232 oberon_error(ctx
, "unresolved forward declaration");
2240 oberon_decl_seq(oberon_context_t
* ctx
)
2242 if(ctx
-> token
== CONST
)
2244 oberon_assert_token(ctx
, CONST
);
2245 while(ctx
-> token
== IDENT
)
2247 oberon_const_decl(ctx
);
2248 oberon_assert_token(ctx
, SEMICOLON
);
2252 if(ctx
-> token
== TYPE
)
2254 oberon_assert_token(ctx
, TYPE
);
2255 while(ctx
-> token
== IDENT
)
2257 oberon_type_decl(ctx
);
2258 oberon_assert_token(ctx
, SEMICOLON
);
2262 if(ctx
-> token
== VAR
)
2264 oberon_assert_token(ctx
, VAR
);
2265 while(ctx
-> token
== IDENT
)
2267 oberon_var_decl(ctx
);
2268 oberon_assert_token(ctx
, SEMICOLON
);
2272 oberon_prevent_recursive_decl(ctx
);
2273 oberon_initialize_decl(ctx
);
2275 while(ctx
-> token
== PROCEDURE
)
2277 oberon_proc_decl(ctx
);
2278 oberon_assert_token(ctx
, SEMICOLON
);
2281 oberon_prevent_undeclarated_procedures(ctx
);
2285 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2287 oberon_autocast_to(ctx
, src
, dst
-> result
);
2288 oberon_generate_assign(ctx
, src
, dst
);
2292 oberon_statement(oberon_context_t
* ctx
)
2294 oberon_expr_t
* item1
;
2295 oberon_expr_t
* item2
;
2297 if(ctx
-> token
== IDENT
)
2299 item1
= oberon_designator(ctx
);
2300 if(ctx
-> token
== ASSIGN
)
2302 oberon_assert_token(ctx
, ASSIGN
);
2303 item2
= oberon_expr(ctx
);
2304 oberon_assign(ctx
, item2
, item1
);
2308 oberon_opt_proc_parens(ctx
, item1
);
2311 else if(ctx
-> token
== RETURN
)
2313 oberon_assert_token(ctx
, RETURN
);
2314 if(ISEXPR(ctx
-> token
))
2316 oberon_expr_t
* expr
;
2317 expr
= oberon_expr(ctx
);
2318 oberon_make_return(ctx
, expr
);
2322 oberon_make_return(ctx
, NULL
);
2328 oberon_statement_seq(oberon_context_t
* ctx
)
2330 oberon_statement(ctx
);
2331 while(ctx
-> token
== SEMICOLON
)
2333 oberon_assert_token(ctx
, SEMICOLON
);
2334 oberon_statement(ctx
);
2339 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2341 oberon_module_t
* m
= ctx
-> module_list
;
2342 while(m
&& strcmp(m
-> name
, name
) != 0)
2350 code
= ctx
-> import_module(name
);
2353 oberon_error(ctx
, "no such module");
2356 m
= oberon_compile_module(ctx
, code
);
2362 oberon_error(ctx
, "cyclic module import");
2365 oberon_object_t
* ident
;
2366 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, 0, 0);
2367 ident
-> module
= m
;
2371 oberon_import_decl(oberon_context_t
* ctx
)
2376 alias
= name
= oberon_assert_ident(ctx
);
2377 if(ctx
-> token
== ASSIGN
)
2379 oberon_assert_token(ctx
, ASSIGN
);
2380 name
= oberon_assert_ident(ctx
);
2383 oberon_import_module(ctx
, alias
, name
);
2387 oberon_import_list(oberon_context_t
* ctx
)
2389 oberon_assert_token(ctx
, IMPORT
);
2391 oberon_import_decl(ctx
);
2392 while(ctx
-> token
== COMMA
)
2394 oberon_assert_token(ctx
, COMMA
);
2395 oberon_import_decl(ctx
);
2398 oberon_assert_token(ctx
, SEMICOLON
);
2402 oberon_parse_module(oberon_context_t
* ctx
)
2406 oberon_read_token(ctx
);
2408 oberon_assert_token(ctx
, MODULE
);
2409 name1
= oberon_assert_ident(ctx
);
2410 oberon_assert_token(ctx
, SEMICOLON
);
2411 ctx
-> mod
-> name
= name1
;
2413 oberon_object_t
* this_module
;
2414 this_module
= oberon_define_object(ctx
-> decl
, name1
, OBERON_CLASS_MODULE
, 0, 0);
2415 this_module
-> module
= ctx
-> mod
;
2417 if(ctx
-> token
== IMPORT
)
2419 oberon_import_list(ctx
);
2422 ctx
-> decl
-> parent
= this_module
;
2424 oberon_decl_seq(ctx
);
2426 oberon_generate_begin_module(ctx
);
2427 if(ctx
-> token
== BEGIN
)
2429 oberon_assert_token(ctx
, BEGIN
);
2430 oberon_statement_seq(ctx
);
2432 oberon_generate_end_module(ctx
);
2434 oberon_assert_token(ctx
, END
);
2435 name2
= oberon_assert_ident(ctx
);
2436 oberon_assert_token(ctx
, DOT
);
2438 if(strcmp(name1
, name2
) != 0)
2440 oberon_error(ctx
, "module name not matched");
2444 // =======================================================================
2446 // =======================================================================
2449 register_default_types(oberon_context_t
* ctx
)
2451 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2452 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2454 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2455 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2456 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2458 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
2459 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1, 0);
2461 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
2462 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1, 0);
2466 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2468 oberon_object_t
* proc
;
2469 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, 1, 0);
2470 proc
-> sysproc
= 1;
2471 proc
-> genfunc
= f
;
2472 proc
-> genproc
= p
;
2473 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2476 static oberon_expr_t
*
2477 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2481 oberon_error(ctx
, "too few arguments");
2486 oberon_error(ctx
, "too mach arguments");
2489 oberon_expr_t
* arg
;
2492 oberon_type_t
* result_type
;
2493 result_type
= arg
-> result
;
2495 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2497 oberon_error(ctx
, "ABS accepts only integers");
2501 oberon_expr_t
* expr
;
2502 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2507 oberon_create_context(ModuleImportCallback import_module
)
2509 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2511 oberon_scope_t
* world_scope
;
2512 world_scope
= oberon_open_scope(ctx
);
2513 ctx
-> world_scope
= world_scope
;
2515 ctx
-> import_module
= import_module
;
2517 oberon_generator_init_context(ctx
);
2519 register_default_types(ctx
);
2520 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2526 oberon_destroy_context(oberon_context_t
* ctx
)
2528 oberon_generator_destroy_context(ctx
);
2533 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2535 const char * code
= ctx
-> code
;
2536 int code_index
= ctx
-> code_index
;
2538 int token
= ctx
-> token
;
2539 char * string
= ctx
-> string
;
2540 int integer
= ctx
-> integer
;
2541 oberon_scope_t
* decl
= ctx
-> decl
;
2542 oberon_module_t
* mod
= ctx
-> mod
;
2544 oberon_scope_t
* module_scope
;
2545 module_scope
= oberon_open_scope(ctx
);
2547 oberon_module_t
* module
;
2548 module
= calloc(1, sizeof *module
);
2549 module
-> decl
= module_scope
;
2550 module
-> next
= ctx
-> module_list
;
2552 ctx
-> mod
= module
;
2553 ctx
-> module_list
= module
;
2555 oberon_init_scaner(ctx
, newcode
);
2556 oberon_parse_module(ctx
);
2558 module
-> ready
= 1;
2561 ctx
-> code_index
= code_index
;
2563 ctx
-> token
= token
;
2564 ctx
-> string
= string
;
2565 ctx
-> integer
= integer
;