e12ee36174e9fd9cfd9a870225dea8528d46e8f8
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)
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
-> local
= scope
-> local
;
155 newvar
-> parent
= scope
-> parent
;
163 oberon_define_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
, oberon_type_t
* type
)
165 // TODO check base fields
167 oberon_object_t
* x
= rec
-> decl
;
168 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
175 oberon_error(ctx
, "multiple definition");
178 oberon_object_t
* field
= malloc(sizeof *field
);
179 memset(field
, 0, sizeof *field
);
180 field
-> name
= name
;
181 field
-> class = OBERON_CLASS_FIELD
;
182 field
-> type
= type
;
184 field
-> parent
= NULL
;
186 rec
-> num_decl
+= 1;
190 static oberon_object_t
*
191 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
193 oberon_object_t
* x
= list
;
194 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
201 static oberon_object_t
*
202 oberon_find_object(oberon_scope_t
* scope
, char * name
, int check_it
)
204 oberon_object_t
* result
= NULL
;
206 oberon_scope_t
* s
= scope
;
207 while(result
== NULL
&& s
!= NULL
)
209 result
= oberon_find_object_in_list(s
-> list
, name
);
213 if(check_it
&& result
== NULL
)
215 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
221 static oberon_object_t
*
222 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
224 oberon_object_t
* x
= rec
-> decl
;
225 for(int i
= 0; i
< rec
-> num_decl
; i
++)
227 if(strcmp(x
-> name
, name
) == 0)
234 oberon_error(ctx
, "field not defined");
239 static oberon_object_t
*
240 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
)
242 oberon_object_t
* id
;
243 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
);
245 oberon_generator_init_type(scope
-> ctx
, type
);
250 static oberon_type_t *
251 oberon_find_type(oberon_scope_t * scope, char * name)
253 oberon_object_t * x = oberon_find_object(scope, name);
254 if(x -> class != OBERON_CLASS_TYPE)
256 oberon_error(scope -> ctx, "%s not a type", name);
263 static oberon_object_t
*
264 oberon_define_var(oberon_scope_t
* scope
, int class, char * name
, oberon_type_t
* type
)
266 oberon_object_t
* var
;
267 var
= oberon_define_object(scope
, name
, class);
273 static oberon_object_t *
274 oberon_find_var(oberon_scope_t * scope, char * name)
276 oberon_object_t * x = oberon_find_object(scope, name);
278 if(x -> class != OBERON_CLASS_VAR)
280 oberon_error(scope -> ctx, "%s not a var", name);
288 static oberon_object_t *
289 oberon_define_proc(oberon_scope_t * scope, char * name, oberon_type_t * signature)
291 oberon_object_t * proc;
292 proc = oberon_define_object(scope, name, OBERON_CLASS_PROC);
293 proc -> type = signature;
298 // =======================================================================
300 // =======================================================================
303 oberon_get_char(oberon_context_t
* ctx
)
305 ctx
-> code_index
+= 1;
306 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
310 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
313 ctx
-> code_index
= 0;
314 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
318 oberon_read_ident(oberon_context_t
* ctx
)
321 int i
= ctx
-> code_index
;
323 int c
= ctx
-> code
[i
];
331 char * ident
= malloc(len
+ 1);
332 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
335 ctx
-> code_index
= i
;
336 ctx
-> c
= ctx
-> code
[i
];
337 ctx
-> string
= ident
;
338 ctx
-> token
= IDENT
;
340 if(strcmp(ident
, "MODULE") == 0)
342 ctx
-> token
= MODULE
;
344 else if(strcmp(ident
, "END") == 0)
348 else if(strcmp(ident
, "VAR") == 0)
352 else if(strcmp(ident
, "BEGIN") == 0)
354 ctx
-> token
= BEGIN
;
356 else if(strcmp(ident
, "TRUE") == 0)
360 else if(strcmp(ident
, "FALSE") == 0)
362 ctx
-> token
= FALSE
;
364 else if(strcmp(ident
, "OR") == 0)
368 else if(strcmp(ident
, "DIV") == 0)
372 else if(strcmp(ident
, "MOD") == 0)
376 else if(strcmp(ident
, "PROCEDURE") == 0)
378 ctx
-> token
= PROCEDURE
;
380 else if(strcmp(ident
, "RETURN") == 0)
382 ctx
-> token
= RETURN
;
384 else if(strcmp(ident
, "CONST") == 0)
386 ctx
-> token
= CONST
;
388 else if(strcmp(ident
, "TYPE") == 0)
392 else if(strcmp(ident
, "ARRAY") == 0)
394 ctx
-> token
= ARRAY
;
396 else if(strcmp(ident
, "OF") == 0)
400 else if(strcmp(ident
, "RECORD") == 0)
402 ctx
-> token
= RECORD
;
404 else if(strcmp(ident
, "POINTER") == 0)
406 ctx
-> token
= POINTER
;
408 else if(strcmp(ident
, "TO") == 0)
412 else if(strcmp(ident
, "NIL") == 0)
416 else if(strcmp(ident
, "IMPORT") == 0)
418 ctx
-> token
= IMPORT
;
423 oberon_read_integer(oberon_context_t
* ctx
)
426 int i
= ctx
-> code_index
;
428 int c
= ctx
-> code
[i
];
436 char * ident
= malloc(len
+ 2);
437 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
440 ctx
-> code_index
= i
;
441 ctx
-> c
= ctx
-> code
[i
];
442 ctx
-> string
= ident
;
443 ctx
-> integer
= atoi(ident
);
444 ctx
-> token
= INTEGER
;
448 oberon_skip_space(oberon_context_t
* ctx
)
450 while(isspace(ctx
-> c
))
452 oberon_get_char(ctx
);
457 oberon_read_symbol(oberon_context_t
* ctx
)
466 ctx
-> token
= SEMICOLON
;
467 oberon_get_char(ctx
);
470 ctx
-> token
= COLON
;
471 oberon_get_char(ctx
);
474 ctx
-> token
= ASSIGN
;
475 oberon_get_char(ctx
);
480 oberon_get_char(ctx
);
483 ctx
-> token
= LPAREN
;
484 oberon_get_char(ctx
);
487 ctx
-> token
= RPAREN
;
488 oberon_get_char(ctx
);
491 ctx
-> token
= EQUAL
;
492 oberon_get_char(ctx
);
496 oberon_get_char(ctx
);
500 oberon_get_char(ctx
);
504 oberon_get_char(ctx
);
508 ctx
-> token
= GREAT
;
509 oberon_get_char(ctx
);
513 oberon_get_char(ctx
);
518 oberon_get_char(ctx
);
521 ctx
-> token
= MINUS
;
522 oberon_get_char(ctx
);
526 oberon_get_char(ctx
);
529 ctx
-> token
= SLASH
;
530 oberon_get_char(ctx
);
534 oberon_get_char(ctx
);
538 oberon_get_char(ctx
);
541 ctx
-> token
= COMMA
;
542 oberon_get_char(ctx
);
545 ctx
-> token
= LBRACE
;
546 oberon_get_char(ctx
);
549 ctx
-> token
= RBRACE
;
550 oberon_get_char(ctx
);
553 ctx
-> token
= UPARROW
;
554 oberon_get_char(ctx
);
557 oberon_error(ctx
, "invalid char");
563 oberon_read_token(oberon_context_t
* ctx
)
565 oberon_skip_space(ctx
);
570 oberon_read_ident(ctx
);
574 oberon_read_integer(ctx
);
578 oberon_read_symbol(ctx
);
582 // =======================================================================
584 // =======================================================================
586 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
587 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
588 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
589 static char * oberon_assert_ident(oberon_context_t
* ctx
);
590 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
591 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
593 static oberon_expr_t
*
594 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
596 oberon_oper_t
* operator;
597 operator = malloc(sizeof *operator);
598 memset(operator, 0, sizeof *operator);
600 operator -> is_item
= 0;
601 operator -> result
= result
;
603 operator -> left
= left
;
604 operator -> right
= right
;
606 return (oberon_expr_t
*) operator;
609 static oberon_expr_t
*
610 oberon_new_item(int mode
, oberon_type_t
* result
)
612 oberon_item_t
* item
;
613 item
= malloc(sizeof *item
);
614 memset(item
, 0, sizeof *item
);
617 item
-> result
= result
;
620 return (oberon_expr_t
*)item
;
623 static oberon_expr_t
*
624 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
626 oberon_expr_t
* expr
;
627 oberon_type_t
* result
;
629 result
= a
-> result
;
633 if(result
-> class != OBERON_TYPE_INTEGER
)
635 oberon_error(ctx
, "incompatible operator type");
638 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
640 else if(token
== NOT
)
642 if(result
-> class != OBERON_TYPE_BOOLEAN
)
644 oberon_error(ctx
, "incompatible operator type");
647 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
651 oberon_error(ctx
, "oberon_make_unary_op: wat");
658 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
660 oberon_expr_t
* last
;
663 *first
= last
= oberon_expr(ctx
);
664 while(ctx
-> token
== COMMA
)
666 oberon_assert_token(ctx
, COMMA
);
667 oberon_expr_t
* current
;
671 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
675 current
= oberon_expr(ctx
);
678 last
-> next
= current
;
684 static oberon_expr_t
*
685 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
687 if(pref
-> class != expr
-> result
-> class)
689 oberon_error(ctx
, "incompatible types");
692 if(pref
-> class == OBERON_TYPE_INTEGER
)
694 if(expr
-> result
-> class > pref
-> class)
696 oberon_error(ctx
, "incompatible size");
699 else if(pref
-> class == OBERON_TYPE_RECORD
)
701 if(expr
-> result
!= pref
)
703 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
704 oberon_error(ctx
, "incompatible record types");
707 else if(pref
-> class == OBERON_TYPE_POINTER
)
709 if(expr
-> result
-> base
!= pref
-> base
)
711 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
713 oberon_error(ctx
, "incompatible pointer types");
724 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
726 if(desig
-> is_item
== 0)
728 oberon_error(ctx
, "expected item");
731 if(desig
-> item
.mode
!= MODE_CALL
)
733 oberon_error(ctx
, "expected mode CALL");
736 if(desig
-> item
.var
-> type
-> class != OBERON_TYPE_PROCEDURE
)
738 oberon_error(ctx
, "only procedures can be called");
741 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
742 int num_args
= desig
-> item
.num_args
;
743 int num_decl
= fn
-> num_decl
;
745 if(num_args
< num_decl
)
747 oberon_error(ctx
, "too few arguments");
749 else if(num_args
> num_decl
)
751 oberon_error(ctx
, "too many arguments");
754 oberon_expr_t
* arg
= desig
-> item
.args
;
755 oberon_object_t
* param
= fn
-> decl
;
756 for(int i
= 0; i
< num_args
; i
++)
758 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
762 switch(arg
-> item
.mode
)
767 // Допустимо разыменование?
771 oberon_error(ctx
, "var-parameter accept only variables");
776 oberon_autocast_to(ctx
, arg
, param
-> type
);
778 param
= param
-> next
;
782 static oberon_expr_t
*
783 oberon_make_call_func(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
785 switch(proc
-> class)
787 case OBERON_CLASS_PROC
:
788 if(proc
-> class != OBERON_CLASS_PROC
)
790 oberon_error(ctx
, "not a procedure");
793 case OBERON_CLASS_VAR
:
794 case OBERON_CLASS_VAR_PARAM
:
795 case OBERON_CLASS_PARAM
:
796 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
798 oberon_error(ctx
, "not a procedure");
802 oberon_error(ctx
, "not a procedure");
806 oberon_expr_t
* call
;
810 if(proc
-> genfunc
== NULL
)
812 oberon_error(ctx
, "not a function-procedure");
815 call
= proc
-> genfunc(ctx
, num_args
, list_args
);
819 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
)
821 oberon_error(ctx
, "attempt to call procedure in expression");
824 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
);
825 call
-> item
.var
= proc
;
826 call
-> item
.num_args
= num_args
;
827 call
-> item
.args
= list_args
;
828 oberon_autocast_call(ctx
, call
);
835 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
837 switch(proc
-> class)
839 case OBERON_CLASS_PROC
:
840 if(proc
-> class != OBERON_CLASS_PROC
)
842 oberon_error(ctx
, "not a procedure");
845 case OBERON_CLASS_VAR
:
846 case OBERON_CLASS_VAR_PARAM
:
847 case OBERON_CLASS_PARAM
:
848 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
850 oberon_error(ctx
, "not a procedure");
854 oberon_error(ctx
, "not a procedure");
860 if(proc
-> genproc
== NULL
)
862 oberon_error(ctx
, "requres non-typed procedure");
865 proc
-> genproc(ctx
, num_args
, list_args
);
869 if(proc
-> type
-> base
-> class != OBERON_TYPE_VOID
)
871 oberon_error(ctx
, "attempt to call function as non-typed procedure");
874 oberon_expr_t
* call
;
875 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
);
876 call
-> item
.var
= proc
;
877 call
-> item
.num_args
= num_args
;
878 call
-> item
.args
= list_args
;
879 oberon_autocast_call(ctx
, call
);
880 oberon_generate_call_proc(ctx
, call
);
888 || ((x) == INTEGER) \
894 static oberon_expr_t
*
895 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
897 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
899 oberon_error(ctx
, "not a pointer");
902 assert(expr
-> is_item
);
904 oberon_expr_t
* selector
;
905 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
);
906 selector
-> item
.parent
= (oberon_item_t
*) expr
;
911 static oberon_expr_t
*
912 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
914 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
916 desig
= oberno_make_dereferencing(ctx
, desig
);
919 assert(desig
-> is_item
);
921 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
923 oberon_error(ctx
, "not array");
926 oberon_type_t
* base
;
927 base
= desig
-> result
-> base
;
929 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
931 oberon_error(ctx
, "index must be integer");
934 // Статическая проверка границ массива
937 if(index
-> item
.mode
== MODE_INTEGER
)
939 int arr_size
= desig
-> result
-> size
;
940 int index_int
= index
-> item
.integer
;
941 if(index_int
< 0 || index_int
> arr_size
- 1)
943 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
948 oberon_expr_t
* selector
;
949 selector
= oberon_new_item(MODE_INDEX
, base
);
950 selector
-> item
.parent
= (oberon_item_t
*) desig
;
951 selector
-> item
.num_args
= 1;
952 selector
-> item
.args
= index
;
957 static oberon_expr_t
*
958 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
960 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
962 expr
= oberno_make_dereferencing(ctx
, expr
);
965 assert(expr
-> is_item
== 1);
967 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
969 oberon_error(ctx
, "not record");
972 oberon_type_t
* rec
= expr
-> result
;
974 oberon_object_t
* field
;
975 field
= oberon_find_field(ctx
, rec
, name
);
977 oberon_expr_t
* selector
;
978 selector
= oberon_new_item(MODE_FIELD
, field
-> type
);
979 selector
-> item
.var
= field
;
980 selector
-> item
.parent
= (oberon_item_t
*) expr
;
985 #define ISSELECTOR(x) \
990 static oberon_object_t
*
991 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
996 name
= oberon_assert_ident(ctx
);
997 x
= oberon_find_object(ctx
-> decl
, name
, check
);
1001 if(x
-> class == OBERON_CLASS_MODULE
)
1003 oberon_assert_token(ctx
, DOT
);
1004 name
= oberon_assert_ident(ctx
);
1005 /* Наличие объектов в левых модулях всегда проверяется */
1006 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1018 static oberon_expr_t
*
1019 oberon_designator(oberon_context_t
* ctx
)
1022 oberon_object_t
* var
;
1023 oberon_expr_t
* expr
;
1025 var
= oberon_qualident(ctx
, NULL
, 1);
1027 switch(var
-> class)
1029 case OBERON_CLASS_CONST
:
1031 expr
= (oberon_expr_t
*) var
-> value
;
1033 case OBERON_CLASS_VAR
:
1034 case OBERON_CLASS_VAR_PARAM
:
1035 case OBERON_CLASS_PARAM
:
1036 case OBERON_CLASS_PROC
:
1037 expr
= oberon_new_item(MODE_VAR
, var
-> type
);
1040 oberon_error(ctx
, "invalid designator");
1043 expr
-> item
.var
= var
;
1045 while(ISSELECTOR(ctx
-> token
))
1047 switch(ctx
-> token
)
1050 oberon_assert_token(ctx
, DOT
);
1051 name
= oberon_assert_ident(ctx
);
1052 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1055 oberon_assert_token(ctx
, LBRACE
);
1056 int num_indexes
= 0;
1057 oberon_expr_t
* indexes
= NULL
;
1058 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1059 oberon_assert_token(ctx
, RBRACE
);
1061 for(int i
= 0; i
< num_indexes
; i
++)
1063 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1064 indexes
= indexes
-> next
;
1068 oberon_assert_token(ctx
, UPARROW
);
1069 expr
= oberno_make_dereferencing(ctx
, expr
);
1072 oberon_error(ctx
, "oberon_designator: wat");
1079 static oberon_expr_t
*
1080 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1082 assert(expr
-> is_item
== 1);
1084 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1085 if(ctx
-> token
== LPAREN
)
1087 oberon_assert_token(ctx
, LPAREN
);
1090 oberon_expr_t
* arguments
= NULL
;
1092 if(ISEXPR(ctx
-> token
))
1094 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1097 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1099 oberon_assert_token(ctx
, RPAREN
);
1106 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1108 assert(expr
-> is_item
== 1);
1111 oberon_expr_t
* arguments
= NULL
;
1113 if(ctx
-> token
== LPAREN
)
1115 oberon_assert_token(ctx
, LPAREN
);
1117 if(ISEXPR(ctx
-> token
))
1119 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1122 oberon_assert_token(ctx
, RPAREN
);
1125 /* Вызов происходит даже без скобок */
1126 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1129 static oberon_expr_t
*
1130 oberon_factor(oberon_context_t
* ctx
)
1132 oberon_expr_t
* expr
;
1134 switch(ctx
-> token
)
1137 expr
= oberon_designator(ctx
);
1138 expr
= oberon_opt_func_parens(ctx
, expr
);
1141 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
);
1142 expr
-> item
.integer
= ctx
-> integer
;
1143 oberon_assert_token(ctx
, INTEGER
);
1146 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
1147 expr
-> item
.boolean
= 1;
1148 oberon_assert_token(ctx
, TRUE
);
1151 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
1152 expr
-> item
.boolean
= 0;
1153 oberon_assert_token(ctx
, FALSE
);
1156 oberon_assert_token(ctx
, LPAREN
);
1157 expr
= oberon_expr(ctx
);
1158 oberon_assert_token(ctx
, RPAREN
);
1161 oberon_assert_token(ctx
, NOT
);
1162 expr
= oberon_factor(ctx
);
1163 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1166 oberon_assert_token(ctx
, NIL
);
1167 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
);
1170 oberon_error(ctx
, "invalid expression");
1177 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1178 * 1. Классы обоих типов должны быть одинаковы
1179 * 2. В качестве результата должен быть выбран больший тип.
1180 * 3. Если размер результат не должен быть меньше чем базовый int
1184 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
1186 if((a
-> class) != (b
-> class))
1188 oberon_error(ctx
, "incompatible types");
1191 if((a
-> size
) > (b
-> size
))
1200 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
1202 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
1204 *result
= ctx
-> int_type
;
1208 /* TODO: cast types */
1211 #define ITMAKESBOOLEAN(x) \
1212 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1214 #define ITUSEONLYINTEGER(x) \
1215 ((x) >= LESS && (x) <= GEQ)
1217 #define ITUSEONLYBOOLEAN(x) \
1218 (((x) == OR) || ((x) == AND))
1220 static oberon_expr_t
*
1221 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1223 oberon_expr_t
* expr
;
1224 oberon_type_t
* result
;
1226 if(ITMAKESBOOLEAN(token
))
1228 if(ITUSEONLYINTEGER(token
))
1230 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1231 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1233 oberon_error(ctx
, "used only with integer types");
1236 else if(ITUSEONLYBOOLEAN(token
))
1238 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1239 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1241 oberon_error(ctx
, "used only with boolean type");
1245 result
= ctx
-> bool_type
;
1249 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1251 else if(token
== NEQ
)
1253 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1255 else if(token
== LESS
)
1257 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1259 else if(token
== LEQ
)
1261 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1263 else if(token
== GREAT
)
1265 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1267 else if(token
== GEQ
)
1269 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1271 else if(token
== OR
)
1273 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1275 else if(token
== AND
)
1277 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1281 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1286 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1290 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1292 else if(token
== MINUS
)
1294 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1296 else if(token
== STAR
)
1298 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1300 else if(token
== SLASH
)
1302 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1304 else if(token
== DIV
)
1306 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1308 else if(token
== MOD
)
1310 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1314 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1321 #define ISMULOP(x) \
1322 ((x) >= STAR && (x) <= AND)
1324 static oberon_expr_t
*
1325 oberon_term_expr(oberon_context_t
* ctx
)
1327 oberon_expr_t
* expr
;
1329 expr
= oberon_factor(ctx
);
1330 while(ISMULOP(ctx
-> token
))
1332 int token
= ctx
-> token
;
1333 oberon_read_token(ctx
);
1335 oberon_expr_t
* inter
= oberon_factor(ctx
);
1336 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1342 #define ISADDOP(x) \
1343 ((x) >= PLUS && (x) <= OR)
1345 static oberon_expr_t
*
1346 oberon_simple_expr(oberon_context_t
* ctx
)
1348 oberon_expr_t
* expr
;
1351 if(ctx
-> token
== PLUS
)
1354 oberon_assert_token(ctx
, PLUS
);
1356 else if(ctx
-> token
== MINUS
)
1359 oberon_assert_token(ctx
, MINUS
);
1362 expr
= oberon_term_expr(ctx
);
1363 while(ISADDOP(ctx
-> token
))
1365 int token
= ctx
-> token
;
1366 oberon_read_token(ctx
);
1368 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1369 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1374 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1380 #define ISRELATION(x) \
1381 ((x) >= EQUAL && (x) <= GEQ)
1383 static oberon_expr_t
*
1384 oberon_expr(oberon_context_t
* ctx
)
1386 oberon_expr_t
* expr
;
1388 expr
= oberon_simple_expr(ctx
);
1389 while(ISRELATION(ctx
-> token
))
1391 int token
= ctx
-> token
;
1392 oberon_read_token(ctx
);
1394 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1395 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1401 static oberon_item_t
*
1402 oberon_const_expr(oberon_context_t
* ctx
)
1404 oberon_expr_t
* expr
;
1405 expr
= oberon_expr(ctx
);
1407 if(expr
-> is_item
== 0)
1409 oberon_error(ctx
, "const expression are required");
1412 return (oberon_item_t
*) expr
;
1415 // =======================================================================
1417 // =======================================================================
1419 static void oberon_decl_seq(oberon_context_t
* ctx
);
1420 static void oberon_statement_seq(oberon_context_t
* ctx
);
1421 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1424 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1426 if(ctx
-> token
!= token
)
1428 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1433 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1435 oberon_expect_token(ctx
, token
);
1436 oberon_read_token(ctx
);
1440 oberon_assert_ident(oberon_context_t
* ctx
)
1442 oberon_expect_token(ctx
, IDENT
);
1443 char * ident
= ctx
-> string
;
1444 oberon_read_token(ctx
);
1449 oberon_var_decl(oberon_context_t
* ctx
)
1452 oberon_type_t
* type
;
1453 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1455 name
= oberon_assert_ident(ctx
);
1456 oberon_assert_token(ctx
, COLON
);
1457 oberon_type(ctx
, &type
);
1458 oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR
, name
, type
);
1461 static oberon_object_t
*
1462 oberon_make_param(oberon_context_t
* ctx
, int token
, char * name
, oberon_type_t
* type
)
1464 oberon_object_t
* param
;
1468 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR_PARAM
, name
, type
);
1470 else if(token
== IDENT
)
1472 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_PARAM
, name
, type
);
1476 oberon_error(ctx
, "oberon_make_param: wat");
1482 static oberon_object_t
*
1483 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1485 int modifer_token
= ctx
-> token
;
1486 if(ctx
-> token
== VAR
)
1488 oberon_read_token(ctx
);
1492 name
= oberon_assert_ident(ctx
);
1494 oberon_assert_token(ctx
, COLON
);
1496 oberon_type_t
* type
;
1497 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1498 oberon_type(ctx
, &type
);
1500 oberon_object_t
* first
;
1501 first
= oberon_make_param(ctx
, modifer_token
, name
, type
);
1507 #define ISFPSECTION \
1508 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1511 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1513 oberon_assert_token(ctx
, LPAREN
);
1517 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1518 while(ctx
-> token
== SEMICOLON
)
1520 oberon_assert_token(ctx
, SEMICOLON
);
1521 oberon_fp_section(ctx
, &signature
-> num_decl
);
1525 oberon_assert_token(ctx
, RPAREN
);
1527 if(ctx
-> token
== COLON
)
1529 oberon_assert_token(ctx
, COLON
);
1531 oberon_object_t
* typeobj
;
1532 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1533 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1535 oberon_error(ctx
, "function result is not type");
1537 signature
-> base
= typeobj
-> type
;
1542 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1544 oberon_type_t
* signature
;
1546 signature
-> class = OBERON_TYPE_PROCEDURE
;
1547 signature
-> num_decl
= 0;
1548 signature
-> base
= ctx
-> void_type
;
1549 signature
-> decl
= NULL
;
1551 if(ctx
-> token
== LPAREN
)
1553 oberon_formal_pars(ctx
, signature
);
1558 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1560 if(a
-> num_decl
!= b
-> num_decl
)
1562 oberon_error(ctx
, "number parameters not matched");
1565 int num_param
= a
-> num_decl
;
1566 oberon_object_t
* param_a
= a
-> decl
;
1567 oberon_object_t
* param_b
= b
-> decl
;
1568 for(int i
= 0; i
< num_param
; i
++)
1570 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1572 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1575 if(param_a
-> type
!= param_b
-> type
)
1577 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1580 param_a
= param_a
-> next
;
1581 param_b
= param_b
-> next
;
1586 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1588 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1589 oberon_type_t
* result_type
= proc
-> type
-> base
;
1591 if(result_type
-> class == OBERON_TYPE_VOID
)
1595 oberon_error(ctx
, "procedure has no result type");
1602 oberon_error(ctx
, "procedure requires expression on result");
1605 oberon_autocast_to(ctx
, expr
, result_type
);
1608 proc
-> has_return
= 1;
1610 oberon_generate_return(ctx
, expr
);
1614 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1616 oberon_assert_token(ctx
, SEMICOLON
);
1618 ctx
-> decl
= proc
-> scope
;
1620 oberon_decl_seq(ctx
);
1622 oberon_generate_begin_proc(ctx
, proc
);
1624 if(ctx
-> token
== BEGIN
)
1626 oberon_assert_token(ctx
, BEGIN
);
1627 oberon_statement_seq(ctx
);
1630 oberon_assert_token(ctx
, END
);
1631 char * name
= oberon_assert_ident(ctx
);
1632 if(strcmp(name
, proc
-> name
) != 0)
1634 oberon_error(ctx
, "procedure name not matched");
1637 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1638 && proc
-> has_return
== 0)
1640 oberon_make_return(ctx
, NULL
);
1643 if(proc
-> has_return
== 0)
1645 oberon_error(ctx
, "procedure requires return");
1648 oberon_generate_end_proc(ctx
);
1649 oberon_close_scope(ctx
-> decl
);
1653 oberon_proc_decl(oberon_context_t
* ctx
)
1655 oberon_assert_token(ctx
, PROCEDURE
);
1658 if(ctx
-> token
== UPARROW
)
1660 oberon_assert_token(ctx
, UPARROW
);
1665 name
= oberon_assert_ident(ctx
);
1667 oberon_scope_t
* proc_scope
;
1668 proc_scope
= oberon_open_scope(ctx
);
1669 ctx
-> decl
-> local
= 1;
1671 oberon_type_t
* signature
;
1672 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1673 oberon_opt_formal_pars(ctx
, &signature
);
1675 oberon_initialize_decl(ctx
);
1676 oberon_generator_init_type(ctx
, signature
);
1677 oberon_close_scope(ctx
-> decl
);
1679 oberon_object_t
* proc
;
1680 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1683 if(proc
-> class != OBERON_CLASS_PROC
)
1685 oberon_error(ctx
, "mult definition");
1692 oberon_error(ctx
, "mult procedure definition");
1696 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1700 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
);
1701 proc
-> type
= signature
;
1702 proc
-> scope
= proc_scope
;
1703 oberon_generator_init_proc(ctx
, proc
);
1706 proc
-> scope
-> parent
= proc
;
1711 oberon_proc_decl_body(ctx
, proc
);
1716 oberon_const_decl(oberon_context_t
* ctx
)
1719 oberon_item_t
* value
;
1720 oberon_object_t
* constant
;
1722 name
= oberon_assert_ident(ctx
);
1723 oberon_assert_token(ctx
, EQUAL
);
1724 value
= oberon_const_expr(ctx
);
1726 constant
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_CONST
);
1727 constant
-> value
= value
;
1731 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
1733 if(size
-> is_item
== 0)
1735 oberon_error(ctx
, "requires constant");
1738 if(size
-> item
.mode
!= MODE_INTEGER
)
1740 oberon_error(ctx
, "requires integer constant");
1743 oberon_type_t
* arr
;
1745 arr
-> class = OBERON_TYPE_ARRAY
;
1746 arr
-> size
= size
-> item
.integer
;
1751 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1753 if(ctx
-> token
== IDENT
)
1756 oberon_type_t
* type
;
1757 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1759 name
= oberon_assert_ident(ctx
);
1760 oberon_assert_token(ctx
, COLON
);
1761 oberon_type(ctx
, &type
);
1762 oberon_define_field(ctx
, rec
, name
, type
);
1767 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1770 oberon_object_t
* to
;
1772 to
= oberon_qualident(ctx
, &name
, 0);
1774 //name = oberon_assert_ident(ctx);
1775 //to = oberon_find_object(ctx -> decl, name, 0);
1779 if(to
-> class != OBERON_CLASS_TYPE
)
1781 oberon_error(ctx
, "not a type");
1786 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
);
1787 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1793 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
1796 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1800 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
1808 oberon_type_t
* dim
;
1809 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1811 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
1813 oberon_make_array_type(ctx
, sizes
, dim
, type
);
1817 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1819 if(ctx
-> token
== IDENT
)
1821 oberon_qualident_type(ctx
, type
);
1823 else if(ctx
-> token
== ARRAY
)
1825 oberon_assert_token(ctx
, ARRAY
);
1828 oberon_expr_t
* sizes
;
1829 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
1831 oberon_assert_token(ctx
, OF
);
1833 oberon_type_t
* base
;
1834 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1835 oberon_type(ctx
, &base
);
1837 oberon_make_multiarray(ctx
, sizes
, base
, type
);
1839 else if(ctx
-> token
== RECORD
)
1841 oberon_type_t
* rec
;
1843 rec
-> class = OBERON_TYPE_RECORD
;
1844 oberon_object_t
* list
= malloc(sizeof *list
);
1845 memset(list
, 0, sizeof *list
);
1846 rec
-> num_decl
= 0;
1850 oberon_assert_token(ctx
, RECORD
);
1851 oberon_field_list(ctx
, rec
);
1852 while(ctx
-> token
== SEMICOLON
)
1854 oberon_assert_token(ctx
, SEMICOLON
);
1855 oberon_field_list(ctx
, rec
);
1857 oberon_assert_token(ctx
, END
);
1859 rec
-> decl
= rec
-> decl
-> next
;
1862 else if(ctx
-> token
== POINTER
)
1864 oberon_assert_token(ctx
, POINTER
);
1865 oberon_assert_token(ctx
, TO
);
1867 oberon_type_t
* base
;
1868 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1869 oberon_type(ctx
, &base
);
1871 oberon_type_t
* ptr
;
1873 ptr
-> class = OBERON_TYPE_POINTER
;
1876 else if(ctx
-> token
== PROCEDURE
)
1878 oberon_open_scope(ctx
);
1879 oberon_assert_token(ctx
, PROCEDURE
);
1880 oberon_opt_formal_pars(ctx
, type
);
1881 oberon_close_scope(ctx
-> decl
);
1885 oberon_error(ctx
, "invalid type declaration");
1890 oberon_type_decl(oberon_context_t
* ctx
)
1893 oberon_object_t
* newtype
;
1894 oberon_type_t
* type
;
1896 name
= oberon_assert_ident(ctx
);
1898 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
1901 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
);
1902 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1903 assert(newtype
-> type
);
1907 if(newtype
-> class != OBERON_CLASS_TYPE
)
1909 oberon_error(ctx
, "mult definition");
1912 if(newtype
-> linked
)
1914 oberon_error(ctx
, "mult definition - already linked");
1918 oberon_assert_token(ctx
, EQUAL
);
1920 type
= newtype
-> type
;
1921 oberon_type(ctx
, &type
);
1923 if(type
-> class == OBERON_TYPE_VOID
)
1925 oberon_error(ctx
, "recursive alias declaration");
1928 newtype
-> type
= type
;
1929 newtype
-> linked
= 1;
1932 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
1933 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
1936 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
1938 if(type
-> class != OBERON_TYPE_POINTER
1939 && type
-> class != OBERON_TYPE_ARRAY
)
1944 if(type
-> recursive
)
1946 oberon_error(ctx
, "recursive pointer declaration");
1949 if(type
-> base
-> class == OBERON_TYPE_POINTER
)
1951 oberon_error(ctx
, "attempt to make pointer to pointer");
1954 type
-> recursive
= 1;
1956 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
1958 type
-> recursive
= 0;
1962 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
1964 if(type
-> class != OBERON_TYPE_RECORD
)
1969 if(type
-> recursive
)
1971 oberon_error(ctx
, "recursive record declaration");
1974 type
-> recursive
= 1;
1976 int num_fields
= type
-> num_decl
;
1977 oberon_object_t
* field
= type
-> decl
;
1978 for(int i
= 0; i
< num_fields
; i
++)
1980 oberon_prevent_recursive_object(ctx
, field
);
1981 field
= field
-> next
;
1984 type
-> recursive
= 0;
1987 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
1989 if(type
-> class != OBERON_TYPE_PROCEDURE
)
1994 if(type
-> recursive
)
1996 oberon_error(ctx
, "recursive procedure declaration");
1999 type
-> recursive
= 1;
2001 int num_fields
= type
-> num_decl
;
2002 oberon_object_t
* field
= type
-> decl
;
2003 for(int i
= 0; i
< num_fields
; i
++)
2005 oberon_prevent_recursive_object(ctx
, field
);
2006 field
= field
-> next
;
2009 type
-> recursive
= 0;
2013 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2015 if(type
-> class != OBERON_TYPE_ARRAY
)
2020 if(type
-> recursive
)
2022 oberon_error(ctx
, "recursive array declaration");
2025 type
-> recursive
= 1;
2027 oberon_prevent_recursive_type(ctx
, type
-> base
);
2029 type
-> recursive
= 0;
2033 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2035 if(type
-> class == OBERON_TYPE_POINTER
)
2037 oberon_prevent_recursive_pointer(ctx
, type
);
2039 else if(type
-> class == OBERON_TYPE_RECORD
)
2041 oberon_prevent_recursive_record(ctx
, type
);
2043 else if(type
-> class == OBERON_TYPE_ARRAY
)
2045 oberon_prevent_recursive_array(ctx
, type
);
2047 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2049 oberon_prevent_recursive_procedure(ctx
, type
);
2054 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2058 case OBERON_CLASS_VAR
:
2059 case OBERON_CLASS_TYPE
:
2060 case OBERON_CLASS_PARAM
:
2061 case OBERON_CLASS_VAR_PARAM
:
2062 case OBERON_CLASS_FIELD
:
2063 oberon_prevent_recursive_type(ctx
, x
-> type
);
2065 case OBERON_CLASS_CONST
:
2066 case OBERON_CLASS_PROC
:
2067 case OBERON_CLASS_MODULE
:
2070 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2076 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2078 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2082 oberon_prevent_recursive_object(ctx
, x
);
2087 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2088 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2091 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2093 if(type
-> class != OBERON_TYPE_RECORD
)
2098 int num_fields
= type
-> num_decl
;
2099 oberon_object_t
* field
= type
-> decl
;
2100 for(int i
= 0; i
< num_fields
; i
++)
2102 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2104 oberon_initialize_type(ctx
, field
-> type
);
2107 oberon_initialize_object(ctx
, field
);
2108 field
= field
-> next
;
2111 oberon_generator_init_record(ctx
, type
);
2115 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2117 if(type
-> class == OBERON_TYPE_VOID
)
2119 oberon_error(ctx
, "undeclarated type");
2122 if(type
-> initialized
)
2127 type
-> initialized
= 1;
2129 if(type
-> class == OBERON_TYPE_POINTER
)
2131 oberon_initialize_type(ctx
, type
-> base
);
2132 oberon_generator_init_type(ctx
, type
);
2134 else if(type
-> class == OBERON_TYPE_ARRAY
)
2136 oberon_initialize_type(ctx
, type
-> base
);
2137 oberon_generator_init_type(ctx
, type
);
2139 else if(type
-> class == OBERON_TYPE_RECORD
)
2141 oberon_generator_init_type(ctx
, type
);
2142 oberon_initialize_record_fields(ctx
, type
);
2144 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2146 int num_fields
= type
-> num_decl
;
2147 oberon_object_t
* field
= type
-> decl
;
2148 for(int i
= 0; i
< num_fields
; i
++)
2150 oberon_initialize_object(ctx
, field
);
2151 field
= field
-> next
;
2154 oberon_generator_init_type(ctx
, type
);
2158 oberon_generator_init_type(ctx
, type
);
2163 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2165 if(x
-> initialized
)
2170 x
-> initialized
= 1;
2174 case OBERON_CLASS_TYPE
:
2175 oberon_initialize_type(ctx
, x
-> type
);
2177 case OBERON_CLASS_VAR
:
2178 case OBERON_CLASS_PARAM
:
2179 case OBERON_CLASS_VAR_PARAM
:
2180 case OBERON_CLASS_FIELD
:
2181 oberon_initialize_type(ctx
, x
-> type
);
2182 oberon_generator_init_var(ctx
, x
);
2184 case OBERON_CLASS_CONST
:
2185 case OBERON_CLASS_PROC
:
2186 case OBERON_CLASS_MODULE
:
2189 oberon_error(ctx
, "oberon_initialize_object: wat");
2195 oberon_initialize_decl(oberon_context_t
* ctx
)
2197 oberon_object_t
* x
= ctx
-> decl
-> list
;
2201 oberon_initialize_object(ctx
, x
-> next
);
2207 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2209 oberon_object_t
* x
= ctx
-> decl
-> list
;
2213 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2215 if(x
-> next
-> linked
== 0)
2217 oberon_error(ctx
, "unresolved forward declaration");
2225 oberon_decl_seq(oberon_context_t
* ctx
)
2227 if(ctx
-> token
== CONST
)
2229 oberon_assert_token(ctx
, CONST
);
2230 while(ctx
-> token
== IDENT
)
2232 oberon_const_decl(ctx
);
2233 oberon_assert_token(ctx
, SEMICOLON
);
2237 if(ctx
-> token
== TYPE
)
2239 oberon_assert_token(ctx
, TYPE
);
2240 while(ctx
-> token
== IDENT
)
2242 oberon_type_decl(ctx
);
2243 oberon_assert_token(ctx
, SEMICOLON
);
2247 if(ctx
-> token
== VAR
)
2249 oberon_assert_token(ctx
, VAR
);
2250 while(ctx
-> token
== IDENT
)
2252 oberon_var_decl(ctx
);
2253 oberon_assert_token(ctx
, SEMICOLON
);
2257 oberon_prevent_recursive_decl(ctx
);
2258 oberon_initialize_decl(ctx
);
2260 while(ctx
-> token
== PROCEDURE
)
2262 oberon_proc_decl(ctx
);
2263 oberon_assert_token(ctx
, SEMICOLON
);
2266 oberon_prevent_undeclarated_procedures(ctx
);
2270 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2272 oberon_autocast_to(ctx
, src
, dst
-> result
);
2273 oberon_generate_assign(ctx
, src
, dst
);
2277 oberon_statement(oberon_context_t
* ctx
)
2279 oberon_expr_t
* item1
;
2280 oberon_expr_t
* item2
;
2282 if(ctx
-> token
== IDENT
)
2284 item1
= oberon_designator(ctx
);
2285 if(ctx
-> token
== ASSIGN
)
2287 oberon_assert_token(ctx
, ASSIGN
);
2288 item2
= oberon_expr(ctx
);
2289 oberon_assign(ctx
, item2
, item1
);
2293 oberon_opt_proc_parens(ctx
, item1
);
2296 else if(ctx
-> token
== RETURN
)
2298 oberon_assert_token(ctx
, RETURN
);
2299 if(ISEXPR(ctx
-> token
))
2301 oberon_expr_t
* expr
;
2302 expr
= oberon_expr(ctx
);
2303 oberon_make_return(ctx
, expr
);
2307 oberon_make_return(ctx
, NULL
);
2313 oberon_statement_seq(oberon_context_t
* ctx
)
2315 oberon_statement(ctx
);
2316 while(ctx
-> token
== SEMICOLON
)
2318 oberon_assert_token(ctx
, SEMICOLON
);
2319 oberon_statement(ctx
);
2324 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2326 oberon_module_t
* m
= ctx
-> module_list
;
2327 while(m
&& strcmp(m
-> name
, name
) != 0)
2335 code
= ctx
-> import_module(name
);
2338 oberon_error(ctx
, "no such module");
2341 m
= oberon_compile_module(ctx
, code
);
2347 oberon_error(ctx
, "cyclic module import");
2350 oberon_object_t
* ident
;
2351 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
);
2352 ident
-> module
= m
;
2356 oberon_import_decl(oberon_context_t
* ctx
)
2361 alias
= name
= oberon_assert_ident(ctx
);
2362 if(ctx
-> token
== ASSIGN
)
2364 oberon_assert_token(ctx
, ASSIGN
);
2365 name
= oberon_assert_ident(ctx
);
2368 oberon_import_module(ctx
, alias
, name
);
2372 oberon_import_list(oberon_context_t
* ctx
)
2374 oberon_assert_token(ctx
, IMPORT
);
2376 oberon_import_decl(ctx
);
2377 while(ctx
-> token
== COMMA
)
2379 oberon_assert_token(ctx
, COMMA
);
2380 oberon_import_decl(ctx
);
2383 oberon_assert_token(ctx
, SEMICOLON
);
2387 oberon_parse_module(oberon_context_t
* ctx
)
2391 oberon_read_token(ctx
);
2393 oberon_assert_token(ctx
, MODULE
);
2394 name1
= oberon_assert_ident(ctx
);
2395 oberon_assert_token(ctx
, SEMICOLON
);
2396 ctx
-> mod
-> name
= name1
;
2398 oberon_object_t
* this_module
;
2399 this_module
= oberon_define_object(ctx
-> decl
, name1
, OBERON_CLASS_MODULE
);
2400 this_module
-> module
= ctx
-> mod
;
2402 if(ctx
-> token
== IMPORT
)
2404 oberon_import_list(ctx
);
2407 ctx
-> decl
-> parent
= this_module
;
2409 oberon_decl_seq(ctx
);
2411 oberon_generate_begin_module(ctx
);
2413 if(ctx
-> token
== BEGIN
)
2415 oberon_assert_token(ctx
, BEGIN
);
2416 oberon_statement_seq(ctx
);
2417 oberon_generate_end_module(ctx
);
2420 oberon_assert_token(ctx
, END
);
2421 name2
= oberon_assert_ident(ctx
);
2422 oberon_assert_token(ctx
, DOT
);
2424 if(strcmp(name1
, name2
) != 0)
2426 oberon_error(ctx
, "module name not matched");
2430 // =======================================================================
2432 // =======================================================================
2435 register_default_types(oberon_context_t
* ctx
)
2437 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2438 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2440 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2441 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2442 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2444 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
2445 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
);
2447 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
2448 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
);
2452 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2454 oberon_object_t
* proc
;
2455 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
);
2456 proc
-> sysproc
= 1;
2457 proc
-> genfunc
= f
;
2458 proc
-> genproc
= p
;
2459 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2462 static oberon_expr_t
*
2463 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2467 oberon_error(ctx
, "too few arguments");
2472 oberon_error(ctx
, "too mach arguments");
2475 oberon_expr_t
* arg
;
2478 oberon_type_t
* result_type
;
2479 result_type
= arg
-> result
;
2481 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2483 oberon_error(ctx
, "ABS accepts only integers");
2487 oberon_expr_t
* expr
;
2488 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2493 oberon_create_context(ModuleImportCallback import_module
)
2495 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2497 oberon_scope_t
* world_scope
;
2498 world_scope
= oberon_open_scope(ctx
);
2499 ctx
-> world_scope
= world_scope
;
2501 ctx
-> import_module
= import_module
;
2503 oberon_generator_init_context(ctx
);
2505 register_default_types(ctx
);
2506 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2512 oberon_destroy_context(oberon_context_t
* ctx
)
2514 oberon_generator_destroy_context(ctx
);
2519 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2521 const char * code
= ctx
-> code
;
2522 int code_index
= ctx
-> code_index
;
2524 int token
= ctx
-> token
;
2525 char * string
= ctx
-> string
;
2526 int integer
= ctx
-> integer
;
2527 oberon_scope_t
* decl
= ctx
-> decl
;
2528 oberon_module_t
* mod
= ctx
-> mod
;
2530 oberon_scope_t
* module_scope
;
2531 module_scope
= oberon_open_scope(ctx
);
2533 oberon_module_t
* module
;
2534 module
= calloc(1, sizeof *module
);
2535 module
-> decl
= module_scope
;
2536 module
-> next
= ctx
-> module_list
;
2538 ctx
-> mod
= module
;
2539 ctx
-> module_list
= module
;
2541 oberon_init_scaner(ctx
, newcode
);
2542 oberon_parse_module(ctx
);
2544 module
-> ready
= 1;
2547 ctx
-> code_index
= code_index
;
2549 ctx
-> token
= token
;
2550 ctx
-> string
= string
;
2551 ctx
-> integer
= integer
;