59 // =======================================================================
61 // =======================================================================
64 oberon_error(oberon_context_t
* ctx
, const char * fmt
, ...)
68 fprintf(stderr
, "error: ");
69 vfprintf(stderr
, fmt
, ptr
);
70 fprintf(stderr
, "\n");
71 fprintf(stderr
, " code_index = %i\n", ctx
-> code_index
);
72 fprintf(stderr
, " c = %c\n", ctx
-> c
);
73 fprintf(stderr
, " token = %i\n", ctx
-> token
);
78 static oberon_type_t
*
79 oberon_new_type_ptr(int class)
81 oberon_type_t
* x
= malloc(sizeof *x
);
82 memset(x
, 0, sizeof *x
);
87 static oberon_type_t
*
88 oberon_new_type_integer(int size
)
91 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
96 static oberon_type_t
*
97 oberon_new_type_boolean(int size
)
100 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
105 // =======================================================================
107 // =======================================================================
109 static oberon_scope_t
*
110 oberon_open_scope(oberon_context_t
* ctx
)
112 oberon_scope_t
* scope
= calloc(1, sizeof *scope
);
113 oberon_object_t
* list
= calloc(1, sizeof *list
);
116 scope
-> list
= list
;
117 scope
-> up
= ctx
-> decl
;
121 scope
-> parent
= scope
-> up
-> parent
;
122 scope
-> local
= scope
-> up
-> local
;
130 oberon_close_scope(oberon_scope_t
* scope
)
132 oberon_context_t
* ctx
= scope
-> ctx
;
133 ctx
-> decl
= scope
-> up
;
136 static oberon_object_t
*
137 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class, int export
, int read_only
)
139 oberon_object_t
* x
= scope
-> list
;
140 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
147 oberon_error(scope
-> ctx
, "already defined");
150 oberon_object_t
* newvar
= malloc(sizeof *newvar
);
151 memset(newvar
, 0, sizeof *newvar
);
152 newvar
-> name
= name
;
153 newvar
-> class = class;
154 newvar
-> export
= export
;
155 newvar
-> read_only
= read_only
;
156 newvar
-> local
= scope
-> local
;
157 newvar
-> parent
= scope
-> parent
;
158 newvar
-> module
= scope
-> ctx
-> mod
;
165 static oberon_object_t
*
166 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
168 oberon_object_t
* x
= list
;
169 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
176 static oberon_object_t
*
177 oberon_find_object(oberon_scope_t
* scope
, char * name
, int check_it
)
179 oberon_object_t
* result
= NULL
;
181 oberon_scope_t
* s
= scope
;
182 while(result
== NULL
&& s
!= NULL
)
184 result
= oberon_find_object_in_list(s
-> list
, name
);
188 if(check_it
&& result
== NULL
)
190 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
196 static oberon_object_t
*
197 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
199 oberon_object_t
* x
= rec
-> decl
;
200 for(int i
= 0; i
< rec
-> num_decl
; i
++)
202 if(strcmp(x
-> name
, name
) == 0)
209 oberon_error(ctx
, "field not defined");
214 static oberon_object_t
*
215 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
, int export
)
217 oberon_object_t
* id
;
218 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
, export
, 0);
220 oberon_generator_init_type(scope
-> ctx
, type
);
224 // =======================================================================
226 // =======================================================================
229 oberon_get_char(oberon_context_t
* ctx
)
231 if(ctx
-> code
[ctx
-> code_index
])
233 ctx
-> code_index
+= 1;
234 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
239 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
242 ctx
-> code_index
= 0;
243 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
247 oberon_read_ident(oberon_context_t
* ctx
)
250 int i
= ctx
-> code_index
;
252 int c
= ctx
-> code
[i
];
260 char * ident
= malloc(len
+ 1);
261 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
264 ctx
-> code_index
= i
;
265 ctx
-> c
= ctx
-> code
[i
];
266 ctx
-> string
= ident
;
267 ctx
-> token
= IDENT
;
269 if(strcmp(ident
, "MODULE") == 0)
271 ctx
-> token
= MODULE
;
273 else if(strcmp(ident
, "END") == 0)
277 else if(strcmp(ident
, "VAR") == 0)
281 else if(strcmp(ident
, "BEGIN") == 0)
283 ctx
-> token
= BEGIN
;
285 else if(strcmp(ident
, "TRUE") == 0)
289 else if(strcmp(ident
, "FALSE") == 0)
291 ctx
-> token
= FALSE
;
293 else if(strcmp(ident
, "OR") == 0)
297 else if(strcmp(ident
, "DIV") == 0)
301 else if(strcmp(ident
, "MOD") == 0)
305 else if(strcmp(ident
, "PROCEDURE") == 0)
307 ctx
-> token
= PROCEDURE
;
309 else if(strcmp(ident
, "RETURN") == 0)
311 ctx
-> token
= RETURN
;
313 else if(strcmp(ident
, "CONST") == 0)
315 ctx
-> token
= CONST
;
317 else if(strcmp(ident
, "TYPE") == 0)
321 else if(strcmp(ident
, "ARRAY") == 0)
323 ctx
-> token
= ARRAY
;
325 else if(strcmp(ident
, "OF") == 0)
329 else if(strcmp(ident
, "RECORD") == 0)
331 ctx
-> token
= RECORD
;
333 else if(strcmp(ident
, "POINTER") == 0)
335 ctx
-> token
= POINTER
;
337 else if(strcmp(ident
, "TO") == 0)
341 else if(strcmp(ident
, "NIL") == 0)
345 else if(strcmp(ident
, "IMPORT") == 0)
347 ctx
-> token
= IMPORT
;
352 oberon_read_integer(oberon_context_t
* ctx
)
355 int i
= ctx
-> code_index
;
357 int c
= ctx
-> code
[i
];
365 char * ident
= malloc(len
+ 2);
366 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
369 ctx
-> code_index
= i
;
370 ctx
-> c
= ctx
-> code
[i
];
371 ctx
-> string
= ident
;
372 ctx
-> integer
= atoi(ident
);
373 ctx
-> token
= INTEGER
;
377 oberon_skip_space(oberon_context_t
* ctx
)
379 while(isspace(ctx
-> c
))
381 oberon_get_char(ctx
);
386 oberon_read_comment(oberon_context_t
* ctx
)
393 oberon_get_char(ctx
);
396 oberon_get_char(ctx
);
400 else if(ctx
-> c
== '*')
402 oberon_get_char(ctx
);
405 oberon_get_char(ctx
);
409 else if(ctx
-> c
== 0)
411 oberon_error(ctx
, "unterminated comment");
415 oberon_get_char(ctx
);
420 static void oberon_read_token(oberon_context_t
* ctx
);
423 oberon_read_symbol(oberon_context_t
* ctx
)
432 ctx
-> token
= SEMICOLON
;
433 oberon_get_char(ctx
);
436 ctx
-> token
= COLON
;
437 oberon_get_char(ctx
);
440 ctx
-> token
= ASSIGN
;
441 oberon_get_char(ctx
);
446 oberon_get_char(ctx
);
449 ctx
-> token
= LPAREN
;
450 oberon_get_char(ctx
);
453 oberon_get_char(ctx
);
454 oberon_read_comment(ctx
);
455 oberon_read_token(ctx
);
459 ctx
-> token
= RPAREN
;
460 oberon_get_char(ctx
);
463 ctx
-> token
= EQUAL
;
464 oberon_get_char(ctx
);
468 oberon_get_char(ctx
);
472 oberon_get_char(ctx
);
476 oberon_get_char(ctx
);
480 ctx
-> token
= GREAT
;
481 oberon_get_char(ctx
);
485 oberon_get_char(ctx
);
490 oberon_get_char(ctx
);
493 ctx
-> token
= MINUS
;
494 oberon_get_char(ctx
);
498 oberon_get_char(ctx
);
501 oberon_get_char(ctx
);
502 oberon_error(ctx
, "unstarted comment");
506 ctx
-> token
= SLASH
;
507 oberon_get_char(ctx
);
511 oberon_get_char(ctx
);
515 oberon_get_char(ctx
);
518 ctx
-> token
= COMMA
;
519 oberon_get_char(ctx
);
522 ctx
-> token
= LBRACE
;
523 oberon_get_char(ctx
);
526 ctx
-> token
= RBRACE
;
527 oberon_get_char(ctx
);
530 ctx
-> token
= UPARROW
;
531 oberon_get_char(ctx
);
534 oberon_error(ctx
, "invalid char %c", ctx
-> c
);
540 oberon_read_token(oberon_context_t
* ctx
)
542 oberon_skip_space(ctx
);
547 oberon_read_ident(ctx
);
551 oberon_read_integer(ctx
);
555 oberon_read_symbol(ctx
);
559 // =======================================================================
561 // =======================================================================
563 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
564 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
565 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
566 static char * oberon_assert_ident(oberon_context_t
* ctx
);
567 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
568 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
570 static oberon_expr_t
*
571 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
573 oberon_oper_t
* operator;
574 operator = malloc(sizeof *operator);
575 memset(operator, 0, sizeof *operator);
577 operator -> is_item
= 0;
578 operator -> result
= result
;
579 operator -> read_only
= 1;
581 operator -> left
= left
;
582 operator -> right
= right
;
584 return (oberon_expr_t
*) operator;
587 static oberon_expr_t
*
588 oberon_new_item(int mode
, oberon_type_t
* result
, int read_only
)
590 oberon_item_t
* item
;
591 item
= malloc(sizeof *item
);
592 memset(item
, 0, sizeof *item
);
595 item
-> result
= result
;
596 item
-> read_only
= read_only
;
599 return (oberon_expr_t
*)item
;
602 static oberon_expr_t
*
603 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
605 oberon_expr_t
* expr
;
606 oberon_type_t
* result
;
608 result
= a
-> result
;
612 if(result
-> class != OBERON_TYPE_INTEGER
)
614 oberon_error(ctx
, "incompatible operator type");
617 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
619 else if(token
== NOT
)
621 if(result
-> class != OBERON_TYPE_BOOLEAN
)
623 oberon_error(ctx
, "incompatible operator type");
626 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
630 oberon_error(ctx
, "oberon_make_unary_op: wat");
637 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
639 oberon_expr_t
* last
;
642 *first
= last
= oberon_expr(ctx
);
643 while(ctx
-> token
== COMMA
)
645 oberon_assert_token(ctx
, COMMA
);
646 oberon_expr_t
* current
;
650 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
654 current
= oberon_expr(ctx
);
657 last
-> next
= current
;
663 static oberon_expr_t
*
664 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
666 if(pref
-> class != expr
-> result
-> class)
668 oberon_error(ctx
, "incompatible types");
671 if(pref
-> class == OBERON_TYPE_INTEGER
)
673 if(expr
-> result
-> class > pref
-> class)
675 oberon_error(ctx
, "incompatible size");
678 else if(pref
-> class == OBERON_TYPE_RECORD
)
680 if(expr
-> result
!= pref
)
682 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
683 oberon_error(ctx
, "incompatible record types");
686 else if(pref
-> class == OBERON_TYPE_POINTER
)
688 if(expr
-> result
-> base
!= pref
-> base
)
690 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
692 oberon_error(ctx
, "incompatible pointer types");
703 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
705 if(desig
-> is_item
== 0)
707 oberon_error(ctx
, "expected item");
710 if(desig
-> item
.mode
!= MODE_CALL
)
712 oberon_error(ctx
, "expected mode CALL");
715 if(desig
-> item
.var
-> type
-> class != OBERON_TYPE_PROCEDURE
)
717 oberon_error(ctx
, "only procedures can be called");
720 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
721 int num_args
= desig
-> item
.num_args
;
722 int num_decl
= fn
-> num_decl
;
724 if(num_args
< num_decl
)
726 oberon_error(ctx
, "too few arguments");
728 else if(num_args
> num_decl
)
730 oberon_error(ctx
, "too many arguments");
733 oberon_expr_t
* arg
= desig
-> item
.args
;
734 oberon_object_t
* param
= fn
-> decl
;
735 for(int i
= 0; i
< num_args
; i
++)
737 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
741 switch(arg
-> item
.mode
)
746 // Допустимо разыменование?
750 oberon_error(ctx
, "var-parameter accept only variables");
755 oberon_autocast_to(ctx
, arg
, param
-> type
);
757 param
= param
-> next
;
761 static oberon_expr_t
*
762 oberon_make_call_func(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
764 switch(proc
-> class)
766 case OBERON_CLASS_PROC
:
767 if(proc
-> class != OBERON_CLASS_PROC
)
769 oberon_error(ctx
, "not a procedure");
772 case OBERON_CLASS_VAR
:
773 case OBERON_CLASS_VAR_PARAM
:
774 case OBERON_CLASS_PARAM
:
775 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
777 oberon_error(ctx
, "not a procedure");
781 oberon_error(ctx
, "not a procedure");
785 oberon_expr_t
* call
;
789 if(proc
-> genfunc
== NULL
)
791 oberon_error(ctx
, "not a function-procedure");
794 call
= proc
-> genfunc(ctx
, num_args
, list_args
);
798 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
)
800 oberon_error(ctx
, "attempt to call procedure in expression");
803 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
804 call
-> item
.var
= proc
;
805 call
-> item
.num_args
= num_args
;
806 call
-> item
.args
= list_args
;
807 oberon_autocast_call(ctx
, call
);
814 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
816 switch(proc
-> class)
818 case OBERON_CLASS_PROC
:
819 if(proc
-> class != OBERON_CLASS_PROC
)
821 oberon_error(ctx
, "not a procedure");
824 case OBERON_CLASS_VAR
:
825 case OBERON_CLASS_VAR_PARAM
:
826 case OBERON_CLASS_PARAM
:
827 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
829 oberon_error(ctx
, "not a procedure");
833 oberon_error(ctx
, "not a procedure");
839 if(proc
-> genproc
== NULL
)
841 oberon_error(ctx
, "requres non-typed procedure");
844 proc
-> genproc(ctx
, num_args
, list_args
);
848 if(proc
-> type
-> base
-> class != OBERON_TYPE_VOID
)
850 oberon_error(ctx
, "attempt to call function as non-typed procedure");
853 oberon_expr_t
* call
;
854 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
855 call
-> item
.var
= proc
;
856 call
-> item
.num_args
= num_args
;
857 call
-> item
.args
= list_args
;
858 oberon_autocast_call(ctx
, call
);
859 oberon_generate_call_proc(ctx
, call
);
867 || ((x) == INTEGER) \
873 static oberon_expr_t
*
874 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
876 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
878 oberon_error(ctx
, "not a pointer");
881 assert(expr
-> is_item
);
883 oberon_expr_t
* selector
;
884 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
, expr
-> read_only
);
885 selector
-> item
.parent
= (oberon_item_t
*) expr
;
890 static oberon_expr_t
*
891 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
893 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
895 desig
= oberno_make_dereferencing(ctx
, desig
);
898 assert(desig
-> is_item
);
900 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
902 oberon_error(ctx
, "not array");
905 oberon_type_t
* base
;
906 base
= desig
-> result
-> base
;
908 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
910 oberon_error(ctx
, "index must be integer");
913 // Статическая проверка границ массива
916 if(index
-> item
.mode
== MODE_INTEGER
)
918 int arr_size
= desig
-> result
-> size
;
919 int index_int
= index
-> item
.integer
;
920 if(index_int
< 0 || index_int
> arr_size
- 1)
922 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
927 oberon_expr_t
* selector
;
928 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
929 selector
-> item
.parent
= (oberon_item_t
*) desig
;
930 selector
-> item
.num_args
= 1;
931 selector
-> item
.args
= index
;
936 static oberon_expr_t
*
937 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
939 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
941 expr
= oberno_make_dereferencing(ctx
, expr
);
944 assert(expr
-> is_item
== 1);
946 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
948 oberon_error(ctx
, "not record");
951 oberon_type_t
* rec
= expr
-> result
;
953 oberon_object_t
* field
;
954 field
= oberon_find_field(ctx
, rec
, name
);
956 if(field
-> export
== 0)
958 if(field
-> module
!= ctx
-> mod
)
960 oberon_error(ctx
, "field not exported");
965 if(field
-> read_only
)
967 if(field
-> module
!= ctx
-> mod
)
973 oberon_expr_t
* selector
;
974 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
975 selector
-> item
.var
= field
;
976 selector
-> item
.parent
= (oberon_item_t
*) expr
;
981 #define ISSELECTOR(x) \
986 static oberon_object_t
*
987 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
992 name
= oberon_assert_ident(ctx
);
993 x
= oberon_find_object(ctx
-> decl
, name
, check
);
997 if(x
-> class == OBERON_CLASS_MODULE
)
999 oberon_assert_token(ctx
, DOT
);
1000 name
= oberon_assert_ident(ctx
);
1001 /* Наличие объектов в левых модулях всегда проверяется */
1002 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1004 if(x
-> export
== 0)
1006 oberon_error(ctx
, "not exported");
1019 static oberon_expr_t
*
1020 oberon_designator(oberon_context_t
* ctx
)
1023 oberon_object_t
* var
;
1024 oberon_expr_t
* expr
;
1026 var
= oberon_qualident(ctx
, NULL
, 1);
1029 if(var
-> read_only
)
1031 if(var
-> module
!= ctx
-> mod
)
1037 switch(var
-> class)
1039 case OBERON_CLASS_CONST
:
1041 expr
= (oberon_expr_t
*) var
-> value
;
1043 case OBERON_CLASS_VAR
:
1044 case OBERON_CLASS_VAR_PARAM
:
1045 case OBERON_CLASS_PARAM
:
1046 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
1048 case OBERON_CLASS_PROC
:
1049 expr
= oberon_new_item(MODE_VAR
, var
-> type
, 1);
1052 oberon_error(ctx
, "invalid designator");
1055 expr
-> item
.var
= var
;
1057 while(ISSELECTOR(ctx
-> token
))
1059 switch(ctx
-> token
)
1062 oberon_assert_token(ctx
, DOT
);
1063 name
= oberon_assert_ident(ctx
);
1064 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1067 oberon_assert_token(ctx
, LBRACE
);
1068 int num_indexes
= 0;
1069 oberon_expr_t
* indexes
= NULL
;
1070 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1071 oberon_assert_token(ctx
, RBRACE
);
1073 for(int i
= 0; i
< num_indexes
; i
++)
1075 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1076 indexes
= indexes
-> next
;
1080 oberon_assert_token(ctx
, UPARROW
);
1081 expr
= oberno_make_dereferencing(ctx
, expr
);
1084 oberon_error(ctx
, "oberon_designator: wat");
1091 static oberon_expr_t
*
1092 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1094 assert(expr
-> is_item
== 1);
1096 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1097 if(ctx
-> token
== LPAREN
)
1099 oberon_assert_token(ctx
, LPAREN
);
1102 oberon_expr_t
* arguments
= NULL
;
1104 if(ISEXPR(ctx
-> token
))
1106 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1109 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1111 oberon_assert_token(ctx
, RPAREN
);
1118 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1120 assert(expr
-> is_item
== 1);
1123 oberon_expr_t
* arguments
= NULL
;
1125 if(ctx
-> token
== LPAREN
)
1127 oberon_assert_token(ctx
, LPAREN
);
1129 if(ISEXPR(ctx
-> token
))
1131 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1134 oberon_assert_token(ctx
, RPAREN
);
1137 /* Вызов происходит даже без скобок */
1138 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1141 static oberon_expr_t
*
1142 oberon_factor(oberon_context_t
* ctx
)
1144 oberon_expr_t
* expr
;
1146 switch(ctx
-> token
)
1149 expr
= oberon_designator(ctx
);
1150 expr
= oberon_opt_func_parens(ctx
, expr
);
1153 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
, 1);
1154 expr
-> item
.integer
= ctx
-> integer
;
1155 oberon_assert_token(ctx
, INTEGER
);
1158 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1159 expr
-> item
.boolean
= 1;
1160 oberon_assert_token(ctx
, TRUE
);
1163 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1164 expr
-> item
.boolean
= 0;
1165 oberon_assert_token(ctx
, FALSE
);
1168 oberon_assert_token(ctx
, LPAREN
);
1169 expr
= oberon_expr(ctx
);
1170 oberon_assert_token(ctx
, RPAREN
);
1173 oberon_assert_token(ctx
, NOT
);
1174 expr
= oberon_factor(ctx
);
1175 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1178 oberon_assert_token(ctx
, NIL
);
1179 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
, 1);
1182 oberon_error(ctx
, "invalid expression");
1189 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1190 * 1. Классы обоих типов должны быть одинаковы
1191 * 2. В качестве результата должен быть выбран больший тип.
1192 * 3. Если размер результат не должен быть меньше чем базовый int
1196 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
1198 if((a
-> class) != (b
-> class))
1200 oberon_error(ctx
, "incompatible types");
1203 if((a
-> size
) > (b
-> size
))
1212 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
1214 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
1216 *result
= ctx
-> int_type
;
1220 /* TODO: cast types */
1223 #define ITMAKESBOOLEAN(x) \
1224 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1226 #define ITUSEONLYINTEGER(x) \
1227 ((x) >= LESS && (x) <= GEQ)
1229 #define ITUSEONLYBOOLEAN(x) \
1230 (((x) == OR) || ((x) == AND))
1232 static oberon_expr_t
*
1233 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1235 oberon_expr_t
* expr
;
1236 oberon_type_t
* result
;
1238 if(ITMAKESBOOLEAN(token
))
1240 if(ITUSEONLYINTEGER(token
))
1242 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1243 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1245 oberon_error(ctx
, "used only with integer types");
1248 else if(ITUSEONLYBOOLEAN(token
))
1250 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1251 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1253 oberon_error(ctx
, "used only with boolean type");
1257 result
= ctx
-> bool_type
;
1261 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1263 else if(token
== NEQ
)
1265 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1267 else if(token
== LESS
)
1269 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1271 else if(token
== LEQ
)
1273 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1275 else if(token
== GREAT
)
1277 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1279 else if(token
== GEQ
)
1281 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1283 else if(token
== OR
)
1285 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1287 else if(token
== AND
)
1289 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1293 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1298 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1302 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1304 else if(token
== MINUS
)
1306 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1308 else if(token
== STAR
)
1310 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1312 else if(token
== SLASH
)
1314 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1316 else if(token
== DIV
)
1318 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1320 else if(token
== MOD
)
1322 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1326 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1333 #define ISMULOP(x) \
1334 ((x) >= STAR && (x) <= AND)
1336 static oberon_expr_t
*
1337 oberon_term_expr(oberon_context_t
* ctx
)
1339 oberon_expr_t
* expr
;
1341 expr
= oberon_factor(ctx
);
1342 while(ISMULOP(ctx
-> token
))
1344 int token
= ctx
-> token
;
1345 oberon_read_token(ctx
);
1347 oberon_expr_t
* inter
= oberon_factor(ctx
);
1348 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1354 #define ISADDOP(x) \
1355 ((x) >= PLUS && (x) <= OR)
1357 static oberon_expr_t
*
1358 oberon_simple_expr(oberon_context_t
* ctx
)
1360 oberon_expr_t
* expr
;
1363 if(ctx
-> token
== PLUS
)
1366 oberon_assert_token(ctx
, PLUS
);
1368 else if(ctx
-> token
== MINUS
)
1371 oberon_assert_token(ctx
, MINUS
);
1374 expr
= oberon_term_expr(ctx
);
1375 while(ISADDOP(ctx
-> token
))
1377 int token
= ctx
-> token
;
1378 oberon_read_token(ctx
);
1380 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1381 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1386 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1392 #define ISRELATION(x) \
1393 ((x) >= EQUAL && (x) <= GEQ)
1395 static oberon_expr_t
*
1396 oberon_expr(oberon_context_t
* ctx
)
1398 oberon_expr_t
* expr
;
1400 expr
= oberon_simple_expr(ctx
);
1401 while(ISRELATION(ctx
-> token
))
1403 int token
= ctx
-> token
;
1404 oberon_read_token(ctx
);
1406 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1407 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1413 static oberon_item_t
*
1414 oberon_const_expr(oberon_context_t
* ctx
)
1416 oberon_expr_t
* expr
;
1417 expr
= oberon_expr(ctx
);
1419 if(expr
-> is_item
== 0)
1421 oberon_error(ctx
, "const expression are required");
1424 return (oberon_item_t
*) expr
;
1427 // =======================================================================
1429 // =======================================================================
1431 static void oberon_decl_seq(oberon_context_t
* ctx
);
1432 static void oberon_statement_seq(oberon_context_t
* ctx
);
1433 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1436 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1438 if(ctx
-> token
!= token
)
1440 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1445 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1447 oberon_expect_token(ctx
, token
);
1448 oberon_read_token(ctx
);
1452 oberon_assert_ident(oberon_context_t
* ctx
)
1454 oberon_expect_token(ctx
, IDENT
);
1455 char * ident
= ctx
-> string
;
1456 oberon_read_token(ctx
);
1461 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1463 switch(ctx
-> token
)
1466 oberon_assert_token(ctx
, STAR
);
1471 oberon_assert_token(ctx
, MINUS
);
1482 static oberon_object_t
*
1483 oberon_ident_def(oberon_context_t
* ctx
, int class)
1488 oberon_object_t
* x
;
1490 name
= oberon_assert_ident(ctx
);
1491 oberon_def(ctx
, &export
, &read_only
);
1493 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
);
1498 oberon_ident_list(oberon_context_t
* ctx
, int class, int * num
, oberon_object_t
** list
)
1501 *list
= oberon_ident_def(ctx
, class);
1502 while(ctx
-> token
== COMMA
)
1504 oberon_assert_token(ctx
, COMMA
);
1505 oberon_ident_def(ctx
, class);
1511 oberon_var_decl(oberon_context_t
* ctx
)
1514 oberon_object_t
* list
;
1515 oberon_type_t
* type
;
1516 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1518 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, &num
, &list
);
1519 oberon_assert_token(ctx
, COLON
);
1520 oberon_type(ctx
, &type
);
1522 oberon_object_t
* var
= list
;
1523 for(int i
= 0; i
< num
; i
++)
1530 static oberon_object_t
*
1531 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1533 int class = OBERON_CLASS_PARAM
;
1534 if(ctx
-> token
== VAR
)
1536 oberon_read_token(ctx
);
1537 class = OBERON_CLASS_VAR_PARAM
;
1541 oberon_object_t
* list
;
1542 oberon_ident_list(ctx
, class, &num
, &list
);
1544 oberon_assert_token(ctx
, COLON
);
1546 oberon_type_t
* type
;
1547 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1548 oberon_type(ctx
, &type
);
1550 oberon_object_t
* param
= list
;
1551 for(int i
= 0; i
< num
; i
++)
1553 param
-> type
= type
;
1554 param
= param
-> next
;
1561 #define ISFPSECTION \
1562 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1565 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1567 oberon_assert_token(ctx
, LPAREN
);
1571 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1572 while(ctx
-> token
== SEMICOLON
)
1574 oberon_assert_token(ctx
, SEMICOLON
);
1575 oberon_fp_section(ctx
, &signature
-> num_decl
);
1579 oberon_assert_token(ctx
, RPAREN
);
1581 if(ctx
-> token
== COLON
)
1583 oberon_assert_token(ctx
, COLON
);
1585 oberon_object_t
* typeobj
;
1586 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1587 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1589 oberon_error(ctx
, "function result is not type");
1591 signature
-> base
= typeobj
-> type
;
1596 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1598 oberon_type_t
* signature
;
1600 signature
-> class = OBERON_TYPE_PROCEDURE
;
1601 signature
-> num_decl
= 0;
1602 signature
-> base
= ctx
-> void_type
;
1603 signature
-> decl
= NULL
;
1605 if(ctx
-> token
== LPAREN
)
1607 oberon_formal_pars(ctx
, signature
);
1612 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1614 if(a
-> num_decl
!= b
-> num_decl
)
1616 oberon_error(ctx
, "number parameters not matched");
1619 int num_param
= a
-> num_decl
;
1620 oberon_object_t
* param_a
= a
-> decl
;
1621 oberon_object_t
* param_b
= b
-> decl
;
1622 for(int i
= 0; i
< num_param
; i
++)
1624 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1626 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1629 if(param_a
-> type
!= param_b
-> type
)
1631 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1634 param_a
= param_a
-> next
;
1635 param_b
= param_b
-> next
;
1640 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1642 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1643 oberon_type_t
* result_type
= proc
-> type
-> base
;
1645 if(result_type
-> class == OBERON_TYPE_VOID
)
1649 oberon_error(ctx
, "procedure has no result type");
1656 oberon_error(ctx
, "procedure requires expression on result");
1659 oberon_autocast_to(ctx
, expr
, result_type
);
1662 proc
-> has_return
= 1;
1664 oberon_generate_return(ctx
, expr
);
1668 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1670 oberon_assert_token(ctx
, SEMICOLON
);
1672 ctx
-> decl
= proc
-> scope
;
1674 oberon_decl_seq(ctx
);
1676 oberon_generate_begin_proc(ctx
, proc
);
1678 if(ctx
-> token
== BEGIN
)
1680 oberon_assert_token(ctx
, BEGIN
);
1681 oberon_statement_seq(ctx
);
1684 oberon_assert_token(ctx
, END
);
1685 char * name
= oberon_assert_ident(ctx
);
1686 if(strcmp(name
, proc
-> name
) != 0)
1688 oberon_error(ctx
, "procedure name not matched");
1691 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1692 && proc
-> has_return
== 0)
1694 oberon_make_return(ctx
, NULL
);
1697 if(proc
-> has_return
== 0)
1699 oberon_error(ctx
, "procedure requires return");
1702 oberon_generate_end_proc(ctx
);
1703 oberon_close_scope(ctx
-> decl
);
1707 oberon_proc_decl(oberon_context_t
* ctx
)
1709 oberon_assert_token(ctx
, PROCEDURE
);
1712 if(ctx
-> token
== UPARROW
)
1714 oberon_assert_token(ctx
, UPARROW
);
1721 name
= oberon_assert_ident(ctx
);
1722 oberon_def(ctx
, &export
, &read_only
);
1724 oberon_scope_t
* proc_scope
;
1725 proc_scope
= oberon_open_scope(ctx
);
1726 ctx
-> decl
-> local
= 1;
1728 oberon_type_t
* signature
;
1729 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1730 oberon_opt_formal_pars(ctx
, &signature
);
1732 oberon_initialize_decl(ctx
);
1733 oberon_generator_init_type(ctx
, signature
);
1734 oberon_close_scope(ctx
-> decl
);
1736 oberon_object_t
* proc
;
1737 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1740 if(proc
-> class != OBERON_CLASS_PROC
)
1742 oberon_error(ctx
, "mult definition");
1749 oberon_error(ctx
, "mult procedure definition");
1753 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
1755 oberon_error(ctx
, "export type not matched");
1758 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1762 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
);
1763 proc
-> type
= signature
;
1764 proc
-> scope
= proc_scope
;
1765 oberon_generator_init_proc(ctx
, proc
);
1768 proc
-> scope
-> parent
= proc
;
1773 oberon_proc_decl_body(ctx
, proc
);
1778 oberon_const_decl(oberon_context_t
* ctx
)
1780 oberon_item_t
* value
;
1781 oberon_object_t
* constant
;
1783 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
);
1784 oberon_assert_token(ctx
, EQUAL
);
1785 value
= oberon_const_expr(ctx
);
1786 constant
-> value
= value
;
1790 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
1792 if(size
-> is_item
== 0)
1794 oberon_error(ctx
, "requires constant");
1797 if(size
-> item
.mode
!= MODE_INTEGER
)
1799 oberon_error(ctx
, "requires integer constant");
1802 oberon_type_t
* arr
;
1804 arr
-> class = OBERON_TYPE_ARRAY
;
1805 arr
-> size
= size
-> item
.integer
;
1810 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1812 if(ctx
-> token
== IDENT
)
1815 oberon_object_t
* list
;
1816 oberon_type_t
* type
;
1817 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1819 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, &num
, &list
);
1820 oberon_assert_token(ctx
, COLON
);
1821 oberon_type(ctx
, &type
);
1823 oberon_object_t
* field
= list
;
1824 for(int i
= 0; i
< num
; i
++)
1826 field
-> type
= type
;
1827 field
= field
-> next
;
1830 rec
-> num_decl
+= num
;
1835 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1838 oberon_object_t
* to
;
1840 to
= oberon_qualident(ctx
, &name
, 0);
1842 //name = oberon_assert_ident(ctx);
1843 //to = oberon_find_object(ctx -> decl, name, 0);
1847 if(to
-> class != OBERON_CLASS_TYPE
)
1849 oberon_error(ctx
, "not a type");
1854 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, 0, 0);
1855 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1861 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
1864 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1868 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
1876 oberon_type_t
* dim
;
1877 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1879 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
1881 oberon_make_array_type(ctx
, sizes
, dim
, type
);
1885 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1887 if(ctx
-> token
== IDENT
)
1889 oberon_qualident_type(ctx
, type
);
1891 else if(ctx
-> token
== ARRAY
)
1893 oberon_assert_token(ctx
, ARRAY
);
1896 oberon_expr_t
* sizes
;
1897 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
1899 oberon_assert_token(ctx
, OF
);
1901 oberon_type_t
* base
;
1902 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1903 oberon_type(ctx
, &base
);
1905 oberon_make_multiarray(ctx
, sizes
, base
, type
);
1907 else if(ctx
-> token
== RECORD
)
1909 oberon_type_t
* rec
;
1911 rec
-> class = OBERON_TYPE_RECORD
;
1913 oberon_scope_t
* record_scope
;
1914 record_scope
= oberon_open_scope(ctx
);
1915 // TODO parent object
1916 //record_scope -> parent = NULL;
1917 record_scope
-> local
= 1;
1919 oberon_assert_token(ctx
, RECORD
);
1920 oberon_field_list(ctx
, rec
);
1921 while(ctx
-> token
== SEMICOLON
)
1923 oberon_assert_token(ctx
, SEMICOLON
);
1924 oberon_field_list(ctx
, rec
);
1926 oberon_assert_token(ctx
, END
);
1928 rec
-> decl
= record_scope
-> list
-> next
;
1929 oberon_close_scope(record_scope
);
1933 else if(ctx
-> token
== POINTER
)
1935 oberon_assert_token(ctx
, POINTER
);
1936 oberon_assert_token(ctx
, TO
);
1938 oberon_type_t
* base
;
1939 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1940 oberon_type(ctx
, &base
);
1942 oberon_type_t
* ptr
;
1944 ptr
-> class = OBERON_TYPE_POINTER
;
1947 else if(ctx
-> token
== PROCEDURE
)
1949 oberon_open_scope(ctx
);
1950 oberon_assert_token(ctx
, PROCEDURE
);
1951 oberon_opt_formal_pars(ctx
, type
);
1952 oberon_close_scope(ctx
-> decl
);
1956 oberon_error(ctx
, "invalid type declaration");
1961 oberon_type_decl(oberon_context_t
* ctx
)
1964 oberon_object_t
* newtype
;
1965 oberon_type_t
* type
;
1969 name
= oberon_assert_ident(ctx
);
1970 oberon_def(ctx
, &export
, &read_only
);
1972 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
1975 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
1976 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1977 assert(newtype
-> type
);
1981 if(newtype
-> class != OBERON_CLASS_TYPE
)
1983 oberon_error(ctx
, "mult definition");
1986 if(newtype
-> linked
)
1988 oberon_error(ctx
, "mult definition - already linked");
1991 newtype
-> export
= export
;
1992 newtype
-> read_only
= read_only
;
1995 oberon_assert_token(ctx
, EQUAL
);
1997 type
= newtype
-> type
;
1998 oberon_type(ctx
, &type
);
2000 if(type
-> class == OBERON_TYPE_VOID
)
2002 oberon_error(ctx
, "recursive alias declaration");
2005 newtype
-> type
= type
;
2006 newtype
-> linked
= 1;
2009 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2010 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2013 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
2015 if(type
-> class != OBERON_TYPE_POINTER
2016 && type
-> class != OBERON_TYPE_ARRAY
)
2021 if(type
-> recursive
)
2023 oberon_error(ctx
, "recursive pointer declaration");
2026 if(type
-> base
-> class == OBERON_TYPE_POINTER
)
2028 oberon_error(ctx
, "attempt to make pointer to pointer");
2031 type
-> recursive
= 1;
2033 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
2035 type
-> recursive
= 0;
2039 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
2041 if(type
-> class != OBERON_TYPE_RECORD
)
2046 if(type
-> recursive
)
2048 oberon_error(ctx
, "recursive record declaration");
2051 type
-> recursive
= 1;
2053 int num_fields
= type
-> num_decl
;
2054 oberon_object_t
* field
= type
-> decl
;
2055 for(int i
= 0; i
< num_fields
; i
++)
2057 oberon_prevent_recursive_object(ctx
, field
);
2058 field
= field
-> next
;
2061 type
-> recursive
= 0;
2064 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2066 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2071 if(type
-> recursive
)
2073 oberon_error(ctx
, "recursive procedure declaration");
2076 type
-> recursive
= 1;
2078 int num_fields
= type
-> num_decl
;
2079 oberon_object_t
* field
= type
-> decl
;
2080 for(int i
= 0; i
< num_fields
; i
++)
2082 oberon_prevent_recursive_object(ctx
, field
);
2083 field
= field
-> next
;
2086 type
-> recursive
= 0;
2090 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2092 if(type
-> class != OBERON_TYPE_ARRAY
)
2097 if(type
-> recursive
)
2099 oberon_error(ctx
, "recursive array declaration");
2102 type
-> recursive
= 1;
2104 oberon_prevent_recursive_type(ctx
, type
-> base
);
2106 type
-> recursive
= 0;
2110 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2112 if(type
-> class == OBERON_TYPE_POINTER
)
2114 oberon_prevent_recursive_pointer(ctx
, type
);
2116 else if(type
-> class == OBERON_TYPE_RECORD
)
2118 oberon_prevent_recursive_record(ctx
, type
);
2120 else if(type
-> class == OBERON_TYPE_ARRAY
)
2122 oberon_prevent_recursive_array(ctx
, type
);
2124 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2126 oberon_prevent_recursive_procedure(ctx
, type
);
2131 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2135 case OBERON_CLASS_VAR
:
2136 case OBERON_CLASS_TYPE
:
2137 case OBERON_CLASS_PARAM
:
2138 case OBERON_CLASS_VAR_PARAM
:
2139 case OBERON_CLASS_FIELD
:
2140 oberon_prevent_recursive_type(ctx
, x
-> type
);
2142 case OBERON_CLASS_CONST
:
2143 case OBERON_CLASS_PROC
:
2144 case OBERON_CLASS_MODULE
:
2147 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2153 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2155 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2159 oberon_prevent_recursive_object(ctx
, x
);
2164 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2165 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2168 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2170 if(type
-> class != OBERON_TYPE_RECORD
)
2175 int num_fields
= type
-> num_decl
;
2176 oberon_object_t
* field
= type
-> decl
;
2177 for(int i
= 0; i
< num_fields
; i
++)
2179 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2181 oberon_initialize_type(ctx
, field
-> type
);
2184 oberon_initialize_object(ctx
, field
);
2185 field
= field
-> next
;
2188 oberon_generator_init_record(ctx
, type
);
2192 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2194 if(type
-> class == OBERON_TYPE_VOID
)
2196 oberon_error(ctx
, "undeclarated type");
2199 if(type
-> initialized
)
2204 type
-> initialized
= 1;
2206 if(type
-> class == OBERON_TYPE_POINTER
)
2208 oberon_initialize_type(ctx
, type
-> base
);
2209 oberon_generator_init_type(ctx
, type
);
2211 else if(type
-> class == OBERON_TYPE_ARRAY
)
2213 oberon_initialize_type(ctx
, type
-> base
);
2214 oberon_generator_init_type(ctx
, type
);
2216 else if(type
-> class == OBERON_TYPE_RECORD
)
2218 oberon_generator_init_type(ctx
, type
);
2219 oberon_initialize_record_fields(ctx
, type
);
2221 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2223 int num_fields
= type
-> num_decl
;
2224 oberon_object_t
* field
= type
-> decl
;
2225 for(int i
= 0; i
< num_fields
; i
++)
2227 oberon_initialize_object(ctx
, field
);
2228 field
= field
-> next
;
2231 oberon_generator_init_type(ctx
, type
);
2235 oberon_generator_init_type(ctx
, type
);
2240 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2242 if(x
-> initialized
)
2247 x
-> initialized
= 1;
2251 case OBERON_CLASS_TYPE
:
2252 oberon_initialize_type(ctx
, x
-> type
);
2254 case OBERON_CLASS_VAR
:
2255 case OBERON_CLASS_PARAM
:
2256 case OBERON_CLASS_VAR_PARAM
:
2257 case OBERON_CLASS_FIELD
:
2258 oberon_initialize_type(ctx
, x
-> type
);
2259 oberon_generator_init_var(ctx
, x
);
2261 case OBERON_CLASS_CONST
:
2262 case OBERON_CLASS_PROC
:
2263 case OBERON_CLASS_MODULE
:
2266 oberon_error(ctx
, "oberon_initialize_object: wat");
2272 oberon_initialize_decl(oberon_context_t
* ctx
)
2274 oberon_object_t
* x
= ctx
-> decl
-> list
;
2278 oberon_initialize_object(ctx
, x
-> next
);
2284 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2286 oberon_object_t
* x
= ctx
-> decl
-> list
;
2290 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2292 if(x
-> next
-> linked
== 0)
2294 oberon_error(ctx
, "unresolved forward declaration");
2302 oberon_decl_seq(oberon_context_t
* ctx
)
2304 if(ctx
-> token
== CONST
)
2306 oberon_assert_token(ctx
, CONST
);
2307 while(ctx
-> token
== IDENT
)
2309 oberon_const_decl(ctx
);
2310 oberon_assert_token(ctx
, SEMICOLON
);
2314 if(ctx
-> token
== TYPE
)
2316 oberon_assert_token(ctx
, TYPE
);
2317 while(ctx
-> token
== IDENT
)
2319 oberon_type_decl(ctx
);
2320 oberon_assert_token(ctx
, SEMICOLON
);
2324 if(ctx
-> token
== VAR
)
2326 oberon_assert_token(ctx
, VAR
);
2327 while(ctx
-> token
== IDENT
)
2329 oberon_var_decl(ctx
);
2330 oberon_assert_token(ctx
, SEMICOLON
);
2334 oberon_prevent_recursive_decl(ctx
);
2335 oberon_initialize_decl(ctx
);
2337 while(ctx
-> token
== PROCEDURE
)
2339 oberon_proc_decl(ctx
);
2340 oberon_assert_token(ctx
, SEMICOLON
);
2343 oberon_prevent_undeclarated_procedures(ctx
);
2347 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2349 if(dst
-> read_only
)
2351 oberon_error(ctx
, "read-only destination");
2354 oberon_autocast_to(ctx
, src
, dst
-> result
);
2355 oberon_generate_assign(ctx
, src
, dst
);
2359 oberon_statement(oberon_context_t
* ctx
)
2361 oberon_expr_t
* item1
;
2362 oberon_expr_t
* item2
;
2364 if(ctx
-> token
== IDENT
)
2366 item1
= oberon_designator(ctx
);
2367 if(ctx
-> token
== ASSIGN
)
2369 oberon_assert_token(ctx
, ASSIGN
);
2370 item2
= oberon_expr(ctx
);
2371 oberon_assign(ctx
, item2
, item1
);
2375 oberon_opt_proc_parens(ctx
, item1
);
2378 else if(ctx
-> token
== RETURN
)
2380 oberon_assert_token(ctx
, RETURN
);
2381 if(ISEXPR(ctx
-> token
))
2383 oberon_expr_t
* expr
;
2384 expr
= oberon_expr(ctx
);
2385 oberon_make_return(ctx
, expr
);
2389 oberon_make_return(ctx
, NULL
);
2395 oberon_statement_seq(oberon_context_t
* ctx
)
2397 oberon_statement(ctx
);
2398 while(ctx
-> token
== SEMICOLON
)
2400 oberon_assert_token(ctx
, SEMICOLON
);
2401 oberon_statement(ctx
);
2406 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2408 oberon_module_t
* m
= ctx
-> module_list
;
2409 while(m
&& strcmp(m
-> name
, name
) != 0)
2417 code
= ctx
-> import_module(name
);
2420 oberon_error(ctx
, "no such module");
2423 m
= oberon_compile_module(ctx
, code
);
2429 oberon_error(ctx
, "cyclic module import");
2432 oberon_object_t
* ident
;
2433 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, 0, 0);
2434 ident
-> module
= m
;
2438 oberon_import_decl(oberon_context_t
* ctx
)
2443 alias
= name
= oberon_assert_ident(ctx
);
2444 if(ctx
-> token
== ASSIGN
)
2446 oberon_assert_token(ctx
, ASSIGN
);
2447 name
= oberon_assert_ident(ctx
);
2450 oberon_import_module(ctx
, alias
, name
);
2454 oberon_import_list(oberon_context_t
* ctx
)
2456 oberon_assert_token(ctx
, IMPORT
);
2458 oberon_import_decl(ctx
);
2459 while(ctx
-> token
== COMMA
)
2461 oberon_assert_token(ctx
, COMMA
);
2462 oberon_import_decl(ctx
);
2465 oberon_assert_token(ctx
, SEMICOLON
);
2469 oberon_parse_module(oberon_context_t
* ctx
)
2473 oberon_read_token(ctx
);
2475 oberon_assert_token(ctx
, MODULE
);
2476 name1
= oberon_assert_ident(ctx
);
2477 oberon_assert_token(ctx
, SEMICOLON
);
2478 ctx
-> mod
-> name
= name1
;
2480 if(ctx
-> token
== IMPORT
)
2482 oberon_import_list(ctx
);
2485 oberon_decl_seq(ctx
);
2487 oberon_generate_begin_module(ctx
);
2488 if(ctx
-> token
== BEGIN
)
2490 oberon_assert_token(ctx
, BEGIN
);
2491 oberon_statement_seq(ctx
);
2493 oberon_generate_end_module(ctx
);
2495 oberon_assert_token(ctx
, END
);
2496 name2
= oberon_assert_ident(ctx
);
2497 oberon_assert_token(ctx
, DOT
);
2499 if(strcmp(name1
, name2
) != 0)
2501 oberon_error(ctx
, "module name not matched");
2505 // =======================================================================
2507 // =======================================================================
2510 register_default_types(oberon_context_t
* ctx
)
2512 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2513 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2515 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2516 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2517 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2519 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
2520 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1);
2522 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
2523 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1);
2527 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2529 oberon_object_t
* proc
;
2530 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, 1, 0);
2531 proc
-> sysproc
= 1;
2532 proc
-> genfunc
= f
;
2533 proc
-> genproc
= p
;
2534 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2537 static oberon_expr_t
*
2538 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2542 oberon_error(ctx
, "too few arguments");
2547 oberon_error(ctx
, "too mach arguments");
2550 oberon_expr_t
* arg
;
2553 oberon_type_t
* result_type
;
2554 result_type
= arg
-> result
;
2556 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2558 oberon_error(ctx
, "ABS accepts only integers");
2562 oberon_expr_t
* expr
;
2563 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2568 oberon_create_context(ModuleImportCallback import_module
)
2570 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2572 oberon_scope_t
* world_scope
;
2573 world_scope
= oberon_open_scope(ctx
);
2574 ctx
-> world_scope
= world_scope
;
2576 ctx
-> import_module
= import_module
;
2578 oberon_generator_init_context(ctx
);
2580 register_default_types(ctx
);
2581 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2587 oberon_destroy_context(oberon_context_t
* ctx
)
2589 oberon_generator_destroy_context(ctx
);
2594 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2596 const char * code
= ctx
-> code
;
2597 int code_index
= ctx
-> code_index
;
2599 int token
= ctx
-> token
;
2600 char * string
= ctx
-> string
;
2601 int integer
= ctx
-> integer
;
2602 oberon_scope_t
* decl
= ctx
-> decl
;
2603 oberon_module_t
* mod
= ctx
-> mod
;
2605 oberon_scope_t
* module_scope
;
2606 module_scope
= oberon_open_scope(ctx
);
2608 oberon_module_t
* module
;
2609 module
= calloc(1, sizeof *module
);
2610 module
-> decl
= module_scope
;
2611 module
-> next
= ctx
-> module_list
;
2613 ctx
-> mod
= module
;
2614 ctx
-> module_list
= module
;
2616 oberon_init_scaner(ctx
, newcode
);
2617 oberon_parse_module(ctx
);
2619 module
-> ready
= 1;
2622 ctx
-> code_index
= code_index
;
2624 ctx
-> token
= token
;
2625 ctx
-> string
= string
;
2626 ctx
-> integer
= integer
;