f2c901433aeb49363ef01007ed8336a1e5db1919
9 #include "../include/oberon.h"
11 #include "oberon-internals.h"
12 #include "generator.h"
70 // =======================================================================
72 // =======================================================================
75 oberon_error(oberon_context_t
* ctx
, const char * fmt
, ...)
79 fprintf(stderr
, "error: ");
80 vfprintf(stderr
, fmt
, ptr
);
81 fprintf(stderr
, "\n");
82 fprintf(stderr
, " code_index = %i\n", ctx
-> code_index
);
83 fprintf(stderr
, " c = %c\n", ctx
-> c
);
84 fprintf(stderr
, " token = %i\n", ctx
-> token
);
89 static oberon_type_t
*
90 oberon_new_type_ptr(int class)
92 oberon_type_t
* x
= malloc(sizeof *x
);
93 memset(x
, 0, sizeof *x
);
98 static oberon_type_t
*
99 oberon_new_type_integer(int size
)
102 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
107 static oberon_type_t
*
108 oberon_new_type_boolean()
111 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
115 static oberon_type_t
*
116 oberon_new_type_real(int size
)
119 x
= oberon_new_type_ptr(OBERON_TYPE_REAL
);
124 static oberon_type_t
*
125 oberon_new_type_char(int size
)
128 x
= oberon_new_type_ptr(OBERON_TYPE_CHAR
);
133 static oberon_type_t
*
134 oberon_new_type_string(int size
)
137 x
= oberon_new_type_ptr(OBERON_TYPE_STRING
);
142 // =======================================================================
144 // =======================================================================
146 static oberon_scope_t
*
147 oberon_open_scope(oberon_context_t
* ctx
)
149 oberon_scope_t
* scope
= calloc(1, sizeof *scope
);
150 oberon_object_t
* list
= calloc(1, sizeof *list
);
153 scope
-> list
= list
;
154 scope
-> up
= ctx
-> decl
;
158 scope
-> local
= scope
-> up
-> local
;
159 scope
-> parent
= scope
-> up
-> parent
;
160 scope
-> parent_type
= scope
-> up
-> parent_type
;
168 oberon_close_scope(oberon_scope_t
* scope
)
170 oberon_context_t
* ctx
= scope
-> ctx
;
171 ctx
-> decl
= scope
-> up
;
174 static oberon_object_t
*
175 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
177 oberon_object_t
* x
= list
;
178 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
185 static oberon_object_t
*
186 oberon_find_object(oberon_scope_t
* scope
, char * name
, bool check_it
)
188 oberon_object_t
* result
= NULL
;
190 oberon_scope_t
* s
= scope
;
191 while(result
== NULL
&& s
!= NULL
)
193 result
= oberon_find_object_in_list(s
-> list
, name
);
197 if(check_it
&& result
== NULL
)
199 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
205 static oberon_object_t
*
206 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class, bool export
, bool read_only
, bool check_upscope
)
210 if(oberon_find_object(scope
-> up
, name
, false))
212 oberon_error(scope
-> ctx
, "already defined");
216 oberon_object_t
* x
= scope
-> list
;
217 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
224 oberon_error(scope
-> ctx
, "already defined");
227 oberon_object_t
* newvar
= malloc(sizeof *newvar
);
228 memset(newvar
, 0, sizeof *newvar
);
229 newvar
-> name
= name
;
230 newvar
-> class = class;
231 newvar
-> export
= export
;
232 newvar
-> read_only
= read_only
;
233 newvar
-> local
= scope
-> local
;
234 newvar
-> parent
= scope
-> parent
;
235 newvar
-> parent_type
= scope
-> parent_type
;
236 newvar
-> module
= scope
-> ctx
-> mod
;
243 static oberon_object_t
*
244 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
, int export
)
246 oberon_object_t
* id
;
247 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
, export
, false, false);
249 oberon_generator_init_type(scope
-> ctx
, type
);
253 // =======================================================================
255 // =======================================================================
258 oberon_get_char(oberon_context_t
* ctx
)
260 if(ctx
-> code
[ctx
-> code_index
])
262 ctx
-> code_index
+= 1;
263 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
268 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
271 ctx
-> code_index
= 0;
272 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
276 oberon_read_ident(oberon_context_t
* ctx
)
279 int i
= ctx
-> code_index
;
281 int c
= ctx
-> code
[i
];
289 char * ident
= malloc(len
+ 1);
290 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
293 ctx
-> code_index
= i
;
294 ctx
-> c
= ctx
-> code
[i
];
295 ctx
-> string
= ident
;
296 ctx
-> token
= IDENT
;
298 if(strcmp(ident
, "MODULE") == 0)
300 ctx
-> token
= MODULE
;
302 else if(strcmp(ident
, "END") == 0)
306 else if(strcmp(ident
, "VAR") == 0)
310 else if(strcmp(ident
, "BEGIN") == 0)
312 ctx
-> token
= BEGIN
;
314 else if(strcmp(ident
, "TRUE") == 0)
318 else if(strcmp(ident
, "FALSE") == 0)
320 ctx
-> token
= FALSE
;
322 else if(strcmp(ident
, "OR") == 0)
326 else if(strcmp(ident
, "DIV") == 0)
330 else if(strcmp(ident
, "MOD") == 0)
334 else if(strcmp(ident
, "PROCEDURE") == 0)
336 ctx
-> token
= PROCEDURE
;
338 else if(strcmp(ident
, "RETURN") == 0)
340 ctx
-> token
= RETURN
;
342 else if(strcmp(ident
, "CONST") == 0)
344 ctx
-> token
= CONST
;
346 else if(strcmp(ident
, "TYPE") == 0)
350 else if(strcmp(ident
, "ARRAY") == 0)
352 ctx
-> token
= ARRAY
;
354 else if(strcmp(ident
, "OF") == 0)
358 else if(strcmp(ident
, "RECORD") == 0)
360 ctx
-> token
= RECORD
;
362 else if(strcmp(ident
, "POINTER") == 0)
364 ctx
-> token
= POINTER
;
366 else if(strcmp(ident
, "TO") == 0)
370 else if(strcmp(ident
, "NIL") == 0)
374 else if(strcmp(ident
, "IMPORT") == 0)
376 ctx
-> token
= IMPORT
;
378 else if(strcmp(ident
, "IN") == 0)
382 else if(strcmp(ident
, "IS") == 0)
386 else if(strcmp(ident
, "IF") == 0)
390 else if(strcmp(ident
, "THEN") == 0)
394 else if(strcmp(ident
, "ELSE") == 0)
401 oberon_read_number(oberon_context_t
* ctx
)
414 * mode = 3 == LONGREAL
418 start_i
= ctx
-> code_index
;
420 while(isdigit(ctx
-> c
))
422 oberon_get_char(ctx
);
425 end_i
= ctx
-> code_index
;
427 if(isxdigit(ctx
-> c
))
430 while(isxdigit(ctx
-> c
))
432 oberon_get_char(ctx
);
435 end_i
= ctx
-> code_index
;
440 oberon_get_char(ctx
);
442 else if(ctx
-> c
== 'X')
445 oberon_get_char(ctx
);
449 oberon_error(ctx
, "invalid hex number");
452 else if(ctx
-> c
== '.')
455 oberon_get_char(ctx
);
457 while(isdigit(ctx
-> c
))
459 oberon_get_char(ctx
);
462 if(ctx
-> c
== 'E' || ctx
-> c
== 'D')
464 exp_i
= ctx
-> code_index
;
471 oberon_get_char(ctx
);
473 if(ctx
-> c
== '+' || ctx
-> c
== '-')
475 oberon_get_char(ctx
);
478 while(isdigit(ctx
-> c
))
480 oberon_get_char(ctx
);
485 end_i
= ctx
-> code_index
;
493 oberon_get_char(ctx
);
495 else if(ctx
-> c
== 'X')
498 oberon_get_char(ctx
);
502 int len
= end_i
- start_i
;
503 ident
= malloc(len
+ 1);
504 memcpy(ident
, &ctx
-> code
[start_i
], len
);
507 ctx
-> longmode
= false;
510 int i
= exp_i
- start_i
;
512 ctx
-> longmode
= true;
518 integer
= atol(ident
);
520 ctx
-> token
= INTEGER
;
523 sscanf(ident
, "%lx", &integer
);
525 ctx
-> token
= INTEGER
;
529 sscanf(ident
, "%lf", &real
);
533 sscanf(ident
, "%lx", &integer
);
538 oberon_error(ctx
, "oberon_read_number: wat");
542 ctx
-> string
= ident
;
543 ctx
-> integer
= integer
;
548 oberon_skip_space(oberon_context_t
* ctx
)
550 while(isspace(ctx
-> c
))
552 oberon_get_char(ctx
);
557 oberon_read_comment(oberon_context_t
* ctx
)
564 oberon_get_char(ctx
);
567 oberon_get_char(ctx
);
571 else if(ctx
-> c
== '*')
573 oberon_get_char(ctx
);
576 oberon_get_char(ctx
);
580 else if(ctx
-> c
== 0)
582 oberon_error(ctx
, "unterminated comment");
586 oberon_get_char(ctx
);
591 static void oberon_read_string(oberon_context_t
* ctx
)
594 oberon_get_char(ctx
);
596 int start
= ctx
-> code_index
;
598 while(ctx
-> c
!= 0 && ctx
-> c
!= c
)
600 oberon_get_char(ctx
);
605 oberon_error(ctx
, "unterminated string");
608 int end
= ctx
-> code_index
;
610 oberon_get_char(ctx
);
612 char * string
= calloc(1, end
- start
+ 1);
613 strncpy(string
, &ctx
-> code
[start
], end
- start
);
615 ctx
-> token
= STRING
;
616 ctx
-> string
= string
;
618 printf("oberon_read_string: string ((%s))\n", string
);
621 static void oberon_read_token(oberon_context_t
* ctx
);
624 oberon_read_symbol(oberon_context_t
* ctx
)
633 ctx
-> token
= SEMICOLON
;
634 oberon_get_char(ctx
);
637 ctx
-> token
= COLON
;
638 oberon_get_char(ctx
);
641 ctx
-> token
= ASSIGN
;
642 oberon_get_char(ctx
);
647 oberon_get_char(ctx
);
650 ctx
-> token
= LPAREN
;
651 oberon_get_char(ctx
);
654 oberon_get_char(ctx
);
655 oberon_read_comment(ctx
);
656 oberon_read_token(ctx
);
660 ctx
-> token
= RPAREN
;
661 oberon_get_char(ctx
);
664 ctx
-> token
= EQUAL
;
665 oberon_get_char(ctx
);
669 oberon_get_char(ctx
);
673 oberon_get_char(ctx
);
677 oberon_get_char(ctx
);
681 ctx
-> token
= GREAT
;
682 oberon_get_char(ctx
);
686 oberon_get_char(ctx
);
691 oberon_get_char(ctx
);
694 ctx
-> token
= MINUS
;
695 oberon_get_char(ctx
);
699 oberon_get_char(ctx
);
702 oberon_get_char(ctx
);
703 oberon_error(ctx
, "unstarted comment");
707 ctx
-> token
= SLASH
;
708 oberon_get_char(ctx
);
712 oberon_get_char(ctx
);
716 oberon_get_char(ctx
);
719 ctx
-> token
= COMMA
;
720 oberon_get_char(ctx
);
723 ctx
-> token
= LBRACE
;
724 oberon_get_char(ctx
);
727 ctx
-> token
= RBRACE
;
728 oberon_get_char(ctx
);
731 ctx
-> token
= UPARROW
;
732 oberon_get_char(ctx
);
735 oberon_read_string(ctx
);
738 oberon_read_string(ctx
);
741 oberon_error(ctx
, "invalid char %c", ctx
-> c
);
747 oberon_read_token(oberon_context_t
* ctx
)
749 oberon_skip_space(ctx
);
754 oberon_read_ident(ctx
);
758 oberon_read_number(ctx
);
762 oberon_read_symbol(ctx
);
766 // =======================================================================
768 // =======================================================================
770 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
771 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
772 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
773 static char * oberon_assert_ident(oberon_context_t
* ctx
);
774 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
775 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
776 static oberon_expr_t
* oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
);
778 static oberon_expr_t
*
779 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
781 oberon_oper_t
* operator;
782 operator = malloc(sizeof *operator);
783 memset(operator, 0, sizeof *operator);
785 operator -> is_item
= 0;
786 operator -> result
= result
;
787 operator -> read_only
= 1;
789 operator -> left
= left
;
790 operator -> right
= right
;
792 return (oberon_expr_t
*) operator;
795 static oberon_expr_t
*
796 oberon_new_item(int mode
, oberon_type_t
* result
, int read_only
)
798 oberon_item_t
* item
;
799 item
= malloc(sizeof *item
);
800 memset(item
, 0, sizeof *item
);
803 item
-> result
= result
;
804 item
-> read_only
= read_only
;
807 return (oberon_expr_t
*)item
;
810 static oberon_expr_t
*
811 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
813 oberon_expr_t
* expr
;
814 oberon_type_t
* result
;
816 result
= a
-> result
;
820 if(result
-> class != OBERON_TYPE_INTEGER
)
822 oberon_error(ctx
, "incompatible operator type");
825 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
827 else if(token
== NOT
)
829 if(result
-> class != OBERON_TYPE_BOOLEAN
)
831 oberon_error(ctx
, "incompatible operator type");
834 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
838 oberon_error(ctx
, "oberon_make_unary_op: wat");
845 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
847 oberon_expr_t
* last
;
852 *first
= last
= (oberon_expr_t
*) oberon_const_expr(ctx
);
856 *first
= last
= oberon_expr(ctx
);
858 while(ctx
-> token
== COMMA
)
860 oberon_assert_token(ctx
, COMMA
);
861 oberon_expr_t
* current
;
865 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
869 current
= oberon_expr(ctx
);
872 last
-> next
= current
;
878 static oberon_expr_t
*
879 oberon_cast_expr(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
881 return oberon_new_operator(OP_CAST
, pref
, expr
, NULL
);
884 static oberon_expr_t
*
885 oberno_make_record_cast(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* rec
)
887 oberon_type_t
* from
= expr
-> result
;
888 oberon_type_t
* to
= rec
;
890 printf("oberno_make_record_cast: from class %i to class %i\n", from
-> class, to
-> class);
892 if(from
-> class == OBERON_TYPE_POINTER
&& to
-> class == OBERON_TYPE_POINTER
)
894 printf("oberno_make_record_cast: pointers\n");
899 if(from
-> class != OBERON_TYPE_RECORD
|| to
-> class != OBERON_TYPE_RECORD
)
901 oberon_error(ctx
, "must be record type");
904 return oberon_cast_expr(ctx
, expr
, rec
);
907 static oberon_type_t
*
908 oberon_get_equal_expr_type(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
910 oberon_type_t
* result
;
911 if(a
-> class == OBERON_TYPE_REAL
&& b
-> class == OBERON_TYPE_INTEGER
)
915 else if(b
-> class == OBERON_TYPE_REAL
&& a
-> class == OBERON_TYPE_INTEGER
)
919 else if(a
-> class != b
-> class)
921 oberon_error(ctx
, "oberon_get_equal_expr_type: incompatible types");
923 else if(a
-> size
> b
-> size
)
936 oberon_check_record_compatibility(oberon_context_t
* ctx
, oberon_type_t
* from
, oberon_type_t
* to
)
938 if(from
-> class == OBERON_TYPE_POINTER
&& to
-> class == OBERON_TYPE_POINTER
)
944 if(from
-> class != OBERON_TYPE_RECORD
|| to
-> class != OBERON_TYPE_RECORD
)
946 oberon_error(ctx
, "not a record");
949 oberon_type_t
* t
= from
;
950 while(t
!= NULL
&& t
!= to
)
957 oberon_error(ctx
, "incompatible record types");
961 static oberon_expr_t
*
962 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
965 // Если классы типов равны
966 // Если INTEGER переводится в REAL
967 // Есди STRING переводится в ARRAY OF CHAR
970 if(pref
-> class != expr
-> result
-> class)
972 printf("expr class %i\n", expr
-> result
-> class);
973 printf("pref class %i\n", pref
-> class);
975 if(expr
-> result
-> class == OBERON_TYPE_STRING
)
977 if(pref
-> class == OBERON_TYPE_ARRAY
)
979 if(pref
-> base
-> class != OBERON_TYPE_CHAR
)
989 else if(expr
-> result
-> class == OBERON_TYPE_INTEGER
)
991 if(pref
-> class != OBERON_TYPE_REAL
)
1004 oberon_error(ctx
, "oberon_autocast_to: incompatible types");
1007 if(pref
-> class == OBERON_TYPE_INTEGER
|| pref
-> class == OBERON_TYPE_REAL
)
1009 if(expr
-> result
-> size
> pref
-> size
)
1011 oberon_error(ctx
, "incompatible size");
1015 expr
= oberon_cast_expr(ctx
, expr
, pref
);
1018 else if(pref
-> class == OBERON_TYPE_RECORD
)
1020 oberon_check_record_compatibility(ctx
, expr
-> result
, pref
);
1021 expr
= oberno_make_record_cast(ctx
, expr
, pref
);
1023 else if(pref
-> class == OBERON_TYPE_POINTER
)
1025 assert(pref
-> base
);
1026 if(expr
-> result
-> base
-> class == OBERON_TYPE_RECORD
)
1028 oberon_check_record_compatibility(ctx
, expr
-> result
, pref
);
1029 expr
= oberno_make_record_cast(ctx
, expr
, pref
);
1031 else if(expr
-> result
-> base
!= pref
-> base
)
1033 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
1035 oberon_error(ctx
, "incompatible pointer types");
1044 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_expr_t
** ea
, oberon_expr_t
** eb
)
1046 oberon_type_t
* a
= (*ea
) -> result
;
1047 oberon_type_t
* b
= (*eb
) -> result
;
1048 oberon_type_t
* preq
= oberon_get_equal_expr_type(ctx
, a
, b
);
1049 *ea
= oberon_autocast_to(ctx
, *ea
, preq
);
1050 *eb
= oberon_autocast_to(ctx
, *eb
, preq
);
1054 oberon_autocast_call(oberon_context_t
* ctx
, oberon_item_t
* desig
)
1056 if(desig
-> mode
!= MODE_CALL
)
1058 oberon_error(ctx
, "expected mode CALL");
1061 oberon_type_t
* fn
= desig
-> parent
-> result
;
1062 int num_args
= desig
-> num_args
;
1063 int num_decl
= fn
-> num_decl
;
1065 if(num_args
< num_decl
)
1067 oberon_error(ctx
, "too few arguments");
1069 else if(num_args
> num_decl
)
1071 oberon_error(ctx
, "too many arguments");
1074 /* Делаем проверку на запись и делаем автокаст */
1075 oberon_expr_t
* casted
[num_args
];
1076 oberon_expr_t
* arg
= desig
-> args
;
1077 oberon_object_t
* param
= fn
-> decl
;
1078 for(int i
= 0; i
< num_args
; i
++)
1080 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
1082 if(arg
-> read_only
)
1084 oberon_error(ctx
, "assign to read-only var");
1088 casted
[i
] = oberon_autocast_to(ctx
, arg
, param
-> type
);
1090 param
= param
-> next
;
1093 /* Создаём новый список выражений */
1097 for(int i
= 0; i
< num_args
- 1; i
++)
1099 casted
[i
] -> next
= casted
[i
+ 1];
1101 desig
-> args
= arg
;
1105 static oberon_expr_t
*
1106 oberon_make_call_func(oberon_context_t
* ctx
, oberon_item_t
* item
, int num_args
, oberon_expr_t
* list_args
)
1108 oberon_type_t
* signature
= item
-> result
;
1109 if(signature
-> class != OBERON_TYPE_PROCEDURE
)
1111 oberon_error(ctx
, "not a procedure");
1114 oberon_expr_t
* call
;
1116 if(signature
-> sysproc
)
1118 if(signature
-> genfunc
== NULL
)
1120 oberon_error(ctx
, "not a function-procedure");
1123 call
= signature
-> genfunc(ctx
, num_args
, list_args
);
1127 if(signature
-> base
-> class == OBERON_TYPE_VOID
)
1129 oberon_error(ctx
, "attempt to call procedure in expression");
1132 call
= oberon_new_item(MODE_CALL
, signature
-> base
, true);
1133 call
-> item
.parent
= item
;
1134 call
-> item
.num_args
= num_args
;
1135 call
-> item
.args
= list_args
;
1136 oberon_autocast_call(ctx
, (oberon_item_t
*) call
);
1143 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_item_t
* item
, int num_args
, oberon_expr_t
* list_args
)
1145 oberon_type_t
* signature
= item
-> result
;
1146 if(signature
-> class != OBERON_TYPE_PROCEDURE
)
1148 oberon_error(ctx
, "not a procedure");
1151 oberon_expr_t
* call
;
1153 if(signature
-> sysproc
)
1155 if(signature
-> genproc
== NULL
)
1157 oberon_error(ctx
, "not a procedure");
1160 signature
-> genproc(ctx
, num_args
, list_args
);
1164 if(signature
-> base
-> class != OBERON_TYPE_VOID
)
1166 oberon_error(ctx
, "attempt to call function as non-typed procedure");
1169 call
= oberon_new_item(MODE_CALL
, signature
-> base
, true);
1170 call
-> item
.parent
= item
;
1171 call
-> item
.num_args
= num_args
;
1172 call
-> item
.args
= list_args
;
1173 oberon_autocast_call(ctx
, (oberon_item_t
*) call
);
1174 oberon_generate_call_proc(ctx
, call
);
1180 oberon_make_call_proc(oberon_context_t * ctx, oberon_object_t * proc, int num_args, oberon_expr_t * list_args)
1182 switch(proc -> class)
1184 case OBERON_CLASS_PROC:
1185 if(proc -> class != OBERON_CLASS_PROC)
1187 oberon_error(ctx, "not a procedure");
1190 case OBERON_CLASS_VAR:
1191 case OBERON_CLASS_VAR_PARAM:
1192 case OBERON_CLASS_PARAM:
1193 if(proc -> type -> class != OBERON_TYPE_PROCEDURE)
1195 oberon_error(ctx, "not a procedure");
1199 oberon_error(ctx, "not a procedure");
1205 if(proc -> genproc == NULL)
1207 oberon_error(ctx, "requres non-typed procedure");
1210 proc -> genproc(ctx, num_args, list_args);
1214 if(proc -> type -> base -> class != OBERON_TYPE_VOID)
1216 oberon_error(ctx, "attempt to call function as non-typed procedure");
1219 oberon_expr_t * call;
1220 call = oberon_new_item(MODE_CALL, proc -> type -> base, 1);
1221 call -> item.var = proc;
1222 call -> item.num_args = num_args;
1223 call -> item.args = list_args;
1224 oberon_autocast_call(ctx, call);
1225 oberon_generate_call_proc(ctx, call);
1234 || ((x) == INTEGER) \
1237 || ((x) == STRING) \
1239 || ((x) == LPAREN) \
1244 static oberon_expr_t
*
1245 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1247 printf("oberno_make_dereferencing\n");
1248 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
1250 oberon_error(ctx
, "not a pointer");
1253 assert(expr
-> is_item
);
1255 oberon_expr_t
* selector
;
1256 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
, expr
-> read_only
);
1257 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1262 static oberon_expr_t
*
1263 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
1265 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
1267 desig
= oberno_make_dereferencing(ctx
, desig
);
1270 assert(desig
-> is_item
);
1272 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
1274 oberon_error(ctx
, "not array");
1277 oberon_type_t
* base
;
1278 base
= desig
-> result
-> base
;
1280 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
1282 oberon_error(ctx
, "index must be integer");
1285 // Статическая проверка границ массива
1286 if(desig
-> result
-> size
!= 0)
1288 if(index
-> is_item
)
1290 if(index
-> item
.mode
== MODE_INTEGER
)
1292 int arr_size
= desig
-> result
-> size
;
1293 int index_int
= index
-> item
.integer
;
1294 if(index_int
< 0 || index_int
> arr_size
- 1)
1296 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
1302 oberon_expr_t
* selector
;
1303 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
1304 selector
-> item
.parent
= (oberon_item_t
*) desig
;
1305 selector
-> item
.num_args
= 1;
1306 selector
-> item
.args
= index
;
1311 static oberon_expr_t
*
1312 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
1314 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
1316 expr
= oberno_make_dereferencing(ctx
, expr
);
1319 assert(expr
-> is_item
);
1321 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
1323 oberon_error(ctx
, "not record");
1326 oberon_type_t
* rec
= expr
-> result
;
1328 oberon_object_t
* field
;
1329 field
= oberon_find_object(rec
-> scope
, name
, true);
1331 if(field
-> export
== 0)
1333 if(field
-> module
!= ctx
-> mod
)
1335 oberon_error(ctx
, "field not exported");
1340 if(field
-> read_only
)
1342 if(field
-> module
!= ctx
-> mod
)
1348 oberon_expr_t
* selector
;
1349 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
1350 selector
-> item
.var
= field
;
1351 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1356 #define ISSELECTOR(x) \
1359 || ((x) == UPARROW) \
1362 static oberon_object_t
*
1363 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
1366 oberon_object_t
* x
;
1368 name
= oberon_assert_ident(ctx
);
1369 x
= oberon_find_object(ctx
-> decl
, name
, check
);
1373 if(x
-> class == OBERON_CLASS_MODULE
)
1375 oberon_assert_token(ctx
, DOT
);
1376 name
= oberon_assert_ident(ctx
);
1377 /* Наличие объектов в левых модулях всегда проверяется */
1378 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1380 if(x
-> export
== 0)
1382 oberon_error(ctx
, "not exported");
1395 static oberon_expr_t
*
1396 oberon_designator(oberon_context_t
* ctx
)
1399 oberon_object_t
* var
;
1400 oberon_expr_t
* expr
;
1402 var
= oberon_qualident(ctx
, NULL
, 1);
1405 if(var
-> read_only
)
1407 if(var
-> module
!= ctx
-> mod
)
1413 switch(var
-> class)
1415 case OBERON_CLASS_CONST
:
1417 expr
= (oberon_expr_t
*) var
-> value
;
1419 case OBERON_CLASS_VAR
:
1420 case OBERON_CLASS_VAR_PARAM
:
1421 case OBERON_CLASS_PARAM
:
1422 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
1424 case OBERON_CLASS_PROC
:
1425 expr
= oberon_new_item(MODE_VAR
, var
-> type
, 1);
1428 oberon_error(ctx
, "invalid designator");
1431 expr
-> item
.var
= var
;
1433 while(expr
-> result
-> class != OBERON_TYPE_PROCEDURE
&& ISSELECTOR(ctx
-> token
))
1435 switch(ctx
-> token
)
1438 oberon_assert_token(ctx
, DOT
);
1439 name
= oberon_assert_ident(ctx
);
1440 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1443 oberon_assert_token(ctx
, LBRACE
);
1444 int num_indexes
= 0;
1445 oberon_expr_t
* indexes
= NULL
;
1446 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1447 oberon_assert_token(ctx
, RBRACE
);
1449 for(int i
= 0; i
< num_indexes
; i
++)
1451 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1452 indexes
= indexes
-> next
;
1456 oberon_assert_token(ctx
, UPARROW
);
1457 expr
= oberno_make_dereferencing(ctx
, expr
);
1460 oberon_assert_token(ctx
, LPAREN
);
1461 oberon_object_t
* objtype
= oberon_qualident(ctx
, NULL
, 1);
1462 if(objtype
-> class != OBERON_CLASS_TYPE
)
1464 oberon_error(ctx
, "must be type");
1466 oberon_assert_token(ctx
, RPAREN
);
1467 expr
= oberno_make_record_cast(ctx
, expr
, objtype
-> type
);
1470 oberon_error(ctx
, "oberon_designator: wat");
1478 static oberon_expr_t
*
1479 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1481 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1482 if(ctx
-> token
== LPAREN
)
1484 oberon_assert_token(ctx
, LPAREN
);
1487 oberon_expr_t
* arguments
= NULL
;
1489 if(ISEXPR(ctx
-> token
))
1491 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1494 assert(expr
-> is_item
== 1);
1495 expr
= oberon_make_call_func(ctx
, (oberon_item_t
*) expr
, num_args
, arguments
);
1497 oberon_assert_token(ctx
, RPAREN
);
1504 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1506 assert(expr
-> is_item
);
1509 oberon_expr_t
* arguments
= NULL
;
1511 if(ctx
-> token
== LPAREN
)
1513 oberon_assert_token(ctx
, LPAREN
);
1515 if(ISEXPR(ctx
-> token
))
1517 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1520 oberon_assert_token(ctx
, RPAREN
);
1523 /* Вызов происходит даже без скобок */
1524 oberon_make_call_proc(ctx
, (oberon_item_t
*) expr
, num_args
, arguments
);
1527 static oberon_type_t
*
1528 oberon_get_type_of_int_value(oberon_context_t
* ctx
, int64_t i
)
1530 if(i
>= -128 && i
<= 127)
1532 return ctx
-> byte_type
;
1534 else if(i
>= -32768 && i
<= 32767)
1536 return ctx
-> shortint_type
;
1538 else if(i
>= -2147483648 && i
<= 2147483647)
1540 return ctx
-> int_type
;
1544 return ctx
-> longint_type
;
1548 static oberon_expr_t
*
1549 oberon_factor(oberon_context_t
* ctx
)
1551 oberon_expr_t
* expr
;
1552 oberon_type_t
* result
;
1554 switch(ctx
-> token
)
1557 expr
= oberon_designator(ctx
);
1558 expr
= oberon_opt_func_parens(ctx
, expr
);
1561 result
= oberon_get_type_of_int_value(ctx
, ctx
-> integer
);
1562 expr
= oberon_new_item(MODE_INTEGER
, result
, true);
1563 expr
-> item
.integer
= ctx
-> integer
;
1564 oberon_assert_token(ctx
, INTEGER
);
1567 result
= ctx
-> char_type
;
1568 expr
= oberon_new_item(MODE_CHAR
, result
, true);
1569 expr
-> item
.integer
= ctx
-> integer
;
1570 oberon_assert_token(ctx
, CHAR
);
1573 result
= ctx
-> string_type
;
1574 expr
= oberon_new_item(MODE_STRING
, result
, true);
1575 expr
-> item
.string
= ctx
-> string
;
1576 oberon_assert_token(ctx
, STRING
);
1579 result
= (ctx
-> longmode
) ? (ctx
-> longreal_type
) : (ctx
-> real_type
);
1580 expr
= oberon_new_item(MODE_REAL
, result
, 1);
1581 expr
-> item
.real
= ctx
-> real
;
1582 oberon_assert_token(ctx
, REAL
);
1585 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, true);
1586 expr
-> item
.boolean
= true;
1587 oberon_assert_token(ctx
, TRUE
);
1590 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, true);
1591 expr
-> item
.boolean
= false;
1592 oberon_assert_token(ctx
, FALSE
);
1595 oberon_assert_token(ctx
, LPAREN
);
1596 expr
= oberon_expr(ctx
);
1597 oberon_assert_token(ctx
, RPAREN
);
1600 oberon_assert_token(ctx
, NOT
);
1601 expr
= oberon_factor(ctx
);
1602 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1605 oberon_assert_token(ctx
, NIL
);
1606 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
, true);
1609 oberon_error(ctx
, "invalid expression");
1615 #define ITMAKESBOOLEAN(x) \
1616 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1618 #define ITUSEONLYINTEGER(x) \
1619 ((x) >= LESS && (x) <= GEQ)
1621 #define ITUSEONLYBOOLEAN(x) \
1622 (((x) == OR) || ((x) == AND))
1625 oberon_autocast_to_real(oberon_context_t
* ctx
, oberon_expr_t
** e
)
1627 oberon_expr_t
* expr
= *e
;
1628 if(expr
-> result
-> class == OBERON_TYPE_INTEGER
)
1630 if(expr
-> result
-> size
<= ctx
-> real_type
-> size
)
1632 *e
= oberon_cast_expr(ctx
, expr
, ctx
-> real_type
);
1636 *e
= oberon_cast_expr(ctx
, expr
, ctx
-> longreal_type
);
1639 else if(expr
-> result
-> class != OBERON_TYPE_REAL
)
1641 oberon_error(ctx
, "required numeric type");
1645 static oberon_expr_t
*
1646 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1648 oberon_expr_t
* expr
;
1649 oberon_type_t
* result
;
1651 if(ITMAKESBOOLEAN(token
))
1653 if(ITUSEONLYINTEGER(token
))
1655 if(a
-> result
-> class == OBERON_TYPE_INTEGER
1656 || b
-> result
-> class == OBERON_TYPE_INTEGER
1657 || a
-> result
-> class == OBERON_TYPE_REAL
1658 || b
-> result
-> class == OBERON_TYPE_REAL
)
1664 oberon_error(ctx
, "used only with numeric types");
1667 else if(ITUSEONLYBOOLEAN(token
))
1669 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1670 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1672 oberon_error(ctx
, "used only with boolean type");
1676 oberon_autocast_binary_op(ctx
, &a
, &b
);
1677 result
= ctx
-> bool_type
;
1681 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1683 else if(token
== NEQ
)
1685 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1687 else if(token
== LESS
)
1689 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1691 else if(token
== LEQ
)
1693 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1695 else if(token
== GREAT
)
1697 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1699 else if(token
== GEQ
)
1701 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1703 else if(token
== OR
)
1705 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1707 else if(token
== AND
)
1709 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1713 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1716 else if(token
== SLASH
)
1718 oberon_autocast_to_real(ctx
, &a
);
1719 oberon_autocast_to_real(ctx
, &b
);
1720 oberon_autocast_binary_op(ctx
, &a
, &b
);
1721 expr
= oberon_new_operator(OP_DIV
, a
-> result
, a
, b
);
1723 else if(token
== DIV
)
1725 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1726 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1728 oberon_error(ctx
, "operator DIV requires integer type");
1731 oberon_autocast_binary_op(ctx
, &a
, &b
);
1732 expr
= oberon_new_operator(OP_DIV
, a
-> result
, a
, b
);
1736 oberon_autocast_binary_op(ctx
, &a
, &b
);
1740 expr
= oberon_new_operator(OP_ADD
, a
-> result
, a
, b
);
1742 else if(token
== MINUS
)
1744 expr
= oberon_new_operator(OP_SUB
, a
-> result
, a
, b
);
1746 else if(token
== STAR
)
1748 expr
= oberon_new_operator(OP_MUL
, a
-> result
, a
, b
);
1750 else if(token
== MOD
)
1752 expr
= oberon_new_operator(OP_MOD
, a
-> result
, a
, b
);
1756 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1763 #define ISMULOP(x) \
1764 ((x) >= STAR && (x) <= AND)
1766 static oberon_expr_t
*
1767 oberon_term_expr(oberon_context_t
* ctx
)
1769 oberon_expr_t
* expr
;
1771 expr
= oberon_factor(ctx
);
1772 while(ISMULOP(ctx
-> token
))
1774 int token
= ctx
-> token
;
1775 oberon_read_token(ctx
);
1777 oberon_expr_t
* inter
= oberon_factor(ctx
);
1778 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1784 #define ISADDOP(x) \
1785 ((x) >= PLUS && (x) <= OR)
1787 static oberon_expr_t
*
1788 oberon_simple_expr(oberon_context_t
* ctx
)
1790 oberon_expr_t
* expr
;
1793 if(ctx
-> token
== PLUS
)
1796 oberon_assert_token(ctx
, PLUS
);
1798 else if(ctx
-> token
== MINUS
)
1801 oberon_assert_token(ctx
, MINUS
);
1804 expr
= oberon_term_expr(ctx
);
1808 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1811 while(ISADDOP(ctx
-> token
))
1813 int token
= ctx
-> token
;
1814 oberon_read_token(ctx
);
1816 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1817 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1823 #define ISRELATION(x) \
1824 ((x) >= EQUAL && (x) <= IS)
1826 static oberon_expr_t
*
1827 oberon_expr(oberon_context_t
* ctx
)
1829 oberon_expr_t
* expr
;
1831 expr
= oberon_simple_expr(ctx
);
1832 while(ISRELATION(ctx
-> token
))
1834 int token
= ctx
-> token
;
1835 oberon_read_token(ctx
);
1837 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1838 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1844 static oberon_item_t
*
1845 oberon_const_expr(oberon_context_t
* ctx
)
1847 oberon_expr_t
* expr
;
1848 expr
= oberon_expr(ctx
);
1850 if(expr
-> is_item
== 0)
1852 oberon_error(ctx
, "const expression are required");
1855 return (oberon_item_t
*) expr
;
1858 // =======================================================================
1860 // =======================================================================
1862 static void oberon_decl_seq(oberon_context_t
* ctx
);
1863 static void oberon_statement_seq(oberon_context_t
* ctx
);
1864 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1867 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1869 if(ctx
-> token
!= token
)
1871 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1876 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1878 oberon_expect_token(ctx
, token
);
1879 oberon_read_token(ctx
);
1883 oberon_assert_ident(oberon_context_t
* ctx
)
1885 oberon_expect_token(ctx
, IDENT
);
1886 char * ident
= ctx
-> string
;
1887 oberon_read_token(ctx
);
1892 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1894 switch(ctx
-> token
)
1897 oberon_assert_token(ctx
, STAR
);
1902 oberon_assert_token(ctx
, MINUS
);
1913 static oberon_object_t
*
1914 oberon_ident_def(oberon_context_t
* ctx
, int class, bool check_upscope
)
1919 oberon_object_t
* x
;
1921 name
= oberon_assert_ident(ctx
);
1922 oberon_def(ctx
, &export
, &read_only
);
1924 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
, check_upscope
);
1929 oberon_ident_list(oberon_context_t
* ctx
, int class, bool check_upscope
, int * num
, oberon_object_t
** list
)
1932 *list
= oberon_ident_def(ctx
, class, check_upscope
);
1933 while(ctx
-> token
== COMMA
)
1935 oberon_assert_token(ctx
, COMMA
);
1936 oberon_ident_def(ctx
, class, check_upscope
);
1942 oberon_var_decl(oberon_context_t
* ctx
)
1945 oberon_object_t
* list
;
1946 oberon_type_t
* type
;
1947 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1949 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, false, &num
, &list
);
1950 oberon_assert_token(ctx
, COLON
);
1951 oberon_type(ctx
, &type
);
1953 oberon_object_t
* var
= list
;
1954 for(int i
= 0; i
< num
; i
++)
1961 static oberon_object_t
*
1962 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1964 int class = OBERON_CLASS_PARAM
;
1965 if(ctx
-> token
== VAR
)
1967 oberon_read_token(ctx
);
1968 class = OBERON_CLASS_VAR_PARAM
;
1972 oberon_object_t
* list
;
1973 oberon_ident_list(ctx
, class, false, &num
, &list
);
1975 oberon_assert_token(ctx
, COLON
);
1977 oberon_type_t
* type
;
1978 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1979 oberon_type(ctx
, &type
);
1981 oberon_object_t
* param
= list
;
1982 for(int i
= 0; i
< num
; i
++)
1984 param
-> type
= type
;
1985 param
= param
-> next
;
1992 #define ISFPSECTION \
1993 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1996 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1998 oberon_assert_token(ctx
, LPAREN
);
2002 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
2003 while(ctx
-> token
== SEMICOLON
)
2005 oberon_assert_token(ctx
, SEMICOLON
);
2006 oberon_fp_section(ctx
, &signature
-> num_decl
);
2010 oberon_assert_token(ctx
, RPAREN
);
2012 if(ctx
-> token
== COLON
)
2014 oberon_assert_token(ctx
, COLON
);
2016 oberon_object_t
* typeobj
;
2017 typeobj
= oberon_qualident(ctx
, NULL
, 1);
2018 if(typeobj
-> class != OBERON_CLASS_TYPE
)
2020 oberon_error(ctx
, "function result is not type");
2022 signature
-> base
= typeobj
-> type
;
2027 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
2029 oberon_type_t
* signature
;
2031 signature
-> class = OBERON_TYPE_PROCEDURE
;
2032 signature
-> num_decl
= 0;
2033 signature
-> base
= ctx
-> void_type
;
2034 signature
-> decl
= NULL
;
2036 if(ctx
-> token
== LPAREN
)
2038 oberon_formal_pars(ctx
, signature
);
2043 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
2045 if(a
-> num_decl
!= b
-> num_decl
)
2047 oberon_error(ctx
, "number parameters not matched");
2050 int num_param
= a
-> num_decl
;
2051 oberon_object_t
* param_a
= a
-> decl
;
2052 oberon_object_t
* param_b
= b
-> decl
;
2053 for(int i
= 0; i
< num_param
; i
++)
2055 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
2057 oberon_error(ctx
, "param %i name not matched", i
+ 1);
2060 if(param_a
-> type
!= param_b
-> type
)
2062 oberon_error(ctx
, "param %i type not matched", i
+ 1);
2065 param_a
= param_a
-> next
;
2066 param_b
= param_b
-> next
;
2071 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
2073 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
2074 oberon_type_t
* result_type
= proc
-> type
-> base
;
2076 if(result_type
-> class == OBERON_TYPE_VOID
)
2080 oberon_error(ctx
, "procedure has no result type");
2087 oberon_error(ctx
, "procedure requires expression on result");
2090 expr
= oberon_autocast_to(ctx
, expr
, result_type
);
2093 proc
-> has_return
= 1;
2095 oberon_generate_return(ctx
, expr
);
2099 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
2101 oberon_assert_token(ctx
, SEMICOLON
);
2103 ctx
-> decl
= proc
-> scope
;
2105 oberon_decl_seq(ctx
);
2107 oberon_generate_begin_proc(ctx
, proc
);
2109 if(ctx
-> token
== BEGIN
)
2111 oberon_assert_token(ctx
, BEGIN
);
2112 oberon_statement_seq(ctx
);
2115 oberon_assert_token(ctx
, END
);
2116 char * name
= oberon_assert_ident(ctx
);
2117 if(strcmp(name
, proc
-> name
) != 0)
2119 oberon_error(ctx
, "procedure name not matched");
2122 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
2123 && proc
-> has_return
== 0)
2125 oberon_make_return(ctx
, NULL
);
2128 if(proc
-> has_return
== 0)
2130 oberon_error(ctx
, "procedure requires return");
2133 oberon_generate_end_proc(ctx
);
2134 oberon_close_scope(ctx
-> decl
);
2138 oberon_proc_decl(oberon_context_t
* ctx
)
2140 oberon_assert_token(ctx
, PROCEDURE
);
2143 if(ctx
-> token
== UPARROW
)
2145 oberon_assert_token(ctx
, UPARROW
);
2152 name
= oberon_assert_ident(ctx
);
2153 oberon_def(ctx
, &export
, &read_only
);
2155 oberon_scope_t
* proc_scope
;
2156 proc_scope
= oberon_open_scope(ctx
);
2157 ctx
-> decl
-> local
= 1;
2159 oberon_type_t
* signature
;
2160 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2161 oberon_opt_formal_pars(ctx
, &signature
);
2163 oberon_initialize_decl(ctx
);
2164 oberon_generator_init_type(ctx
, signature
);
2165 oberon_close_scope(ctx
-> decl
);
2167 oberon_object_t
* proc
;
2168 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
2171 if(proc
-> class != OBERON_CLASS_PROC
)
2173 oberon_error(ctx
, "mult definition");
2180 oberon_error(ctx
, "mult procedure definition");
2184 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
2186 oberon_error(ctx
, "export type not matched");
2189 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
2193 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
, false);
2194 proc
-> type
= signature
;
2195 proc
-> scope
= proc_scope
;
2196 oberon_generator_init_proc(ctx
, proc
);
2199 proc
-> scope
-> parent
= proc
;
2204 oberon_proc_decl_body(ctx
, proc
);
2209 oberon_const_decl(oberon_context_t
* ctx
)
2211 oberon_item_t
* value
;
2212 oberon_object_t
* constant
;
2214 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
, false);
2215 oberon_assert_token(ctx
, EQUAL
);
2216 value
= oberon_const_expr(ctx
);
2217 constant
-> value
= value
;
2221 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
2223 if(size
-> is_item
== 0)
2225 oberon_error(ctx
, "requires constant");
2228 if(size
-> item
.mode
!= MODE_INTEGER
)
2230 oberon_error(ctx
, "requires integer constant");
2233 oberon_type_t
* arr
;
2235 arr
-> class = OBERON_TYPE_ARRAY
;
2236 arr
-> size
= size
-> item
.integer
;
2241 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2244 oberon_object_t
* to
;
2246 to
= oberon_qualident(ctx
, &name
, 0);
2248 //name = oberon_assert_ident(ctx);
2249 //to = oberon_find_object(ctx -> decl, name, 0);
2253 if(to
-> class != OBERON_CLASS_TYPE
)
2255 oberon_error(ctx
, "not a type");
2260 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, false, false, false);
2261 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2267 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
2270 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2274 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
2282 oberon_type_t
* dim
;
2283 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2285 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
2287 oberon_make_array_type(ctx
, sizes
, dim
, type
);
2291 oberon_make_open_array(oberon_context_t
* ctx
, oberon_type_t
* base
, oberon_type_t
* type
)
2293 type
-> class = OBERON_TYPE_ARRAY
;
2295 type
-> base
= base
;
2299 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
, oberon_scope_t
* modscope
)
2301 if(ctx
-> token
== IDENT
)
2304 oberon_object_t
* list
;
2305 oberon_type_t
* type
;
2306 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2308 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, true, &num
, &list
);
2309 oberon_assert_token(ctx
, COLON
);
2311 oberon_scope_t
* current
= ctx
-> decl
;
2312 ctx
-> decl
= modscope
;
2313 oberon_type(ctx
, &type
);
2314 ctx
-> decl
= current
;
2316 oberon_object_t
* field
= list
;
2317 for(int i
= 0; i
< num
; i
++)
2319 field
-> type
= type
;
2320 field
= field
-> next
;
2323 rec
-> num_decl
+= num
;
2328 oberon_type_record_body(oberon_context_t
* ctx
, oberon_type_t
* rec
)
2330 oberon_scope_t
* modscope
= ctx
-> mod
-> decl
;
2331 oberon_scope_t
* oldscope
= ctx
-> decl
;
2332 ctx
-> decl
= modscope
;
2334 if(ctx
-> token
== LPAREN
)
2336 oberon_assert_token(ctx
, LPAREN
);
2338 oberon_object_t
* typeobj
;
2339 typeobj
= oberon_qualident(ctx
, NULL
, true);
2341 if(typeobj
-> class != OBERON_CLASS_TYPE
)
2343 oberon_error(ctx
, "base must be type");
2346 oberon_type_t
* base
= typeobj
-> type
;
2347 if(base
-> class == OBERON_TYPE_POINTER
)
2349 base
= base
-> base
;
2352 if(base
-> class != OBERON_TYPE_RECORD
)
2354 oberon_error(ctx
, "base must be record type");
2358 ctx
-> decl
= base
-> scope
;
2360 oberon_assert_token(ctx
, RPAREN
);
2367 oberon_scope_t
* this_scope
;
2368 this_scope
= oberon_open_scope(ctx
);
2369 this_scope
-> local
= true;
2370 this_scope
-> parent
= NULL
;
2371 this_scope
-> parent_type
= rec
;
2373 oberon_field_list(ctx
, rec
, modscope
);
2374 while(ctx
-> token
== SEMICOLON
)
2376 oberon_assert_token(ctx
, SEMICOLON
);
2377 oberon_field_list(ctx
, rec
, modscope
);
2380 rec
-> scope
= this_scope
;
2381 rec
-> decl
= this_scope
-> list
-> next
;
2382 ctx
-> decl
= oldscope
;
2386 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2388 if(ctx
-> token
== IDENT
)
2390 oberon_qualident_type(ctx
, type
);
2392 else if(ctx
-> token
== ARRAY
)
2394 oberon_assert_token(ctx
, ARRAY
);
2397 oberon_expr_t
* sizes
;
2399 if(ISEXPR(ctx
-> token
))
2401 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
2404 oberon_assert_token(ctx
, OF
);
2406 oberon_type_t
* base
;
2407 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2408 oberon_type(ctx
, &base
);
2412 oberon_make_open_array(ctx
, base
, *type
);
2416 oberon_make_multiarray(ctx
, sizes
, base
, type
);
2419 else if(ctx
-> token
== RECORD
)
2421 oberon_type_t
* rec
;
2423 rec
-> class = OBERON_TYPE_RECORD
;
2424 rec
-> module
= ctx
-> mod
;
2426 oberon_assert_token(ctx
, RECORD
);
2427 oberon_type_record_body(ctx
, rec
);
2428 oberon_assert_token(ctx
, END
);
2432 else if(ctx
-> token
== POINTER
)
2434 oberon_assert_token(ctx
, POINTER
);
2435 oberon_assert_token(ctx
, TO
);
2437 oberon_type_t
* base
;
2438 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2439 oberon_type(ctx
, &base
);
2441 oberon_type_t
* ptr
;
2443 ptr
-> class = OBERON_TYPE_POINTER
;
2446 else if(ctx
-> token
== PROCEDURE
)
2448 oberon_open_scope(ctx
);
2449 oberon_assert_token(ctx
, PROCEDURE
);
2450 oberon_opt_formal_pars(ctx
, type
);
2451 oberon_close_scope(ctx
-> decl
);
2455 oberon_error(ctx
, "invalid type declaration");
2460 oberon_type_decl(oberon_context_t
* ctx
)
2463 oberon_object_t
* newtype
;
2464 oberon_type_t
* type
;
2468 name
= oberon_assert_ident(ctx
);
2469 oberon_def(ctx
, &export
, &read_only
);
2471 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
2474 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
, false);
2475 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2476 assert(newtype
-> type
);
2480 if(newtype
-> class != OBERON_CLASS_TYPE
)
2482 oberon_error(ctx
, "mult definition");
2485 if(newtype
-> linked
)
2487 oberon_error(ctx
, "mult definition - already linked");
2490 newtype
-> export
= export
;
2491 newtype
-> read_only
= read_only
;
2494 oberon_assert_token(ctx
, EQUAL
);
2496 type
= newtype
-> type
;
2497 oberon_type(ctx
, &type
);
2499 if(type
-> class == OBERON_TYPE_VOID
)
2501 oberon_error(ctx
, "recursive alias declaration");
2504 newtype
-> type
= type
;
2505 newtype
-> linked
= 1;
2508 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2509 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2512 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
2514 if(type
-> class != OBERON_TYPE_POINTER
2515 && type
-> class != OBERON_TYPE_ARRAY
)
2520 if(type
-> recursive
)
2522 oberon_error(ctx
, "recursive pointer declaration");
2525 if(type
-> class == OBERON_TYPE_POINTER
2526 && type
-> base
-> class == OBERON_TYPE_POINTER
)
2528 oberon_error(ctx
, "attempt to make pointer to pointer");
2531 type
-> recursive
= 1;
2533 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
2535 type
-> recursive
= 0;
2539 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
2541 if(type
-> class != OBERON_TYPE_RECORD
)
2546 if(type
-> recursive
)
2548 oberon_error(ctx
, "recursive record declaration");
2551 type
-> recursive
= 1;
2553 int num_fields
= type
-> num_decl
;
2554 oberon_object_t
* field
= type
-> decl
;
2555 for(int i
= 0; i
< num_fields
; i
++)
2557 oberon_prevent_recursive_object(ctx
, field
);
2558 field
= field
-> next
;
2561 type
-> recursive
= 0;
2564 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2566 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2571 if(type
-> recursive
)
2573 oberon_error(ctx
, "recursive procedure declaration");
2576 type
-> recursive
= 1;
2578 int num_fields
= type
-> num_decl
;
2579 oberon_object_t
* field
= type
-> decl
;
2580 for(int i
= 0; i
< num_fields
; i
++)
2582 oberon_prevent_recursive_object(ctx
, field
);
2583 field
= field
-> next
;
2586 type
-> recursive
= 0;
2590 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2592 if(type
-> class != OBERON_TYPE_ARRAY
)
2597 if(type
-> recursive
)
2599 oberon_error(ctx
, "recursive array declaration");
2602 type
-> recursive
= 1;
2604 oberon_prevent_recursive_type(ctx
, type
-> base
);
2606 type
-> recursive
= 0;
2610 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2612 if(type
-> class == OBERON_TYPE_POINTER
)
2614 oberon_prevent_recursive_pointer(ctx
, type
);
2616 else if(type
-> class == OBERON_TYPE_RECORD
)
2618 oberon_prevent_recursive_record(ctx
, type
);
2620 else if(type
-> class == OBERON_TYPE_ARRAY
)
2622 oberon_prevent_recursive_array(ctx
, type
);
2624 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2626 oberon_prevent_recursive_procedure(ctx
, type
);
2631 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2635 case OBERON_CLASS_VAR
:
2636 case OBERON_CLASS_TYPE
:
2637 case OBERON_CLASS_PARAM
:
2638 case OBERON_CLASS_VAR_PARAM
:
2639 case OBERON_CLASS_FIELD
:
2640 oberon_prevent_recursive_type(ctx
, x
-> type
);
2642 case OBERON_CLASS_CONST
:
2643 case OBERON_CLASS_PROC
:
2644 case OBERON_CLASS_MODULE
:
2647 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2653 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2655 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2659 oberon_prevent_recursive_object(ctx
, x
);
2664 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2665 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2668 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2670 if(type
-> class != OBERON_TYPE_RECORD
)
2675 int num_fields
= type
-> num_decl
;
2676 oberon_object_t
* field
= type
-> decl
;
2677 for(int i
= 0; i
< num_fields
; i
++)
2679 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2681 oberon_initialize_type(ctx
, field
-> type
);
2684 oberon_initialize_object(ctx
, field
);
2685 field
= field
-> next
;
2688 oberon_generator_init_record(ctx
, type
);
2692 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2694 if(type
-> class == OBERON_TYPE_VOID
)
2696 oberon_error(ctx
, "undeclarated type");
2699 if(type
-> initialized
)
2704 type
-> initialized
= 1;
2706 if(type
-> class == OBERON_TYPE_POINTER
)
2708 oberon_initialize_type(ctx
, type
-> base
);
2709 oberon_generator_init_type(ctx
, type
);
2711 else if(type
-> class == OBERON_TYPE_ARRAY
)
2713 if(type
-> size
!= 0)
2715 if(type
-> base
-> class == OBERON_TYPE_ARRAY
)
2717 if(type
-> base
-> size
== 0)
2719 oberon_error(ctx
, "open array not allowed as array element");
2724 oberon_initialize_type(ctx
, type
-> base
);
2725 oberon_generator_init_type(ctx
, type
);
2727 else if(type
-> class == OBERON_TYPE_RECORD
)
2729 oberon_generator_init_type(ctx
, type
);
2730 oberon_initialize_record_fields(ctx
, type
);
2732 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2734 int num_fields
= type
-> num_decl
;
2735 oberon_object_t
* field
= type
-> decl
;
2736 for(int i
= 0; i
< num_fields
; i
++)
2738 oberon_initialize_object(ctx
, field
);
2739 field
= field
-> next
;
2742 oberon_generator_init_type(ctx
, type
);
2746 oberon_generator_init_type(ctx
, type
);
2751 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2753 if(x
-> initialized
)
2758 x
-> initialized
= 1;
2762 case OBERON_CLASS_TYPE
:
2763 oberon_initialize_type(ctx
, x
-> type
);
2765 case OBERON_CLASS_VAR
:
2766 case OBERON_CLASS_FIELD
:
2767 if(x
-> type
-> class == OBERON_TYPE_ARRAY
)
2769 if(x
-> type
-> size
== 0)
2771 oberon_error(ctx
, "open array not allowed as variable or field");
2774 oberon_initialize_type(ctx
, x
-> type
);
2775 oberon_generator_init_var(ctx
, x
);
2777 case OBERON_CLASS_PARAM
:
2778 case OBERON_CLASS_VAR_PARAM
:
2779 oberon_initialize_type(ctx
, x
-> type
);
2780 oberon_generator_init_var(ctx
, x
);
2782 case OBERON_CLASS_CONST
:
2783 case OBERON_CLASS_PROC
:
2784 case OBERON_CLASS_MODULE
:
2787 oberon_error(ctx
, "oberon_initialize_object: wat");
2793 oberon_initialize_decl(oberon_context_t
* ctx
)
2795 oberon_object_t
* x
= ctx
-> decl
-> list
;
2799 oberon_initialize_object(ctx
, x
-> next
);
2805 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2807 oberon_object_t
* x
= ctx
-> decl
-> list
;
2811 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2813 if(x
-> next
-> linked
== 0)
2815 oberon_error(ctx
, "unresolved forward declaration");
2823 oberon_decl_seq(oberon_context_t
* ctx
)
2825 if(ctx
-> token
== CONST
)
2827 oberon_assert_token(ctx
, CONST
);
2828 while(ctx
-> token
== IDENT
)
2830 oberon_const_decl(ctx
);
2831 oberon_assert_token(ctx
, SEMICOLON
);
2835 if(ctx
-> token
== TYPE
)
2837 oberon_assert_token(ctx
, TYPE
);
2838 while(ctx
-> token
== IDENT
)
2840 oberon_type_decl(ctx
);
2841 oberon_assert_token(ctx
, SEMICOLON
);
2845 if(ctx
-> token
== VAR
)
2847 oberon_assert_token(ctx
, VAR
);
2848 while(ctx
-> token
== IDENT
)
2850 oberon_var_decl(ctx
);
2851 oberon_assert_token(ctx
, SEMICOLON
);
2855 oberon_prevent_recursive_decl(ctx
);
2856 oberon_initialize_decl(ctx
);
2858 while(ctx
-> token
== PROCEDURE
)
2860 oberon_proc_decl(ctx
);
2861 oberon_assert_token(ctx
, SEMICOLON
);
2864 oberon_prevent_undeclarated_procedures(ctx
);
2868 oberon_statement_seq(oberon_context_t
* ctx
);
2871 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2873 if(dst
-> read_only
)
2875 oberon_error(ctx
, "read-only destination");
2878 src
= oberon_autocast_to(ctx
, src
, dst
-> result
);
2879 oberon_generate_assign(ctx
, src
, dst
);
2883 oberon_statement(oberon_context_t
* ctx
)
2885 oberon_expr_t
* item1
;
2886 oberon_expr_t
* item2
;
2888 if(ctx
-> token
== IDENT
)
2890 item1
= oberon_designator(ctx
);
2891 if(ctx
-> token
== ASSIGN
)
2893 oberon_assert_token(ctx
, ASSIGN
);
2894 item2
= oberon_expr(ctx
);
2895 oberon_assign(ctx
, item2
, item1
);
2899 oberon_opt_proc_parens(ctx
, item1
);
2902 else if(ctx
-> token
== IF
)
2906 oberon_expr_t
* cond
;
2908 els
= oberon_generator_reserve_label(ctx
);
2909 end
= oberon_generator_reserve_label(ctx
);
2911 oberon_assert_token(ctx
, IF
);
2912 cond
= oberon_expr(ctx
);
2913 if(cond
-> result
-> class != OBERON_TYPE_BOOLEAN
)
2915 oberon_error(ctx
, "condition must be boolean");
2917 oberon_assert_token(ctx
, THEN
);
2918 oberon_generate_branch(ctx
, cond
, false, els
);
2919 oberon_statement_seq(ctx
);
2920 oberon_generate_goto(ctx
, end
);
2922 oberon_generate_label(ctx
, els
);
2923 if(ctx
-> token
== ELSE
)
2925 oberon_assert_token(ctx
, ELSE
);
2926 oberon_statement_seq(ctx
);
2929 oberon_generate_label(ctx
, end
);
2930 oberon_assert_token(ctx
, END
);
2932 else if(ctx
-> token
== RETURN
)
2934 oberon_assert_token(ctx
, RETURN
);
2935 if(ISEXPR(ctx
-> token
))
2937 oberon_expr_t
* expr
;
2938 expr
= oberon_expr(ctx
);
2939 oberon_make_return(ctx
, expr
);
2943 oberon_make_return(ctx
, NULL
);
2949 oberon_statement_seq(oberon_context_t
* ctx
)
2951 oberon_statement(ctx
);
2952 while(ctx
-> token
== SEMICOLON
)
2954 oberon_assert_token(ctx
, SEMICOLON
);
2955 oberon_statement(ctx
);
2960 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2962 oberon_module_t
* m
= ctx
-> module_list
;
2963 while(m
&& strcmp(m
-> name
, name
) != 0)
2971 code
= ctx
-> import_module(name
);
2974 oberon_error(ctx
, "no such module");
2977 m
= oberon_compile_module(ctx
, code
);
2983 oberon_error(ctx
, "cyclic module import");
2986 oberon_object_t
* ident
;
2987 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, false, false, false);
2988 ident
-> module
= m
;
2992 oberon_import_decl(oberon_context_t
* ctx
)
2997 alias
= name
= oberon_assert_ident(ctx
);
2998 if(ctx
-> token
== ASSIGN
)
3000 oberon_assert_token(ctx
, ASSIGN
);
3001 name
= oberon_assert_ident(ctx
);
3004 oberon_import_module(ctx
, alias
, name
);
3008 oberon_import_list(oberon_context_t
* ctx
)
3010 oberon_assert_token(ctx
, IMPORT
);
3012 oberon_import_decl(ctx
);
3013 while(ctx
-> token
== COMMA
)
3015 oberon_assert_token(ctx
, COMMA
);
3016 oberon_import_decl(ctx
);
3019 oberon_assert_token(ctx
, SEMICOLON
);
3023 oberon_parse_module(oberon_context_t
* ctx
)
3027 oberon_read_token(ctx
);
3029 oberon_assert_token(ctx
, MODULE
);
3030 name1
= oberon_assert_ident(ctx
);
3031 oberon_assert_token(ctx
, SEMICOLON
);
3032 ctx
-> mod
-> name
= name1
;
3034 oberon_generator_init_module(ctx
, ctx
-> mod
);
3036 if(ctx
-> token
== IMPORT
)
3038 oberon_import_list(ctx
);
3041 oberon_decl_seq(ctx
);
3043 oberon_generate_begin_module(ctx
);
3044 if(ctx
-> token
== BEGIN
)
3046 oberon_assert_token(ctx
, BEGIN
);
3047 oberon_statement_seq(ctx
);
3049 oberon_generate_end_module(ctx
);
3051 oberon_assert_token(ctx
, END
);
3052 name2
= oberon_assert_ident(ctx
);
3053 oberon_assert_token(ctx
, DOT
);
3055 if(strcmp(name1
, name2
) != 0)
3057 oberon_error(ctx
, "module name not matched");
3060 oberon_generator_fini_module(ctx
-> mod
);
3063 // =======================================================================
3065 // =======================================================================
3068 register_default_types(oberon_context_t
* ctx
)
3070 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
3071 oberon_generator_init_type(ctx
, ctx
-> void_type
);
3073 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
3074 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
3075 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
3077 ctx
-> string_type
= oberon_new_type_string(1);
3078 oberon_generator_init_type(ctx
, ctx
-> string_type
);
3080 ctx
-> bool_type
= oberon_new_type_boolean();
3081 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1);
3083 ctx
-> byte_type
= oberon_new_type_integer(1);
3084 oberon_define_type(ctx
-> world_scope
, "BYTE", ctx
-> byte_type
, 1);
3086 ctx
-> shortint_type
= oberon_new_type_integer(2);
3087 oberon_define_type(ctx
-> world_scope
, "SHORTINT", ctx
-> shortint_type
, 1);
3089 ctx
-> int_type
= oberon_new_type_integer(4);
3090 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1);
3092 ctx
-> longint_type
= oberon_new_type_integer(8);
3093 oberon_define_type(ctx
-> world_scope
, "LONGINT", ctx
-> longint_type
, 1);
3095 ctx
-> real_type
= oberon_new_type_real(4);
3096 oberon_define_type(ctx
-> world_scope
, "REAL", ctx
-> real_type
, 1);
3098 ctx
-> longreal_type
= oberon_new_type_real(8);
3099 oberon_define_type(ctx
-> world_scope
, "LONGREAL", ctx
-> longreal_type
, 1);
3101 ctx
-> char_type
= oberon_new_type_char(1);
3102 oberon_define_type(ctx
-> world_scope
, "CHAR", ctx
-> char_type
, 1);
3106 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
3108 oberon_object_t
* proc
;
3109 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, true, false, false);
3110 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
3111 proc
-> type
-> sysproc
= true;
3112 proc
-> type
-> genfunc
= f
;
3113 proc
-> type
-> genproc
= p
;
3116 static oberon_expr_t
*
3117 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3121 oberon_error(ctx
, "too few arguments");
3126 oberon_error(ctx
, "too mach arguments");
3129 oberon_expr_t
* arg
;
3132 oberon_type_t
* result_type
;
3133 result_type
= arg
-> result
;
3135 if(result_type
-> class != OBERON_TYPE_INTEGER
)
3137 oberon_error(ctx
, "ABS accepts only integers");
3141 oberon_expr_t
* expr
;
3142 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
3147 oberon_make_new_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3151 oberon_error(ctx
, "too few arguments");
3154 oberon_expr_t
* dst
;
3157 oberon_type_t
* type
;
3158 type
= dst
-> result
;
3160 if(type
-> class != OBERON_TYPE_POINTER
)
3162 oberon_error(ctx
, "not a pointer");
3165 type
= type
-> base
;
3167 oberon_expr_t
* src
;
3168 src
= oberon_new_item(MODE_NEW
, dst
-> result
, 0);
3169 src
-> item
.num_args
= 0;
3170 src
-> item
.args
= NULL
;
3173 if(type
-> class == OBERON_TYPE_ARRAY
)
3175 if(type
-> size
== 0)
3177 oberon_type_t
* x
= type
;
3178 while(x
-> class == OBERON_TYPE_ARRAY
)
3188 if(num_args
< max_args
)
3190 oberon_error(ctx
, "too few arguments");
3193 if(num_args
> max_args
)
3195 oberon_error(ctx
, "too mach arguments");
3198 int num_sizes
= max_args
- 1;
3199 oberon_expr_t
* size_list
= list_args
-> next
;
3201 oberon_expr_t
* arg
= size_list
;
3202 for(int i
= 0; i
< max_args
- 1; i
++)
3204 if(arg
-> result
-> class != OBERON_TYPE_INTEGER
)
3206 oberon_error(ctx
, "size must be integer");
3211 src
-> item
.num_args
= num_sizes
;
3212 src
-> item
.args
= size_list
;
3214 else if(type
-> class != OBERON_TYPE_RECORD
)
3216 oberon_error(ctx
, "oberon_make_new_call: wat");
3219 if(num_args
> max_args
)
3221 oberon_error(ctx
, "too mach arguments");
3224 oberon_assign(ctx
, src
, dst
);
3228 oberon_create_context(ModuleImportCallback import_module
)
3230 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
3232 oberon_scope_t
* world_scope
;
3233 world_scope
= oberon_open_scope(ctx
);
3234 ctx
-> world_scope
= world_scope
;
3236 ctx
-> import_module
= import_module
;
3238 oberon_generator_init_context(ctx
);
3240 register_default_types(ctx
);
3241 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
3242 oberon_new_intrinsic(ctx
, "NEW", NULL
, oberon_make_new_call
);
3248 oberon_destroy_context(oberon_context_t
* ctx
)
3250 oberon_generator_destroy_context(ctx
);
3255 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
3257 const char * code
= ctx
-> code
;
3258 int code_index
= ctx
-> code_index
;
3260 int token
= ctx
-> token
;
3261 char * string
= ctx
-> string
;
3262 int integer
= ctx
-> integer
;
3263 int real
= ctx
-> real
;
3264 bool longmode
= ctx
-> longmode
;
3265 oberon_scope_t
* decl
= ctx
-> decl
;
3266 oberon_module_t
* mod
= ctx
-> mod
;
3268 oberon_scope_t
* module_scope
;
3269 module_scope
= oberon_open_scope(ctx
);
3271 oberon_module_t
* module
;
3272 module
= calloc(1, sizeof *module
);
3273 module
-> decl
= module_scope
;
3274 module
-> next
= ctx
-> module_list
;
3276 ctx
-> mod
= module
;
3277 ctx
-> module_list
= module
;
3279 oberon_init_scaner(ctx
, newcode
);
3280 oberon_parse_module(ctx
);
3282 module
-> ready
= 1;
3285 ctx
-> code_index
= code_index
;
3287 ctx
-> token
= token
;
3288 ctx
-> string
= string
;
3289 ctx
-> integer
= integer
;
3291 ctx
-> longmode
= longmode
;