dab60b0bb151dce64579a099f2aa59f5722a2eb6
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 if(pref
-> class != OBERON_TYPE_PROCEDURE
)
670 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
672 oberon_error(ctx
, "incompatible types");
677 if(pref
-> class == OBERON_TYPE_INTEGER
)
679 if(expr
-> result
-> class > pref
-> class)
681 oberon_error(ctx
, "incompatible size");
684 else if(pref
-> class == OBERON_TYPE_RECORD
)
686 if(expr
-> result
!= pref
)
688 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
689 oberon_error(ctx
, "incompatible record types");
692 else if(pref
-> class == OBERON_TYPE_POINTER
)
694 if(expr
-> result
-> base
!= pref
-> base
)
696 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
698 oberon_error(ctx
, "incompatible pointer types");
709 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
711 if(desig
-> is_item
== 0)
713 oberon_error(ctx
, "expected item");
716 if(desig
-> item
.mode
!= MODE_CALL
)
718 oberon_error(ctx
, "expected mode CALL");
721 if(desig
-> item
.var
-> type
-> class != OBERON_TYPE_PROCEDURE
)
723 oberon_error(ctx
, "only procedures can be called");
726 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
727 int num_args
= desig
-> item
.num_args
;
728 int num_decl
= fn
-> num_decl
;
730 if(num_args
< num_decl
)
732 oberon_error(ctx
, "too few arguments");
734 else if(num_args
> num_decl
)
736 oberon_error(ctx
, "too many arguments");
739 oberon_expr_t
* arg
= desig
-> item
.args
;
740 oberon_object_t
* param
= fn
-> decl
;
741 for(int i
= 0; i
< num_args
; i
++)
743 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
747 oberon_error(ctx
, "assign to read-only var");
752 // switch(arg -> item.mode)
757 // // Допустимо разыменование?
758 // //case MODE_DEREF:
761 // oberon_error(ctx, "var-parameter accept only variables");
766 oberon_autocast_to(ctx
, arg
, param
-> type
);
768 param
= param
-> next
;
772 static oberon_expr_t
*
773 oberon_make_call_func(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
775 switch(proc
-> class)
777 case OBERON_CLASS_PROC
:
778 if(proc
-> class != OBERON_CLASS_PROC
)
780 oberon_error(ctx
, "not a procedure");
783 case OBERON_CLASS_VAR
:
784 case OBERON_CLASS_VAR_PARAM
:
785 case OBERON_CLASS_PARAM
:
786 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
788 oberon_error(ctx
, "not a procedure");
792 oberon_error(ctx
, "not a procedure");
796 oberon_expr_t
* call
;
800 if(proc
-> genfunc
== NULL
)
802 oberon_error(ctx
, "not a function-procedure");
805 call
= proc
-> genfunc(ctx
, num_args
, list_args
);
809 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
)
811 oberon_error(ctx
, "attempt to call procedure in expression");
814 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
815 call
-> item
.var
= proc
;
816 call
-> item
.num_args
= num_args
;
817 call
-> item
.args
= list_args
;
818 oberon_autocast_call(ctx
, call
);
825 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
827 switch(proc
-> class)
829 case OBERON_CLASS_PROC
:
830 if(proc
-> class != OBERON_CLASS_PROC
)
832 oberon_error(ctx
, "not a procedure");
835 case OBERON_CLASS_VAR
:
836 case OBERON_CLASS_VAR_PARAM
:
837 case OBERON_CLASS_PARAM
:
838 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
840 oberon_error(ctx
, "not a procedure");
844 oberon_error(ctx
, "not a procedure");
850 if(proc
-> genproc
== NULL
)
852 oberon_error(ctx
, "requres non-typed procedure");
855 proc
-> genproc(ctx
, num_args
, list_args
);
859 if(proc
-> type
-> base
-> class != OBERON_TYPE_VOID
)
861 oberon_error(ctx
, "attempt to call function as non-typed procedure");
864 oberon_expr_t
* call
;
865 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
866 call
-> item
.var
= proc
;
867 call
-> item
.num_args
= num_args
;
868 call
-> item
.args
= list_args
;
869 oberon_autocast_call(ctx
, call
);
870 oberon_generate_call_proc(ctx
, call
);
878 || ((x) == INTEGER) \
884 static oberon_expr_t
*
885 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
887 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
889 oberon_error(ctx
, "not a pointer");
892 assert(expr
-> is_item
);
894 oberon_expr_t
* selector
;
895 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
, expr
-> read_only
);
896 selector
-> item
.parent
= (oberon_item_t
*) expr
;
901 static oberon_expr_t
*
902 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
904 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
906 desig
= oberno_make_dereferencing(ctx
, desig
);
909 assert(desig
-> is_item
);
911 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
913 oberon_error(ctx
, "not array");
916 oberon_type_t
* base
;
917 base
= desig
-> result
-> base
;
919 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
921 oberon_error(ctx
, "index must be integer");
924 // Статическая проверка границ массива
927 if(index
-> item
.mode
== MODE_INTEGER
)
929 int arr_size
= desig
-> result
-> size
;
930 int index_int
= index
-> item
.integer
;
931 if(index_int
< 0 || index_int
> arr_size
- 1)
933 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
938 oberon_expr_t
* selector
;
939 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
940 selector
-> item
.parent
= (oberon_item_t
*) desig
;
941 selector
-> item
.num_args
= 1;
942 selector
-> item
.args
= index
;
947 static oberon_expr_t
*
948 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
950 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
952 expr
= oberno_make_dereferencing(ctx
, expr
);
955 assert(expr
-> is_item
== 1);
957 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
959 oberon_error(ctx
, "not record");
962 oberon_type_t
* rec
= expr
-> result
;
964 oberon_object_t
* field
;
965 field
= oberon_find_field(ctx
, rec
, name
);
967 if(field
-> export
== 0)
969 if(field
-> module
!= ctx
-> mod
)
971 oberon_error(ctx
, "field not exported");
976 if(field
-> read_only
)
978 if(field
-> module
!= ctx
-> mod
)
984 oberon_expr_t
* selector
;
985 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
986 selector
-> item
.var
= field
;
987 selector
-> item
.parent
= (oberon_item_t
*) expr
;
992 #define ISSELECTOR(x) \
997 static oberon_object_t
*
998 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
1001 oberon_object_t
* x
;
1003 name
= oberon_assert_ident(ctx
);
1004 x
= oberon_find_object(ctx
-> decl
, name
, check
);
1008 if(x
-> class == OBERON_CLASS_MODULE
)
1010 oberon_assert_token(ctx
, DOT
);
1011 name
= oberon_assert_ident(ctx
);
1012 /* Наличие объектов в левых модулях всегда проверяется */
1013 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1015 if(x
-> export
== 0)
1017 oberon_error(ctx
, "not exported");
1030 static oberon_expr_t
*
1031 oberon_designator(oberon_context_t
* ctx
)
1034 oberon_object_t
* var
;
1035 oberon_expr_t
* expr
;
1037 var
= oberon_qualident(ctx
, NULL
, 1);
1040 if(var
-> read_only
)
1042 if(var
-> module
!= ctx
-> mod
)
1048 switch(var
-> class)
1050 case OBERON_CLASS_CONST
:
1052 expr
= (oberon_expr_t
*) var
-> value
;
1054 case OBERON_CLASS_VAR
:
1055 case OBERON_CLASS_VAR_PARAM
:
1056 case OBERON_CLASS_PARAM
:
1057 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
1059 case OBERON_CLASS_PROC
:
1060 expr
= oberon_new_item(MODE_VAR
, var
-> type
, 1);
1063 oberon_error(ctx
, "invalid designator");
1066 expr
-> item
.var
= var
;
1068 while(ISSELECTOR(ctx
-> token
))
1070 switch(ctx
-> token
)
1073 oberon_assert_token(ctx
, DOT
);
1074 name
= oberon_assert_ident(ctx
);
1075 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1078 oberon_assert_token(ctx
, LBRACE
);
1079 int num_indexes
= 0;
1080 oberon_expr_t
* indexes
= NULL
;
1081 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1082 oberon_assert_token(ctx
, RBRACE
);
1084 for(int i
= 0; i
< num_indexes
; i
++)
1086 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1087 indexes
= indexes
-> next
;
1091 oberon_assert_token(ctx
, UPARROW
);
1092 expr
= oberno_make_dereferencing(ctx
, expr
);
1095 oberon_error(ctx
, "oberon_designator: wat");
1102 static oberon_expr_t
*
1103 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1105 assert(expr
-> is_item
== 1);
1107 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1108 if(ctx
-> token
== LPAREN
)
1110 oberon_assert_token(ctx
, LPAREN
);
1113 oberon_expr_t
* arguments
= NULL
;
1115 if(ISEXPR(ctx
-> token
))
1117 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1120 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1122 oberon_assert_token(ctx
, RPAREN
);
1129 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1131 assert(expr
-> is_item
== 1);
1134 oberon_expr_t
* arguments
= NULL
;
1136 if(ctx
-> token
== LPAREN
)
1138 oberon_assert_token(ctx
, LPAREN
);
1140 if(ISEXPR(ctx
-> token
))
1142 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1145 oberon_assert_token(ctx
, RPAREN
);
1148 /* Вызов происходит даже без скобок */
1149 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1152 static oberon_expr_t
*
1153 oberon_factor(oberon_context_t
* ctx
)
1155 oberon_expr_t
* expr
;
1157 switch(ctx
-> token
)
1160 expr
= oberon_designator(ctx
);
1161 expr
= oberon_opt_func_parens(ctx
, expr
);
1164 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
, 1);
1165 expr
-> item
.integer
= ctx
-> integer
;
1166 oberon_assert_token(ctx
, INTEGER
);
1169 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1170 expr
-> item
.boolean
= 1;
1171 oberon_assert_token(ctx
, TRUE
);
1174 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1175 expr
-> item
.boolean
= 0;
1176 oberon_assert_token(ctx
, FALSE
);
1179 oberon_assert_token(ctx
, LPAREN
);
1180 expr
= oberon_expr(ctx
);
1181 oberon_assert_token(ctx
, RPAREN
);
1184 oberon_assert_token(ctx
, NOT
);
1185 expr
= oberon_factor(ctx
);
1186 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1189 oberon_assert_token(ctx
, NIL
);
1190 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
, 1);
1193 oberon_error(ctx
, "invalid expression");
1200 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1201 * 1. Классы обоих типов должны быть одинаковы
1202 * 2. В качестве результата должен быть выбран больший тип.
1203 * 3. Если размер результат не должен быть меньше чем базовый int
1207 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
1209 if((a
-> class) != (b
-> class))
1211 oberon_error(ctx
, "incompatible types");
1214 if((a
-> size
) > (b
-> size
))
1223 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
1225 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
1227 *result
= ctx
-> int_type
;
1231 /* TODO: cast types */
1234 #define ITMAKESBOOLEAN(x) \
1235 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1237 #define ITUSEONLYINTEGER(x) \
1238 ((x) >= LESS && (x) <= GEQ)
1240 #define ITUSEONLYBOOLEAN(x) \
1241 (((x) == OR) || ((x) == AND))
1243 static oberon_expr_t
*
1244 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1246 oberon_expr_t
* expr
;
1247 oberon_type_t
* result
;
1249 if(ITMAKESBOOLEAN(token
))
1251 if(ITUSEONLYINTEGER(token
))
1253 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1254 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1256 oberon_error(ctx
, "used only with integer types");
1259 else if(ITUSEONLYBOOLEAN(token
))
1261 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1262 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1264 oberon_error(ctx
, "used only with boolean type");
1268 result
= ctx
-> bool_type
;
1272 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1274 else if(token
== NEQ
)
1276 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1278 else if(token
== LESS
)
1280 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1282 else if(token
== LEQ
)
1284 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1286 else if(token
== GREAT
)
1288 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1290 else if(token
== GEQ
)
1292 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1294 else if(token
== OR
)
1296 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1298 else if(token
== AND
)
1300 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1304 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1309 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1313 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1315 else if(token
== MINUS
)
1317 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1319 else if(token
== STAR
)
1321 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1323 else if(token
== SLASH
)
1325 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1327 else if(token
== DIV
)
1329 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1331 else if(token
== MOD
)
1333 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1337 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1344 #define ISMULOP(x) \
1345 ((x) >= STAR && (x) <= AND)
1347 static oberon_expr_t
*
1348 oberon_term_expr(oberon_context_t
* ctx
)
1350 oberon_expr_t
* expr
;
1352 expr
= oberon_factor(ctx
);
1353 while(ISMULOP(ctx
-> token
))
1355 int token
= ctx
-> token
;
1356 oberon_read_token(ctx
);
1358 oberon_expr_t
* inter
= oberon_factor(ctx
);
1359 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1365 #define ISADDOP(x) \
1366 ((x) >= PLUS && (x) <= OR)
1368 static oberon_expr_t
*
1369 oberon_simple_expr(oberon_context_t
* ctx
)
1371 oberon_expr_t
* expr
;
1374 if(ctx
-> token
== PLUS
)
1377 oberon_assert_token(ctx
, PLUS
);
1379 else if(ctx
-> token
== MINUS
)
1382 oberon_assert_token(ctx
, MINUS
);
1385 expr
= oberon_term_expr(ctx
);
1386 while(ISADDOP(ctx
-> token
))
1388 int token
= ctx
-> token
;
1389 oberon_read_token(ctx
);
1391 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1392 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1397 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1403 #define ISRELATION(x) \
1404 ((x) >= EQUAL && (x) <= GEQ)
1406 static oberon_expr_t
*
1407 oberon_expr(oberon_context_t
* ctx
)
1409 oberon_expr_t
* expr
;
1411 expr
= oberon_simple_expr(ctx
);
1412 while(ISRELATION(ctx
-> token
))
1414 int token
= ctx
-> token
;
1415 oberon_read_token(ctx
);
1417 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1418 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1424 static oberon_item_t
*
1425 oberon_const_expr(oberon_context_t
* ctx
)
1427 oberon_expr_t
* expr
;
1428 expr
= oberon_expr(ctx
);
1430 if(expr
-> is_item
== 0)
1432 oberon_error(ctx
, "const expression are required");
1435 return (oberon_item_t
*) expr
;
1438 // =======================================================================
1440 // =======================================================================
1442 static void oberon_decl_seq(oberon_context_t
* ctx
);
1443 static void oberon_statement_seq(oberon_context_t
* ctx
);
1444 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1447 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1449 if(ctx
-> token
!= token
)
1451 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1456 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1458 oberon_expect_token(ctx
, token
);
1459 oberon_read_token(ctx
);
1463 oberon_assert_ident(oberon_context_t
* ctx
)
1465 oberon_expect_token(ctx
, IDENT
);
1466 char * ident
= ctx
-> string
;
1467 oberon_read_token(ctx
);
1472 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1474 switch(ctx
-> token
)
1477 oberon_assert_token(ctx
, STAR
);
1482 oberon_assert_token(ctx
, MINUS
);
1493 static oberon_object_t
*
1494 oberon_ident_def(oberon_context_t
* ctx
, int class)
1499 oberon_object_t
* x
;
1501 name
= oberon_assert_ident(ctx
);
1502 oberon_def(ctx
, &export
, &read_only
);
1504 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
);
1509 oberon_ident_list(oberon_context_t
* ctx
, int class, int * num
, oberon_object_t
** list
)
1512 *list
= oberon_ident_def(ctx
, class);
1513 while(ctx
-> token
== COMMA
)
1515 oberon_assert_token(ctx
, COMMA
);
1516 oberon_ident_def(ctx
, class);
1522 oberon_var_decl(oberon_context_t
* ctx
)
1525 oberon_object_t
* list
;
1526 oberon_type_t
* type
;
1527 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1529 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, &num
, &list
);
1530 oberon_assert_token(ctx
, COLON
);
1531 oberon_type(ctx
, &type
);
1533 oberon_object_t
* var
= list
;
1534 for(int i
= 0; i
< num
; i
++)
1541 static oberon_object_t
*
1542 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1544 int class = OBERON_CLASS_PARAM
;
1545 if(ctx
-> token
== VAR
)
1547 oberon_read_token(ctx
);
1548 class = OBERON_CLASS_VAR_PARAM
;
1552 oberon_object_t
* list
;
1553 oberon_ident_list(ctx
, class, &num
, &list
);
1555 oberon_assert_token(ctx
, COLON
);
1557 oberon_type_t
* type
;
1558 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1559 oberon_type(ctx
, &type
);
1561 oberon_object_t
* param
= list
;
1562 for(int i
= 0; i
< num
; i
++)
1564 param
-> type
= type
;
1565 param
= param
-> next
;
1572 #define ISFPSECTION \
1573 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1576 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1578 oberon_assert_token(ctx
, LPAREN
);
1582 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1583 while(ctx
-> token
== SEMICOLON
)
1585 oberon_assert_token(ctx
, SEMICOLON
);
1586 oberon_fp_section(ctx
, &signature
-> num_decl
);
1590 oberon_assert_token(ctx
, RPAREN
);
1592 if(ctx
-> token
== COLON
)
1594 oberon_assert_token(ctx
, COLON
);
1596 oberon_object_t
* typeobj
;
1597 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1598 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1600 oberon_error(ctx
, "function result is not type");
1602 signature
-> base
= typeobj
-> type
;
1607 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1609 oberon_type_t
* signature
;
1611 signature
-> class = OBERON_TYPE_PROCEDURE
;
1612 signature
-> num_decl
= 0;
1613 signature
-> base
= ctx
-> void_type
;
1614 signature
-> decl
= NULL
;
1616 if(ctx
-> token
== LPAREN
)
1618 oberon_formal_pars(ctx
, signature
);
1623 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1625 if(a
-> num_decl
!= b
-> num_decl
)
1627 oberon_error(ctx
, "number parameters not matched");
1630 int num_param
= a
-> num_decl
;
1631 oberon_object_t
* param_a
= a
-> decl
;
1632 oberon_object_t
* param_b
= b
-> decl
;
1633 for(int i
= 0; i
< num_param
; i
++)
1635 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1637 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1640 if(param_a
-> type
!= param_b
-> type
)
1642 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1645 param_a
= param_a
-> next
;
1646 param_b
= param_b
-> next
;
1651 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1653 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1654 oberon_type_t
* result_type
= proc
-> type
-> base
;
1656 if(result_type
-> class == OBERON_TYPE_VOID
)
1660 oberon_error(ctx
, "procedure has no result type");
1667 oberon_error(ctx
, "procedure requires expression on result");
1670 oberon_autocast_to(ctx
, expr
, result_type
);
1673 proc
-> has_return
= 1;
1675 oberon_generate_return(ctx
, expr
);
1679 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1681 oberon_assert_token(ctx
, SEMICOLON
);
1683 ctx
-> decl
= proc
-> scope
;
1685 oberon_decl_seq(ctx
);
1687 oberon_generate_begin_proc(ctx
, proc
);
1689 if(ctx
-> token
== BEGIN
)
1691 oberon_assert_token(ctx
, BEGIN
);
1692 oberon_statement_seq(ctx
);
1695 oberon_assert_token(ctx
, END
);
1696 char * name
= oberon_assert_ident(ctx
);
1697 if(strcmp(name
, proc
-> name
) != 0)
1699 oberon_error(ctx
, "procedure name not matched");
1702 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1703 && proc
-> has_return
== 0)
1705 oberon_make_return(ctx
, NULL
);
1708 if(proc
-> has_return
== 0)
1710 oberon_error(ctx
, "procedure requires return");
1713 oberon_generate_end_proc(ctx
);
1714 oberon_close_scope(ctx
-> decl
);
1718 oberon_proc_decl(oberon_context_t
* ctx
)
1720 oberon_assert_token(ctx
, PROCEDURE
);
1723 if(ctx
-> token
== UPARROW
)
1725 oberon_assert_token(ctx
, UPARROW
);
1732 name
= oberon_assert_ident(ctx
);
1733 oberon_def(ctx
, &export
, &read_only
);
1735 oberon_scope_t
* proc_scope
;
1736 proc_scope
= oberon_open_scope(ctx
);
1737 ctx
-> decl
-> local
= 1;
1739 oberon_type_t
* signature
;
1740 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1741 oberon_opt_formal_pars(ctx
, &signature
);
1743 oberon_initialize_decl(ctx
);
1744 oberon_generator_init_type(ctx
, signature
);
1745 oberon_close_scope(ctx
-> decl
);
1747 oberon_object_t
* proc
;
1748 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1751 if(proc
-> class != OBERON_CLASS_PROC
)
1753 oberon_error(ctx
, "mult definition");
1760 oberon_error(ctx
, "mult procedure definition");
1764 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
1766 oberon_error(ctx
, "export type not matched");
1769 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1773 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
);
1774 proc
-> type
= signature
;
1775 proc
-> scope
= proc_scope
;
1776 oberon_generator_init_proc(ctx
, proc
);
1779 proc
-> scope
-> parent
= proc
;
1784 oberon_proc_decl_body(ctx
, proc
);
1789 oberon_const_decl(oberon_context_t
* ctx
)
1791 oberon_item_t
* value
;
1792 oberon_object_t
* constant
;
1794 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
);
1795 oberon_assert_token(ctx
, EQUAL
);
1796 value
= oberon_const_expr(ctx
);
1797 constant
-> value
= value
;
1801 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
1803 if(size
-> is_item
== 0)
1805 oberon_error(ctx
, "requires constant");
1808 if(size
-> item
.mode
!= MODE_INTEGER
)
1810 oberon_error(ctx
, "requires integer constant");
1813 oberon_type_t
* arr
;
1815 arr
-> class = OBERON_TYPE_ARRAY
;
1816 arr
-> size
= size
-> item
.integer
;
1821 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1823 if(ctx
-> token
== IDENT
)
1826 oberon_object_t
* list
;
1827 oberon_type_t
* type
;
1828 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1830 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, &num
, &list
);
1831 oberon_assert_token(ctx
, COLON
);
1832 oberon_type(ctx
, &type
);
1834 oberon_object_t
* field
= list
;
1835 for(int i
= 0; i
< num
; i
++)
1837 field
-> type
= type
;
1838 field
= field
-> next
;
1841 rec
-> num_decl
+= num
;
1846 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1849 oberon_object_t
* to
;
1851 to
= oberon_qualident(ctx
, &name
, 0);
1853 //name = oberon_assert_ident(ctx);
1854 //to = oberon_find_object(ctx -> decl, name, 0);
1858 if(to
-> class != OBERON_CLASS_TYPE
)
1860 oberon_error(ctx
, "not a type");
1865 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, 0, 0);
1866 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1872 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
1875 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1879 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
1887 oberon_type_t
* dim
;
1888 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1890 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
1892 oberon_make_array_type(ctx
, sizes
, dim
, type
);
1896 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1898 if(ctx
-> token
== IDENT
)
1900 oberon_qualident_type(ctx
, type
);
1902 else if(ctx
-> token
== ARRAY
)
1904 oberon_assert_token(ctx
, ARRAY
);
1907 oberon_expr_t
* sizes
;
1908 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
1910 oberon_assert_token(ctx
, OF
);
1912 oberon_type_t
* base
;
1913 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1914 oberon_type(ctx
, &base
);
1916 oberon_make_multiarray(ctx
, sizes
, base
, type
);
1918 else if(ctx
-> token
== RECORD
)
1920 oberon_type_t
* rec
;
1922 rec
-> class = OBERON_TYPE_RECORD
;
1924 oberon_scope_t
* record_scope
;
1925 record_scope
= oberon_open_scope(ctx
);
1926 // TODO parent object
1927 //record_scope -> parent = NULL;
1928 record_scope
-> local
= 1;
1930 oberon_assert_token(ctx
, RECORD
);
1931 oberon_field_list(ctx
, rec
);
1932 while(ctx
-> token
== SEMICOLON
)
1934 oberon_assert_token(ctx
, SEMICOLON
);
1935 oberon_field_list(ctx
, rec
);
1937 oberon_assert_token(ctx
, END
);
1939 rec
-> decl
= record_scope
-> list
-> next
;
1940 oberon_close_scope(record_scope
);
1944 else if(ctx
-> token
== POINTER
)
1946 oberon_assert_token(ctx
, POINTER
);
1947 oberon_assert_token(ctx
, TO
);
1949 oberon_type_t
* base
;
1950 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1951 oberon_type(ctx
, &base
);
1953 oberon_type_t
* ptr
;
1955 ptr
-> class = OBERON_TYPE_POINTER
;
1958 else if(ctx
-> token
== PROCEDURE
)
1960 oberon_open_scope(ctx
);
1961 oberon_assert_token(ctx
, PROCEDURE
);
1962 oberon_opt_formal_pars(ctx
, type
);
1963 oberon_close_scope(ctx
-> decl
);
1967 oberon_error(ctx
, "invalid type declaration");
1972 oberon_type_decl(oberon_context_t
* ctx
)
1975 oberon_object_t
* newtype
;
1976 oberon_type_t
* type
;
1980 name
= oberon_assert_ident(ctx
);
1981 oberon_def(ctx
, &export
, &read_only
);
1983 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
1986 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
1987 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1988 assert(newtype
-> type
);
1992 if(newtype
-> class != OBERON_CLASS_TYPE
)
1994 oberon_error(ctx
, "mult definition");
1997 if(newtype
-> linked
)
1999 oberon_error(ctx
, "mult definition - already linked");
2002 newtype
-> export
= export
;
2003 newtype
-> read_only
= read_only
;
2006 oberon_assert_token(ctx
, EQUAL
);
2008 type
= newtype
-> type
;
2009 oberon_type(ctx
, &type
);
2011 if(type
-> class == OBERON_TYPE_VOID
)
2013 oberon_error(ctx
, "recursive alias declaration");
2016 newtype
-> type
= type
;
2017 newtype
-> linked
= 1;
2020 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2021 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2024 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
2026 if(type
-> class != OBERON_TYPE_POINTER
2027 && type
-> class != OBERON_TYPE_ARRAY
)
2032 if(type
-> recursive
)
2034 oberon_error(ctx
, "recursive pointer declaration");
2037 if(type
-> base
-> class == OBERON_TYPE_POINTER
)
2039 oberon_error(ctx
, "attempt to make pointer to pointer");
2042 type
-> recursive
= 1;
2044 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
2046 type
-> recursive
= 0;
2050 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
2052 if(type
-> class != OBERON_TYPE_RECORD
)
2057 if(type
-> recursive
)
2059 oberon_error(ctx
, "recursive record declaration");
2062 type
-> recursive
= 1;
2064 int num_fields
= type
-> num_decl
;
2065 oberon_object_t
* field
= type
-> decl
;
2066 for(int i
= 0; i
< num_fields
; i
++)
2068 oberon_prevent_recursive_object(ctx
, field
);
2069 field
= field
-> next
;
2072 type
-> recursive
= 0;
2075 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2077 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2082 if(type
-> recursive
)
2084 oberon_error(ctx
, "recursive procedure declaration");
2087 type
-> recursive
= 1;
2089 int num_fields
= type
-> num_decl
;
2090 oberon_object_t
* field
= type
-> decl
;
2091 for(int i
= 0; i
< num_fields
; i
++)
2093 oberon_prevent_recursive_object(ctx
, field
);
2094 field
= field
-> next
;
2097 type
-> recursive
= 0;
2101 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2103 if(type
-> class != OBERON_TYPE_ARRAY
)
2108 if(type
-> recursive
)
2110 oberon_error(ctx
, "recursive array declaration");
2113 type
-> recursive
= 1;
2115 oberon_prevent_recursive_type(ctx
, type
-> base
);
2117 type
-> recursive
= 0;
2121 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2123 if(type
-> class == OBERON_TYPE_POINTER
)
2125 oberon_prevent_recursive_pointer(ctx
, type
);
2127 else if(type
-> class == OBERON_TYPE_RECORD
)
2129 oberon_prevent_recursive_record(ctx
, type
);
2131 else if(type
-> class == OBERON_TYPE_ARRAY
)
2133 oberon_prevent_recursive_array(ctx
, type
);
2135 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2137 oberon_prevent_recursive_procedure(ctx
, type
);
2142 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2146 case OBERON_CLASS_VAR
:
2147 case OBERON_CLASS_TYPE
:
2148 case OBERON_CLASS_PARAM
:
2149 case OBERON_CLASS_VAR_PARAM
:
2150 case OBERON_CLASS_FIELD
:
2151 oberon_prevent_recursive_type(ctx
, x
-> type
);
2153 case OBERON_CLASS_CONST
:
2154 case OBERON_CLASS_PROC
:
2155 case OBERON_CLASS_MODULE
:
2158 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2164 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2166 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2170 oberon_prevent_recursive_object(ctx
, x
);
2175 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2176 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2179 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2181 if(type
-> class != OBERON_TYPE_RECORD
)
2186 int num_fields
= type
-> num_decl
;
2187 oberon_object_t
* field
= type
-> decl
;
2188 for(int i
= 0; i
< num_fields
; i
++)
2190 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2192 oberon_initialize_type(ctx
, field
-> type
);
2195 oberon_initialize_object(ctx
, field
);
2196 field
= field
-> next
;
2199 oberon_generator_init_record(ctx
, type
);
2203 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2205 if(type
-> class == OBERON_TYPE_VOID
)
2207 oberon_error(ctx
, "undeclarated type");
2210 if(type
-> initialized
)
2215 type
-> initialized
= 1;
2217 if(type
-> class == OBERON_TYPE_POINTER
)
2219 oberon_initialize_type(ctx
, type
-> base
);
2220 oberon_generator_init_type(ctx
, type
);
2222 else if(type
-> class == OBERON_TYPE_ARRAY
)
2224 oberon_initialize_type(ctx
, type
-> base
);
2225 oberon_generator_init_type(ctx
, type
);
2227 else if(type
-> class == OBERON_TYPE_RECORD
)
2229 oberon_generator_init_type(ctx
, type
);
2230 oberon_initialize_record_fields(ctx
, type
);
2232 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2234 int num_fields
= type
-> num_decl
;
2235 oberon_object_t
* field
= type
-> decl
;
2236 for(int i
= 0; i
< num_fields
; i
++)
2238 oberon_initialize_object(ctx
, field
);
2239 field
= field
-> next
;
2242 oberon_generator_init_type(ctx
, type
);
2246 oberon_generator_init_type(ctx
, type
);
2251 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2253 if(x
-> initialized
)
2258 x
-> initialized
= 1;
2262 case OBERON_CLASS_TYPE
:
2263 oberon_initialize_type(ctx
, x
-> type
);
2265 case OBERON_CLASS_VAR
:
2266 case OBERON_CLASS_PARAM
:
2267 case OBERON_CLASS_VAR_PARAM
:
2268 case OBERON_CLASS_FIELD
:
2269 oberon_initialize_type(ctx
, x
-> type
);
2270 oberon_generator_init_var(ctx
, x
);
2272 case OBERON_CLASS_CONST
:
2273 case OBERON_CLASS_PROC
:
2274 case OBERON_CLASS_MODULE
:
2277 oberon_error(ctx
, "oberon_initialize_object: wat");
2283 oberon_initialize_decl(oberon_context_t
* ctx
)
2285 oberon_object_t
* x
= ctx
-> decl
-> list
;
2289 oberon_initialize_object(ctx
, x
-> next
);
2295 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2297 oberon_object_t
* x
= ctx
-> decl
-> list
;
2301 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2303 if(x
-> next
-> linked
== 0)
2305 oberon_error(ctx
, "unresolved forward declaration");
2313 oberon_decl_seq(oberon_context_t
* ctx
)
2315 if(ctx
-> token
== CONST
)
2317 oberon_assert_token(ctx
, CONST
);
2318 while(ctx
-> token
== IDENT
)
2320 oberon_const_decl(ctx
);
2321 oberon_assert_token(ctx
, SEMICOLON
);
2325 if(ctx
-> token
== TYPE
)
2327 oberon_assert_token(ctx
, TYPE
);
2328 while(ctx
-> token
== IDENT
)
2330 oberon_type_decl(ctx
);
2331 oberon_assert_token(ctx
, SEMICOLON
);
2335 if(ctx
-> token
== VAR
)
2337 oberon_assert_token(ctx
, VAR
);
2338 while(ctx
-> token
== IDENT
)
2340 oberon_var_decl(ctx
);
2341 oberon_assert_token(ctx
, SEMICOLON
);
2345 oberon_prevent_recursive_decl(ctx
);
2346 oberon_initialize_decl(ctx
);
2348 while(ctx
-> token
== PROCEDURE
)
2350 oberon_proc_decl(ctx
);
2351 oberon_assert_token(ctx
, SEMICOLON
);
2354 oberon_prevent_undeclarated_procedures(ctx
);
2358 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2360 if(dst
-> read_only
)
2362 oberon_error(ctx
, "read-only destination");
2365 oberon_autocast_to(ctx
, src
, dst
-> result
);
2366 oberon_generate_assign(ctx
, src
, dst
);
2370 oberon_statement(oberon_context_t
* ctx
)
2372 oberon_expr_t
* item1
;
2373 oberon_expr_t
* item2
;
2375 if(ctx
-> token
== IDENT
)
2377 item1
= oberon_designator(ctx
);
2378 if(ctx
-> token
== ASSIGN
)
2380 oberon_assert_token(ctx
, ASSIGN
);
2381 item2
= oberon_expr(ctx
);
2382 oberon_assign(ctx
, item2
, item1
);
2386 oberon_opt_proc_parens(ctx
, item1
);
2389 else if(ctx
-> token
== RETURN
)
2391 oberon_assert_token(ctx
, RETURN
);
2392 if(ISEXPR(ctx
-> token
))
2394 oberon_expr_t
* expr
;
2395 expr
= oberon_expr(ctx
);
2396 oberon_make_return(ctx
, expr
);
2400 oberon_make_return(ctx
, NULL
);
2406 oberon_statement_seq(oberon_context_t
* ctx
)
2408 oberon_statement(ctx
);
2409 while(ctx
-> token
== SEMICOLON
)
2411 oberon_assert_token(ctx
, SEMICOLON
);
2412 oberon_statement(ctx
);
2417 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2419 oberon_module_t
* m
= ctx
-> module_list
;
2420 while(m
&& strcmp(m
-> name
, name
) != 0)
2428 code
= ctx
-> import_module(name
);
2431 oberon_error(ctx
, "no such module");
2434 m
= oberon_compile_module(ctx
, code
);
2440 oberon_error(ctx
, "cyclic module import");
2443 oberon_object_t
* ident
;
2444 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, 0, 0);
2445 ident
-> module
= m
;
2449 oberon_import_decl(oberon_context_t
* ctx
)
2454 alias
= name
= oberon_assert_ident(ctx
);
2455 if(ctx
-> token
== ASSIGN
)
2457 oberon_assert_token(ctx
, ASSIGN
);
2458 name
= oberon_assert_ident(ctx
);
2461 oberon_import_module(ctx
, alias
, name
);
2465 oberon_import_list(oberon_context_t
* ctx
)
2467 oberon_assert_token(ctx
, IMPORT
);
2469 oberon_import_decl(ctx
);
2470 while(ctx
-> token
== COMMA
)
2472 oberon_assert_token(ctx
, COMMA
);
2473 oberon_import_decl(ctx
);
2476 oberon_assert_token(ctx
, SEMICOLON
);
2480 oberon_parse_module(oberon_context_t
* ctx
)
2484 oberon_read_token(ctx
);
2486 oberon_assert_token(ctx
, MODULE
);
2487 name1
= oberon_assert_ident(ctx
);
2488 oberon_assert_token(ctx
, SEMICOLON
);
2489 ctx
-> mod
-> name
= name1
;
2491 if(ctx
-> token
== IMPORT
)
2493 oberon_import_list(ctx
);
2496 oberon_decl_seq(ctx
);
2498 oberon_generate_begin_module(ctx
);
2499 if(ctx
-> token
== BEGIN
)
2501 oberon_assert_token(ctx
, BEGIN
);
2502 oberon_statement_seq(ctx
);
2504 oberon_generate_end_module(ctx
);
2506 oberon_assert_token(ctx
, END
);
2507 name2
= oberon_assert_ident(ctx
);
2508 oberon_assert_token(ctx
, DOT
);
2510 if(strcmp(name1
, name2
) != 0)
2512 oberon_error(ctx
, "module name not matched");
2516 // =======================================================================
2518 // =======================================================================
2521 register_default_types(oberon_context_t
* ctx
)
2523 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2524 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2526 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2527 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2528 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2530 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
2531 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1);
2533 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
2534 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1);
2538 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2540 oberon_object_t
* proc
;
2541 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, 1, 0);
2542 proc
-> sysproc
= 1;
2543 proc
-> genfunc
= f
;
2544 proc
-> genproc
= p
;
2545 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2548 static oberon_expr_t
*
2549 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2553 oberon_error(ctx
, "too few arguments");
2558 oberon_error(ctx
, "too mach arguments");
2561 oberon_expr_t
* arg
;
2564 oberon_type_t
* result_type
;
2565 result_type
= arg
-> result
;
2567 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2569 oberon_error(ctx
, "ABS accepts only integers");
2573 oberon_expr_t
* expr
;
2574 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2579 oberon_make_new_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2583 oberon_error(ctx
, "too few arguments");
2588 oberon_error(ctx
, "too mach arguments");
2591 oberon_expr_t
* dst
;
2594 oberon_type_t
* type
;
2595 type
= dst
-> result
;
2597 if(type
-> class != OBERON_TYPE_POINTER
)
2599 oberon_error(ctx
, "not a pointer");
2602 type
= type
-> base
;
2604 oberon_expr_t
* src
;
2605 src
= oberon_new_item(MODE_NEW
, dst
-> result
, 0);
2606 src
-> item
.num_args
= 0;
2607 src
-> item
.args
= NULL
;
2609 if(type
-> class == OBERON_TYPE_ARRAY
)
2611 // Пригодится при работе с открытыми массивами
2614 oberon_expr_t * sizes = NULL;
2615 oberon_expr_t * last_size = NULL;
2616 sizes = last_size = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
2617 sizes -> item.integer = type -> size;
2618 oberon_type_t * base = type -> base;
2619 while(base -> class == OBERON_TYPE_ARRAY)
2621 oberon_expr_t * size;
2622 size = last_size = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
2623 size -> item.integer = base -> size;
2625 last_size -> next = size;
2627 base = base -> base;
2632 src
-> item
.num_args
= 0;
2633 src
-> item
.args
= NULL
;
2635 else if(type
-> class != OBERON_TYPE_RECORD
)
2637 oberon_error(ctx
, "oberon_make_new_call: wat");
2640 oberon_assign(ctx
, src
, dst
);
2644 oberon_create_context(ModuleImportCallback import_module
)
2646 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2648 oberon_scope_t
* world_scope
;
2649 world_scope
= oberon_open_scope(ctx
);
2650 ctx
-> world_scope
= world_scope
;
2652 ctx
-> import_module
= import_module
;
2654 oberon_generator_init_context(ctx
);
2656 register_default_types(ctx
);
2657 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2658 oberon_new_intrinsic(ctx
, "NEW", NULL
, oberon_make_new_call
);
2664 oberon_destroy_context(oberon_context_t
* ctx
)
2666 oberon_generator_destroy_context(ctx
);
2671 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2673 const char * code
= ctx
-> code
;
2674 int code_index
= ctx
-> code_index
;
2676 int token
= ctx
-> token
;
2677 char * string
= ctx
-> string
;
2678 int integer
= ctx
-> integer
;
2679 oberon_scope_t
* decl
= ctx
-> decl
;
2680 oberon_module_t
* mod
= ctx
-> mod
;
2682 oberon_scope_t
* module_scope
;
2683 module_scope
= oberon_open_scope(ctx
);
2685 oberon_module_t
* module
;
2686 module
= calloc(1, sizeof *module
);
2687 module
-> decl
= module_scope
;
2688 module
-> next
= ctx
-> module_list
;
2690 ctx
-> mod
= module
;
2691 ctx
-> module_list
= module
;
2693 oberon_init_scaner(ctx
, newcode
);
2694 oberon_parse_module(ctx
);
2696 module
-> ready
= 1;
2699 ctx
-> code_index
= code_index
;
2701 ctx
-> token
= token
;
2702 ctx
-> string
= string
;
2703 ctx
-> integer
= integer
;