4b20dad3d30de42797478959dc92d2cd1e8929b9
10 #include "generator.h"
61 // =======================================================================
63 // =======================================================================
66 oberon_error(oberon_context_t
* ctx
, const char * fmt
, ...)
70 fprintf(stderr
, "error: ");
71 vfprintf(stderr
, fmt
, ptr
);
72 fprintf(stderr
, "\n");
73 fprintf(stderr
, " code_index = %i\n", ctx
-> code_index
);
74 fprintf(stderr
, " c = %c\n", ctx
-> c
);
75 fprintf(stderr
, " token = %i\n", ctx
-> token
);
80 static oberon_type_t
*
81 oberon_new_type_ptr(int class)
83 oberon_type_t
* x
= malloc(sizeof *x
);
84 memset(x
, 0, sizeof *x
);
89 static oberon_type_t
*
90 oberon_new_type_integer(int size
)
93 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
98 static oberon_type_t
*
99 oberon_new_type_boolean(int size
)
102 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
107 static oberon_type_t
*
108 oberon_new_type_real(int size
)
111 x
= oberon_new_type_ptr(OBERON_TYPE_REAL
);
116 // =======================================================================
118 // =======================================================================
120 static oberon_scope_t
*
121 oberon_open_scope(oberon_context_t
* ctx
)
123 oberon_scope_t
* scope
= calloc(1, sizeof *scope
);
124 oberon_object_t
* list
= calloc(1, sizeof *list
);
127 scope
-> list
= list
;
128 scope
-> up
= ctx
-> decl
;
132 scope
-> parent
= scope
-> up
-> parent
;
133 scope
-> local
= scope
-> up
-> local
;
141 oberon_close_scope(oberon_scope_t
* scope
)
143 oberon_context_t
* ctx
= scope
-> ctx
;
144 ctx
-> decl
= scope
-> up
;
147 static oberon_object_t
*
148 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class, int export
, int read_only
)
150 oberon_object_t
* x
= scope
-> list
;
151 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
158 oberon_error(scope
-> ctx
, "already defined");
161 oberon_object_t
* newvar
= malloc(sizeof *newvar
);
162 memset(newvar
, 0, sizeof *newvar
);
163 newvar
-> name
= name
;
164 newvar
-> class = class;
165 newvar
-> export
= export
;
166 newvar
-> read_only
= read_only
;
167 newvar
-> local
= scope
-> local
;
168 newvar
-> parent
= scope
-> parent
;
169 newvar
-> module
= scope
-> ctx
-> mod
;
176 static oberon_object_t
*
177 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
179 oberon_object_t
* x
= list
;
180 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
187 static oberon_object_t
*
188 oberon_find_object(oberon_scope_t
* scope
, char * name
, int check_it
)
190 oberon_object_t
* result
= NULL
;
192 oberon_scope_t
* s
= scope
;
193 while(result
== NULL
&& s
!= NULL
)
195 result
= oberon_find_object_in_list(s
-> list
, name
);
199 if(check_it
&& result
== NULL
)
201 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
207 static oberon_object_t
*
208 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
210 oberon_object_t
* x
= rec
-> decl
;
211 for(int i
= 0; i
< rec
-> num_decl
; i
++)
213 if(strcmp(x
-> name
, name
) == 0)
220 oberon_error(ctx
, "field not defined");
225 static oberon_object_t
*
226 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
, int export
)
228 oberon_object_t
* id
;
229 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
, export
, 0);
231 oberon_generator_init_type(scope
-> ctx
, type
);
235 // =======================================================================
237 // =======================================================================
240 oberon_get_char(oberon_context_t
* ctx
)
242 if(ctx
-> code
[ctx
-> code_index
])
244 ctx
-> code_index
+= 1;
245 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
250 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
253 ctx
-> code_index
= 0;
254 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
258 oberon_read_ident(oberon_context_t
* ctx
)
261 int i
= ctx
-> code_index
;
263 int c
= ctx
-> code
[i
];
271 char * ident
= malloc(len
+ 1);
272 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
275 ctx
-> code_index
= i
;
276 ctx
-> c
= ctx
-> code
[i
];
277 ctx
-> string
= ident
;
278 ctx
-> token
= IDENT
;
280 if(strcmp(ident
, "MODULE") == 0)
282 ctx
-> token
= MODULE
;
284 else if(strcmp(ident
, "END") == 0)
288 else if(strcmp(ident
, "VAR") == 0)
292 else if(strcmp(ident
, "BEGIN") == 0)
294 ctx
-> token
= BEGIN
;
296 else if(strcmp(ident
, "TRUE") == 0)
300 else if(strcmp(ident
, "FALSE") == 0)
302 ctx
-> token
= FALSE
;
304 else if(strcmp(ident
, "OR") == 0)
308 else if(strcmp(ident
, "DIV") == 0)
312 else if(strcmp(ident
, "MOD") == 0)
316 else if(strcmp(ident
, "PROCEDURE") == 0)
318 ctx
-> token
= PROCEDURE
;
320 else if(strcmp(ident
, "RETURN") == 0)
322 ctx
-> token
= RETURN
;
324 else if(strcmp(ident
, "CONST") == 0)
326 ctx
-> token
= CONST
;
328 else if(strcmp(ident
, "TYPE") == 0)
332 else if(strcmp(ident
, "ARRAY") == 0)
334 ctx
-> token
= ARRAY
;
336 else if(strcmp(ident
, "OF") == 0)
340 else if(strcmp(ident
, "RECORD") == 0)
342 ctx
-> token
= RECORD
;
344 else if(strcmp(ident
, "POINTER") == 0)
346 ctx
-> token
= POINTER
;
348 else if(strcmp(ident
, "TO") == 0)
352 else if(strcmp(ident
, "NIL") == 0)
356 else if(strcmp(ident
, "IMPORT") == 0)
358 ctx
-> token
= IMPORT
;
363 oberon_read_number(oberon_context_t
* ctx
)
376 * mode = 3 == LONGREAL
379 start_i
= ctx
-> code_index
;
381 while(isdigit(ctx
-> c
))
383 oberon_get_char(ctx
);
386 end_i
= ctx
-> code_index
;
388 if(isxdigit(ctx
-> c
))
391 while(isxdigit(ctx
-> c
))
393 oberon_get_char(ctx
);
396 end_i
= ctx
-> code_index
;
400 oberon_error(ctx
, "invalid hex number");
402 oberon_get_char(ctx
);
404 else if(ctx
-> c
== '.')
407 oberon_get_char(ctx
);
409 while(isdigit(ctx
-> c
))
411 oberon_get_char(ctx
);
414 if(ctx
-> c
== 'E' || ctx
-> c
== 'D')
416 exp_i
= ctx
-> code_index
;
423 oberon_get_char(ctx
);
425 if(ctx
-> c
== '+' || ctx
-> c
== '-')
427 oberon_get_char(ctx
);
430 while(isdigit(ctx
-> c
))
432 oberon_get_char(ctx
);
437 end_i
= ctx
-> code_index
;
440 int len
= end_i
- start_i
;
441 ident
= malloc(len
+ 1);
442 memcpy(ident
, &ctx
-> code
[start_i
], len
);
447 int i
= exp_i
- start_i
;
454 integer
= atol(ident
);
456 ctx
-> token
= INTEGER
;
459 sscanf(ident
, "%lx", &integer
);
461 ctx
-> token
= INTEGER
;
465 sscanf(ident
, "%lf", &real
);
469 oberon_error(ctx
, "oberon_read_number: wat");
473 ctx
-> string
= ident
;
474 ctx
-> integer
= integer
;
479 oberon_skip_space(oberon_context_t
* ctx
)
481 while(isspace(ctx
-> c
))
483 oberon_get_char(ctx
);
488 oberon_read_comment(oberon_context_t
* ctx
)
495 oberon_get_char(ctx
);
498 oberon_get_char(ctx
);
502 else if(ctx
-> c
== '*')
504 oberon_get_char(ctx
);
507 oberon_get_char(ctx
);
511 else if(ctx
-> c
== 0)
513 oberon_error(ctx
, "unterminated comment");
517 oberon_get_char(ctx
);
522 static void oberon_read_token(oberon_context_t
* ctx
);
525 oberon_read_symbol(oberon_context_t
* ctx
)
534 ctx
-> token
= SEMICOLON
;
535 oberon_get_char(ctx
);
538 ctx
-> token
= COLON
;
539 oberon_get_char(ctx
);
542 ctx
-> token
= ASSIGN
;
543 oberon_get_char(ctx
);
548 oberon_get_char(ctx
);
551 ctx
-> token
= LPAREN
;
552 oberon_get_char(ctx
);
555 oberon_get_char(ctx
);
556 oberon_read_comment(ctx
);
557 oberon_read_token(ctx
);
561 ctx
-> token
= RPAREN
;
562 oberon_get_char(ctx
);
565 ctx
-> token
= EQUAL
;
566 oberon_get_char(ctx
);
570 oberon_get_char(ctx
);
574 oberon_get_char(ctx
);
578 oberon_get_char(ctx
);
582 ctx
-> token
= GREAT
;
583 oberon_get_char(ctx
);
587 oberon_get_char(ctx
);
592 oberon_get_char(ctx
);
595 ctx
-> token
= MINUS
;
596 oberon_get_char(ctx
);
600 oberon_get_char(ctx
);
603 oberon_get_char(ctx
);
604 oberon_error(ctx
, "unstarted comment");
608 ctx
-> token
= SLASH
;
609 oberon_get_char(ctx
);
613 oberon_get_char(ctx
);
617 oberon_get_char(ctx
);
620 ctx
-> token
= COMMA
;
621 oberon_get_char(ctx
);
624 ctx
-> token
= LBRACE
;
625 oberon_get_char(ctx
);
628 ctx
-> token
= RBRACE
;
629 oberon_get_char(ctx
);
632 ctx
-> token
= UPARROW
;
633 oberon_get_char(ctx
);
636 oberon_error(ctx
, "invalid char %c", ctx
-> c
);
642 oberon_read_token(oberon_context_t
* ctx
)
644 oberon_skip_space(ctx
);
649 oberon_read_ident(ctx
);
653 oberon_read_number(ctx
);
657 oberon_read_symbol(ctx
);
661 // =======================================================================
663 // =======================================================================
665 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
666 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
667 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
668 static char * oberon_assert_ident(oberon_context_t
* ctx
);
669 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
670 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
672 static oberon_expr_t
*
673 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
675 oberon_oper_t
* operator;
676 operator = malloc(sizeof *operator);
677 memset(operator, 0, sizeof *operator);
679 operator -> is_item
= 0;
680 operator -> result
= result
;
681 operator -> read_only
= 1;
683 operator -> left
= left
;
684 operator -> right
= right
;
686 return (oberon_expr_t
*) operator;
689 static oberon_expr_t
*
690 oberon_new_item(int mode
, oberon_type_t
* result
, int read_only
)
692 oberon_item_t
* item
;
693 item
= malloc(sizeof *item
);
694 memset(item
, 0, sizeof *item
);
697 item
-> result
= result
;
698 item
-> read_only
= read_only
;
701 return (oberon_expr_t
*)item
;
704 static oberon_expr_t
*
705 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
707 oberon_expr_t
* expr
;
708 oberon_type_t
* result
;
710 result
= a
-> result
;
714 if(result
-> class != OBERON_TYPE_INTEGER
)
716 oberon_error(ctx
, "incompatible operator type");
719 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
721 else if(token
== NOT
)
723 if(result
-> class != OBERON_TYPE_BOOLEAN
)
725 oberon_error(ctx
, "incompatible operator type");
728 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
732 oberon_error(ctx
, "oberon_make_unary_op: wat");
739 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
741 oberon_expr_t
* last
;
744 *first
= last
= oberon_expr(ctx
);
745 while(ctx
-> token
== COMMA
)
747 oberon_assert_token(ctx
, COMMA
);
748 oberon_expr_t
* current
;
752 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
756 current
= oberon_expr(ctx
);
759 last
-> next
= current
;
765 static oberon_expr_t
*
766 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
768 if(pref
-> class != expr
-> result
-> class)
770 if(pref
-> class != OBERON_TYPE_PROCEDURE
)
772 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
774 oberon_error(ctx
, "incompatible types");
779 if(pref
-> class == OBERON_TYPE_INTEGER
)
781 if(expr
-> result
-> class > pref
-> class)
783 oberon_error(ctx
, "incompatible size");
786 else if(pref
-> class == OBERON_TYPE_RECORD
)
788 if(expr
-> result
!= pref
)
790 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
791 oberon_error(ctx
, "incompatible record types");
794 else if(pref
-> class == OBERON_TYPE_POINTER
)
796 if(expr
-> result
-> base
!= pref
-> base
)
798 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
800 oberon_error(ctx
, "incompatible pointer types");
811 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
813 if(desig
-> is_item
== 0)
815 oberon_error(ctx
, "expected item");
818 if(desig
-> item
.mode
!= MODE_CALL
)
820 oberon_error(ctx
, "expected mode CALL");
823 if(desig
-> item
.var
-> type
-> class != OBERON_TYPE_PROCEDURE
)
825 oberon_error(ctx
, "only procedures can be called");
828 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
829 int num_args
= desig
-> item
.num_args
;
830 int num_decl
= fn
-> num_decl
;
832 if(num_args
< num_decl
)
834 oberon_error(ctx
, "too few arguments");
836 else if(num_args
> num_decl
)
838 oberon_error(ctx
, "too many arguments");
841 oberon_expr_t
* arg
= desig
-> item
.args
;
842 oberon_object_t
* param
= fn
-> decl
;
843 for(int i
= 0; i
< num_args
; i
++)
845 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
849 oberon_error(ctx
, "assign to read-only var");
854 // switch(arg -> item.mode)
859 // // Допустимо разыменование?
860 // //case MODE_DEREF:
863 // oberon_error(ctx, "var-parameter accept only variables");
868 oberon_autocast_to(ctx
, arg
, param
-> type
);
870 param
= param
-> next
;
874 static oberon_expr_t
*
875 oberon_make_call_func(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
877 switch(proc
-> class)
879 case OBERON_CLASS_PROC
:
880 if(proc
-> class != OBERON_CLASS_PROC
)
882 oberon_error(ctx
, "not a procedure");
885 case OBERON_CLASS_VAR
:
886 case OBERON_CLASS_VAR_PARAM
:
887 case OBERON_CLASS_PARAM
:
888 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
890 oberon_error(ctx
, "not a procedure");
894 oberon_error(ctx
, "not a procedure");
898 oberon_expr_t
* call
;
902 if(proc
-> genfunc
== NULL
)
904 oberon_error(ctx
, "not a function-procedure");
907 call
= proc
-> genfunc(ctx
, num_args
, list_args
);
911 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
)
913 oberon_error(ctx
, "attempt to call procedure in expression");
916 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
917 call
-> item
.var
= proc
;
918 call
-> item
.num_args
= num_args
;
919 call
-> item
.args
= list_args
;
920 oberon_autocast_call(ctx
, call
);
927 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
929 switch(proc
-> class)
931 case OBERON_CLASS_PROC
:
932 if(proc
-> class != OBERON_CLASS_PROC
)
934 oberon_error(ctx
, "not a procedure");
937 case OBERON_CLASS_VAR
:
938 case OBERON_CLASS_VAR_PARAM
:
939 case OBERON_CLASS_PARAM
:
940 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
942 oberon_error(ctx
, "not a procedure");
946 oberon_error(ctx
, "not a procedure");
952 if(proc
-> genproc
== NULL
)
954 oberon_error(ctx
, "requres non-typed procedure");
957 proc
-> genproc(ctx
, num_args
, list_args
);
961 if(proc
-> type
-> base
-> class != OBERON_TYPE_VOID
)
963 oberon_error(ctx
, "attempt to call function as non-typed procedure");
966 oberon_expr_t
* call
;
967 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
968 call
-> item
.var
= proc
;
969 call
-> item
.num_args
= num_args
;
970 call
-> item
.args
= list_args
;
971 oberon_autocast_call(ctx
, call
);
972 oberon_generate_call_proc(ctx
, call
);
980 || ((x) == INTEGER) \
986 static oberon_expr_t
*
987 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
989 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
991 oberon_error(ctx
, "not a pointer");
994 assert(expr
-> is_item
);
996 oberon_expr_t
* selector
;
997 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
, expr
-> read_only
);
998 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1003 static oberon_expr_t
*
1004 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
1006 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
1008 desig
= oberno_make_dereferencing(ctx
, desig
);
1011 assert(desig
-> is_item
);
1013 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
1015 oberon_error(ctx
, "not array");
1018 oberon_type_t
* base
;
1019 base
= desig
-> result
-> base
;
1021 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
1023 oberon_error(ctx
, "index must be integer");
1026 // Статическая проверка границ массива
1027 if(index
-> is_item
)
1029 if(index
-> item
.mode
== MODE_INTEGER
)
1031 int arr_size
= desig
-> result
-> size
;
1032 int index_int
= index
-> item
.integer
;
1033 if(index_int
< 0 || index_int
> arr_size
- 1)
1035 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
1040 oberon_expr_t
* selector
;
1041 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
1042 selector
-> item
.parent
= (oberon_item_t
*) desig
;
1043 selector
-> item
.num_args
= 1;
1044 selector
-> item
.args
= index
;
1049 static oberon_expr_t
*
1050 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
1052 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
1054 expr
= oberno_make_dereferencing(ctx
, expr
);
1057 assert(expr
-> is_item
== 1);
1059 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
1061 oberon_error(ctx
, "not record");
1064 oberon_type_t
* rec
= expr
-> result
;
1066 oberon_object_t
* field
;
1067 field
= oberon_find_field(ctx
, rec
, name
);
1069 if(field
-> export
== 0)
1071 if(field
-> module
!= ctx
-> mod
)
1073 oberon_error(ctx
, "field not exported");
1078 if(field
-> read_only
)
1080 if(field
-> module
!= ctx
-> mod
)
1086 oberon_expr_t
* selector
;
1087 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
1088 selector
-> item
.var
= field
;
1089 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1094 #define ISSELECTOR(x) \
1097 || ((x) == UPARROW))
1099 static oberon_object_t
*
1100 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
1103 oberon_object_t
* x
;
1105 name
= oberon_assert_ident(ctx
);
1106 x
= oberon_find_object(ctx
-> decl
, name
, check
);
1110 if(x
-> class == OBERON_CLASS_MODULE
)
1112 oberon_assert_token(ctx
, DOT
);
1113 name
= oberon_assert_ident(ctx
);
1114 /* Наличие объектов в левых модулях всегда проверяется */
1115 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1117 if(x
-> export
== 0)
1119 oberon_error(ctx
, "not exported");
1132 static oberon_expr_t
*
1133 oberon_designator(oberon_context_t
* ctx
)
1136 oberon_object_t
* var
;
1137 oberon_expr_t
* expr
;
1139 var
= oberon_qualident(ctx
, NULL
, 1);
1142 if(var
-> read_only
)
1144 if(var
-> module
!= ctx
-> mod
)
1150 switch(var
-> class)
1152 case OBERON_CLASS_CONST
:
1154 expr
= (oberon_expr_t
*) var
-> value
;
1156 case OBERON_CLASS_VAR
:
1157 case OBERON_CLASS_VAR_PARAM
:
1158 case OBERON_CLASS_PARAM
:
1159 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
1161 case OBERON_CLASS_PROC
:
1162 expr
= oberon_new_item(MODE_VAR
, var
-> type
, 1);
1165 oberon_error(ctx
, "invalid designator");
1168 expr
-> item
.var
= var
;
1170 while(ISSELECTOR(ctx
-> token
))
1172 switch(ctx
-> token
)
1175 oberon_assert_token(ctx
, DOT
);
1176 name
= oberon_assert_ident(ctx
);
1177 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1180 oberon_assert_token(ctx
, LBRACE
);
1181 int num_indexes
= 0;
1182 oberon_expr_t
* indexes
= NULL
;
1183 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1184 oberon_assert_token(ctx
, RBRACE
);
1186 for(int i
= 0; i
< num_indexes
; i
++)
1188 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1189 indexes
= indexes
-> next
;
1193 oberon_assert_token(ctx
, UPARROW
);
1194 expr
= oberno_make_dereferencing(ctx
, expr
);
1197 oberon_error(ctx
, "oberon_designator: wat");
1204 static oberon_expr_t
*
1205 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1207 assert(expr
-> is_item
== 1);
1209 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1210 if(ctx
-> token
== LPAREN
)
1212 oberon_assert_token(ctx
, LPAREN
);
1215 oberon_expr_t
* arguments
= NULL
;
1217 if(ISEXPR(ctx
-> token
))
1219 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1222 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1224 oberon_assert_token(ctx
, RPAREN
);
1231 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1233 assert(expr
-> is_item
== 1);
1236 oberon_expr_t
* arguments
= NULL
;
1238 if(ctx
-> token
== LPAREN
)
1240 oberon_assert_token(ctx
, LPAREN
);
1242 if(ISEXPR(ctx
-> token
))
1244 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1247 oberon_assert_token(ctx
, RPAREN
);
1250 /* Вызов происходит даже без скобок */
1251 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1254 static oberon_expr_t
*
1255 oberon_factor(oberon_context_t
* ctx
)
1257 oberon_expr_t
* expr
;
1259 switch(ctx
-> token
)
1262 expr
= oberon_designator(ctx
);
1263 expr
= oberon_opt_func_parens(ctx
, expr
);
1266 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
, 1);
1267 expr
-> item
.integer
= ctx
-> integer
;
1268 oberon_assert_token(ctx
, INTEGER
);
1271 expr
= oberon_new_item(MODE_REAL
, ctx
-> real_type
, 1);
1272 expr
-> item
.real
= ctx
-> real
;
1273 oberon_assert_token(ctx
, REAL
);
1276 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1277 expr
-> item
.boolean
= 1;
1278 oberon_assert_token(ctx
, TRUE
);
1281 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1282 expr
-> item
.boolean
= 0;
1283 oberon_assert_token(ctx
, FALSE
);
1286 oberon_assert_token(ctx
, LPAREN
);
1287 expr
= oberon_expr(ctx
);
1288 oberon_assert_token(ctx
, RPAREN
);
1291 oberon_assert_token(ctx
, NOT
);
1292 expr
= oberon_factor(ctx
);
1293 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1296 oberon_assert_token(ctx
, NIL
);
1297 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
, 1);
1300 oberon_error(ctx
, "invalid expression");
1307 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1308 * 1. Классы обоих типов должны быть одинаковы
1309 * 2. В качестве результата должен быть выбран больший тип.
1310 * 3. Если размер результат не должен быть меньше чем базовый int
1314 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
1316 if((a
-> class) != (b
-> class))
1318 oberon_error(ctx
, "incompatible types");
1321 if((a
-> size
) > (b
-> size
))
1330 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
1332 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
1334 *result
= ctx
-> int_type
;
1338 /* TODO: cast types */
1341 #define ITMAKESBOOLEAN(x) \
1342 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1344 #define ITUSEONLYINTEGER(x) \
1345 ((x) >= LESS && (x) <= GEQ)
1347 #define ITUSEONLYBOOLEAN(x) \
1348 (((x) == OR) || ((x) == AND))
1350 static oberon_expr_t
*
1351 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1353 oberon_expr_t
* expr
;
1354 oberon_type_t
* result
;
1356 if(ITMAKESBOOLEAN(token
))
1358 if(ITUSEONLYINTEGER(token
))
1360 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1361 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1363 oberon_error(ctx
, "used only with integer types");
1366 else if(ITUSEONLYBOOLEAN(token
))
1368 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1369 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1371 oberon_error(ctx
, "used only with boolean type");
1375 result
= ctx
-> bool_type
;
1379 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1381 else if(token
== NEQ
)
1383 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1385 else if(token
== LESS
)
1387 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1389 else if(token
== LEQ
)
1391 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1393 else if(token
== GREAT
)
1395 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1397 else if(token
== GEQ
)
1399 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1401 else if(token
== OR
)
1403 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1405 else if(token
== AND
)
1407 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1411 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1414 else if(token
== SLASH
)
1416 if(a
-> result
-> class != OBERON_TYPE_REAL
)
1418 if(a
-> result
-> class == OBERON_TYPE_INTEGER
)
1420 oberon_error(ctx
, "TODO cast int -> real");
1424 oberon_error(ctx
, "operator / requires numeric type");
1428 if(b
-> result
-> class != OBERON_TYPE_REAL
)
1430 if(b
-> result
-> class == OBERON_TYPE_INTEGER
)
1432 oberon_error(ctx
, "TODO cast int -> real");
1436 oberon_error(ctx
, "operator / requires numeric type");
1440 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1441 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1443 else if(token
== DIV
)
1445 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1446 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1448 oberon_error(ctx
, "operator DIV requires integer type");
1451 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1452 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1456 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1460 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1462 else if(token
== MINUS
)
1464 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1466 else if(token
== STAR
)
1468 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1470 else if(token
== MOD
)
1472 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1476 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1483 #define ISMULOP(x) \
1484 ((x) >= STAR && (x) <= AND)
1486 static oberon_expr_t
*
1487 oberon_term_expr(oberon_context_t
* ctx
)
1489 oberon_expr_t
* expr
;
1491 expr
= oberon_factor(ctx
);
1492 while(ISMULOP(ctx
-> token
))
1494 int token
= ctx
-> token
;
1495 oberon_read_token(ctx
);
1497 oberon_expr_t
* inter
= oberon_factor(ctx
);
1498 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1504 #define ISADDOP(x) \
1505 ((x) >= PLUS && (x) <= OR)
1507 static oberon_expr_t
*
1508 oberon_simple_expr(oberon_context_t
* ctx
)
1510 oberon_expr_t
* expr
;
1513 if(ctx
-> token
== PLUS
)
1516 oberon_assert_token(ctx
, PLUS
);
1518 else if(ctx
-> token
== MINUS
)
1521 oberon_assert_token(ctx
, MINUS
);
1524 expr
= oberon_term_expr(ctx
);
1525 while(ISADDOP(ctx
-> token
))
1527 int token
= ctx
-> token
;
1528 oberon_read_token(ctx
);
1530 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1531 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1536 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1542 #define ISRELATION(x) \
1543 ((x) >= EQUAL && (x) <= GEQ)
1545 static oberon_expr_t
*
1546 oberon_expr(oberon_context_t
* ctx
)
1548 oberon_expr_t
* expr
;
1550 expr
= oberon_simple_expr(ctx
);
1551 while(ISRELATION(ctx
-> token
))
1553 int token
= ctx
-> token
;
1554 oberon_read_token(ctx
);
1556 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1557 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1563 static oberon_item_t
*
1564 oberon_const_expr(oberon_context_t
* ctx
)
1566 oberon_expr_t
* expr
;
1567 expr
= oberon_expr(ctx
);
1569 if(expr
-> is_item
== 0)
1571 oberon_error(ctx
, "const expression are required");
1574 return (oberon_item_t
*) expr
;
1577 // =======================================================================
1579 // =======================================================================
1581 static void oberon_decl_seq(oberon_context_t
* ctx
);
1582 static void oberon_statement_seq(oberon_context_t
* ctx
);
1583 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1586 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1588 if(ctx
-> token
!= token
)
1590 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1595 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1597 oberon_expect_token(ctx
, token
);
1598 oberon_read_token(ctx
);
1602 oberon_assert_ident(oberon_context_t
* ctx
)
1604 oberon_expect_token(ctx
, IDENT
);
1605 char * ident
= ctx
-> string
;
1606 oberon_read_token(ctx
);
1611 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1613 switch(ctx
-> token
)
1616 oberon_assert_token(ctx
, STAR
);
1621 oberon_assert_token(ctx
, MINUS
);
1632 static oberon_object_t
*
1633 oberon_ident_def(oberon_context_t
* ctx
, int class)
1638 oberon_object_t
* x
;
1640 name
= oberon_assert_ident(ctx
);
1641 oberon_def(ctx
, &export
, &read_only
);
1643 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
);
1648 oberon_ident_list(oberon_context_t
* ctx
, int class, int * num
, oberon_object_t
** list
)
1651 *list
= oberon_ident_def(ctx
, class);
1652 while(ctx
-> token
== COMMA
)
1654 oberon_assert_token(ctx
, COMMA
);
1655 oberon_ident_def(ctx
, class);
1661 oberon_var_decl(oberon_context_t
* ctx
)
1664 oberon_object_t
* list
;
1665 oberon_type_t
* type
;
1666 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1668 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, &num
, &list
);
1669 oberon_assert_token(ctx
, COLON
);
1670 oberon_type(ctx
, &type
);
1672 oberon_object_t
* var
= list
;
1673 for(int i
= 0; i
< num
; i
++)
1680 static oberon_object_t
*
1681 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1683 int class = OBERON_CLASS_PARAM
;
1684 if(ctx
-> token
== VAR
)
1686 oberon_read_token(ctx
);
1687 class = OBERON_CLASS_VAR_PARAM
;
1691 oberon_object_t
* list
;
1692 oberon_ident_list(ctx
, class, &num
, &list
);
1694 oberon_assert_token(ctx
, COLON
);
1696 oberon_type_t
* type
;
1697 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1698 oberon_type(ctx
, &type
);
1700 oberon_object_t
* param
= list
;
1701 for(int i
= 0; i
< num
; i
++)
1703 param
-> type
= type
;
1704 param
= param
-> next
;
1711 #define ISFPSECTION \
1712 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1715 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1717 oberon_assert_token(ctx
, LPAREN
);
1721 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1722 while(ctx
-> token
== SEMICOLON
)
1724 oberon_assert_token(ctx
, SEMICOLON
);
1725 oberon_fp_section(ctx
, &signature
-> num_decl
);
1729 oberon_assert_token(ctx
, RPAREN
);
1731 if(ctx
-> token
== COLON
)
1733 oberon_assert_token(ctx
, COLON
);
1735 oberon_object_t
* typeobj
;
1736 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1737 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1739 oberon_error(ctx
, "function result is not type");
1741 signature
-> base
= typeobj
-> type
;
1746 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1748 oberon_type_t
* signature
;
1750 signature
-> class = OBERON_TYPE_PROCEDURE
;
1751 signature
-> num_decl
= 0;
1752 signature
-> base
= ctx
-> void_type
;
1753 signature
-> decl
= NULL
;
1755 if(ctx
-> token
== LPAREN
)
1757 oberon_formal_pars(ctx
, signature
);
1762 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1764 if(a
-> num_decl
!= b
-> num_decl
)
1766 oberon_error(ctx
, "number parameters not matched");
1769 int num_param
= a
-> num_decl
;
1770 oberon_object_t
* param_a
= a
-> decl
;
1771 oberon_object_t
* param_b
= b
-> decl
;
1772 for(int i
= 0; i
< num_param
; i
++)
1774 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1776 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1779 if(param_a
-> type
!= param_b
-> type
)
1781 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1784 param_a
= param_a
-> next
;
1785 param_b
= param_b
-> next
;
1790 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1792 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1793 oberon_type_t
* result_type
= proc
-> type
-> base
;
1795 if(result_type
-> class == OBERON_TYPE_VOID
)
1799 oberon_error(ctx
, "procedure has no result type");
1806 oberon_error(ctx
, "procedure requires expression on result");
1809 oberon_autocast_to(ctx
, expr
, result_type
);
1812 proc
-> has_return
= 1;
1814 oberon_generate_return(ctx
, expr
);
1818 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1820 oberon_assert_token(ctx
, SEMICOLON
);
1822 ctx
-> decl
= proc
-> scope
;
1824 oberon_decl_seq(ctx
);
1826 oberon_generate_begin_proc(ctx
, proc
);
1828 if(ctx
-> token
== BEGIN
)
1830 oberon_assert_token(ctx
, BEGIN
);
1831 oberon_statement_seq(ctx
);
1834 oberon_assert_token(ctx
, END
);
1835 char * name
= oberon_assert_ident(ctx
);
1836 if(strcmp(name
, proc
-> name
) != 0)
1838 oberon_error(ctx
, "procedure name not matched");
1841 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1842 && proc
-> has_return
== 0)
1844 oberon_make_return(ctx
, NULL
);
1847 if(proc
-> has_return
== 0)
1849 oberon_error(ctx
, "procedure requires return");
1852 oberon_generate_end_proc(ctx
);
1853 oberon_close_scope(ctx
-> decl
);
1857 oberon_proc_decl(oberon_context_t
* ctx
)
1859 oberon_assert_token(ctx
, PROCEDURE
);
1862 if(ctx
-> token
== UPARROW
)
1864 oberon_assert_token(ctx
, UPARROW
);
1871 name
= oberon_assert_ident(ctx
);
1872 oberon_def(ctx
, &export
, &read_only
);
1874 oberon_scope_t
* proc_scope
;
1875 proc_scope
= oberon_open_scope(ctx
);
1876 ctx
-> decl
-> local
= 1;
1878 oberon_type_t
* signature
;
1879 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1880 oberon_opt_formal_pars(ctx
, &signature
);
1882 oberon_initialize_decl(ctx
);
1883 oberon_generator_init_type(ctx
, signature
);
1884 oberon_close_scope(ctx
-> decl
);
1886 oberon_object_t
* proc
;
1887 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1890 if(proc
-> class != OBERON_CLASS_PROC
)
1892 oberon_error(ctx
, "mult definition");
1899 oberon_error(ctx
, "mult procedure definition");
1903 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
1905 oberon_error(ctx
, "export type not matched");
1908 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1912 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
);
1913 proc
-> type
= signature
;
1914 proc
-> scope
= proc_scope
;
1915 oberon_generator_init_proc(ctx
, proc
);
1918 proc
-> scope
-> parent
= proc
;
1923 oberon_proc_decl_body(ctx
, proc
);
1928 oberon_const_decl(oberon_context_t
* ctx
)
1930 oberon_item_t
* value
;
1931 oberon_object_t
* constant
;
1933 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
);
1934 oberon_assert_token(ctx
, EQUAL
);
1935 value
= oberon_const_expr(ctx
);
1936 constant
-> value
= value
;
1940 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
1942 if(size
-> is_item
== 0)
1944 oberon_error(ctx
, "requires constant");
1947 if(size
-> item
.mode
!= MODE_INTEGER
)
1949 oberon_error(ctx
, "requires integer constant");
1952 oberon_type_t
* arr
;
1954 arr
-> class = OBERON_TYPE_ARRAY
;
1955 arr
-> size
= size
-> item
.integer
;
1960 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1962 if(ctx
-> token
== IDENT
)
1965 oberon_object_t
* list
;
1966 oberon_type_t
* type
;
1967 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1969 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, &num
, &list
);
1970 oberon_assert_token(ctx
, COLON
);
1971 oberon_type(ctx
, &type
);
1973 oberon_object_t
* field
= list
;
1974 for(int i
= 0; i
< num
; i
++)
1976 field
-> type
= type
;
1977 field
= field
-> next
;
1980 rec
-> num_decl
+= num
;
1985 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1988 oberon_object_t
* to
;
1990 to
= oberon_qualident(ctx
, &name
, 0);
1992 //name = oberon_assert_ident(ctx);
1993 //to = oberon_find_object(ctx -> decl, name, 0);
1997 if(to
-> class != OBERON_CLASS_TYPE
)
1999 oberon_error(ctx
, "not a type");
2004 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, 0, 0);
2005 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2011 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
2014 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2018 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
2026 oberon_type_t
* dim
;
2027 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2029 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
2031 oberon_make_array_type(ctx
, sizes
, dim
, type
);
2035 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2037 if(ctx
-> token
== IDENT
)
2039 oberon_qualident_type(ctx
, type
);
2041 else if(ctx
-> token
== ARRAY
)
2043 oberon_assert_token(ctx
, ARRAY
);
2046 oberon_expr_t
* sizes
;
2047 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
2049 oberon_assert_token(ctx
, OF
);
2051 oberon_type_t
* base
;
2052 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2053 oberon_type(ctx
, &base
);
2055 oberon_make_multiarray(ctx
, sizes
, base
, type
);
2057 else if(ctx
-> token
== RECORD
)
2059 oberon_type_t
* rec
;
2061 rec
-> class = OBERON_TYPE_RECORD
;
2063 oberon_scope_t
* record_scope
;
2064 record_scope
= oberon_open_scope(ctx
);
2065 // TODO parent object
2066 //record_scope -> parent = NULL;
2067 record_scope
-> local
= 1;
2069 oberon_assert_token(ctx
, RECORD
);
2070 oberon_field_list(ctx
, rec
);
2071 while(ctx
-> token
== SEMICOLON
)
2073 oberon_assert_token(ctx
, SEMICOLON
);
2074 oberon_field_list(ctx
, rec
);
2076 oberon_assert_token(ctx
, END
);
2078 rec
-> decl
= record_scope
-> list
-> next
;
2079 oberon_close_scope(record_scope
);
2083 else if(ctx
-> token
== POINTER
)
2085 oberon_assert_token(ctx
, POINTER
);
2086 oberon_assert_token(ctx
, TO
);
2088 oberon_type_t
* base
;
2089 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2090 oberon_type(ctx
, &base
);
2092 oberon_type_t
* ptr
;
2094 ptr
-> class = OBERON_TYPE_POINTER
;
2097 else if(ctx
-> token
== PROCEDURE
)
2099 oberon_open_scope(ctx
);
2100 oberon_assert_token(ctx
, PROCEDURE
);
2101 oberon_opt_formal_pars(ctx
, type
);
2102 oberon_close_scope(ctx
-> decl
);
2106 oberon_error(ctx
, "invalid type declaration");
2111 oberon_type_decl(oberon_context_t
* ctx
)
2114 oberon_object_t
* newtype
;
2115 oberon_type_t
* type
;
2119 name
= oberon_assert_ident(ctx
);
2120 oberon_def(ctx
, &export
, &read_only
);
2122 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
2125 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
2126 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2127 assert(newtype
-> type
);
2131 if(newtype
-> class != OBERON_CLASS_TYPE
)
2133 oberon_error(ctx
, "mult definition");
2136 if(newtype
-> linked
)
2138 oberon_error(ctx
, "mult definition - already linked");
2141 newtype
-> export
= export
;
2142 newtype
-> read_only
= read_only
;
2145 oberon_assert_token(ctx
, EQUAL
);
2147 type
= newtype
-> type
;
2148 oberon_type(ctx
, &type
);
2150 if(type
-> class == OBERON_TYPE_VOID
)
2152 oberon_error(ctx
, "recursive alias declaration");
2155 newtype
-> type
= type
;
2156 newtype
-> linked
= 1;
2159 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2160 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2163 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
2165 if(type
-> class != OBERON_TYPE_POINTER
2166 && type
-> class != OBERON_TYPE_ARRAY
)
2171 if(type
-> recursive
)
2173 oberon_error(ctx
, "recursive pointer declaration");
2176 if(type
-> base
-> class == OBERON_TYPE_POINTER
)
2178 oberon_error(ctx
, "attempt to make pointer to pointer");
2181 type
-> recursive
= 1;
2183 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
2185 type
-> recursive
= 0;
2189 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
2191 if(type
-> class != OBERON_TYPE_RECORD
)
2196 if(type
-> recursive
)
2198 oberon_error(ctx
, "recursive record declaration");
2201 type
-> recursive
= 1;
2203 int num_fields
= type
-> num_decl
;
2204 oberon_object_t
* field
= type
-> decl
;
2205 for(int i
= 0; i
< num_fields
; i
++)
2207 oberon_prevent_recursive_object(ctx
, field
);
2208 field
= field
-> next
;
2211 type
-> recursive
= 0;
2214 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2216 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2221 if(type
-> recursive
)
2223 oberon_error(ctx
, "recursive procedure declaration");
2226 type
-> recursive
= 1;
2228 int num_fields
= type
-> num_decl
;
2229 oberon_object_t
* field
= type
-> decl
;
2230 for(int i
= 0; i
< num_fields
; i
++)
2232 oberon_prevent_recursive_object(ctx
, field
);
2233 field
= field
-> next
;
2236 type
-> recursive
= 0;
2240 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2242 if(type
-> class != OBERON_TYPE_ARRAY
)
2247 if(type
-> recursive
)
2249 oberon_error(ctx
, "recursive array declaration");
2252 type
-> recursive
= 1;
2254 oberon_prevent_recursive_type(ctx
, type
-> base
);
2256 type
-> recursive
= 0;
2260 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2262 if(type
-> class == OBERON_TYPE_POINTER
)
2264 oberon_prevent_recursive_pointer(ctx
, type
);
2266 else if(type
-> class == OBERON_TYPE_RECORD
)
2268 oberon_prevent_recursive_record(ctx
, type
);
2270 else if(type
-> class == OBERON_TYPE_ARRAY
)
2272 oberon_prevent_recursive_array(ctx
, type
);
2274 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2276 oberon_prevent_recursive_procedure(ctx
, type
);
2281 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2285 case OBERON_CLASS_VAR
:
2286 case OBERON_CLASS_TYPE
:
2287 case OBERON_CLASS_PARAM
:
2288 case OBERON_CLASS_VAR_PARAM
:
2289 case OBERON_CLASS_FIELD
:
2290 oberon_prevent_recursive_type(ctx
, x
-> type
);
2292 case OBERON_CLASS_CONST
:
2293 case OBERON_CLASS_PROC
:
2294 case OBERON_CLASS_MODULE
:
2297 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2303 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2305 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2309 oberon_prevent_recursive_object(ctx
, x
);
2314 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2315 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2318 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2320 if(type
-> class != OBERON_TYPE_RECORD
)
2325 int num_fields
= type
-> num_decl
;
2326 oberon_object_t
* field
= type
-> decl
;
2327 for(int i
= 0; i
< num_fields
; i
++)
2329 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2331 oberon_initialize_type(ctx
, field
-> type
);
2334 oberon_initialize_object(ctx
, field
);
2335 field
= field
-> next
;
2338 oberon_generator_init_record(ctx
, type
);
2342 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2344 if(type
-> class == OBERON_TYPE_VOID
)
2346 oberon_error(ctx
, "undeclarated type");
2349 if(type
-> initialized
)
2354 type
-> initialized
= 1;
2356 if(type
-> class == OBERON_TYPE_POINTER
)
2358 oberon_initialize_type(ctx
, type
-> base
);
2359 oberon_generator_init_type(ctx
, type
);
2361 else if(type
-> class == OBERON_TYPE_ARRAY
)
2363 oberon_initialize_type(ctx
, type
-> base
);
2364 oberon_generator_init_type(ctx
, type
);
2366 else if(type
-> class == OBERON_TYPE_RECORD
)
2368 oberon_generator_init_type(ctx
, type
);
2369 oberon_initialize_record_fields(ctx
, type
);
2371 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2373 int num_fields
= type
-> num_decl
;
2374 oberon_object_t
* field
= type
-> decl
;
2375 for(int i
= 0; i
< num_fields
; i
++)
2377 oberon_initialize_object(ctx
, field
);
2378 field
= field
-> next
;
2381 oberon_generator_init_type(ctx
, type
);
2385 oberon_generator_init_type(ctx
, type
);
2390 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2392 if(x
-> initialized
)
2397 x
-> initialized
= 1;
2401 case OBERON_CLASS_TYPE
:
2402 oberon_initialize_type(ctx
, x
-> type
);
2404 case OBERON_CLASS_VAR
:
2405 case OBERON_CLASS_PARAM
:
2406 case OBERON_CLASS_VAR_PARAM
:
2407 case OBERON_CLASS_FIELD
:
2408 oberon_initialize_type(ctx
, x
-> type
);
2409 oberon_generator_init_var(ctx
, x
);
2411 case OBERON_CLASS_CONST
:
2412 case OBERON_CLASS_PROC
:
2413 case OBERON_CLASS_MODULE
:
2416 oberon_error(ctx
, "oberon_initialize_object: wat");
2422 oberon_initialize_decl(oberon_context_t
* ctx
)
2424 oberon_object_t
* x
= ctx
-> decl
-> list
;
2428 oberon_initialize_object(ctx
, x
-> next
);
2434 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2436 oberon_object_t
* x
= ctx
-> decl
-> list
;
2440 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2442 if(x
-> next
-> linked
== 0)
2444 oberon_error(ctx
, "unresolved forward declaration");
2452 oberon_decl_seq(oberon_context_t
* ctx
)
2454 if(ctx
-> token
== CONST
)
2456 oberon_assert_token(ctx
, CONST
);
2457 while(ctx
-> token
== IDENT
)
2459 oberon_const_decl(ctx
);
2460 oberon_assert_token(ctx
, SEMICOLON
);
2464 if(ctx
-> token
== TYPE
)
2466 oberon_assert_token(ctx
, TYPE
);
2467 while(ctx
-> token
== IDENT
)
2469 oberon_type_decl(ctx
);
2470 oberon_assert_token(ctx
, SEMICOLON
);
2474 if(ctx
-> token
== VAR
)
2476 oberon_assert_token(ctx
, VAR
);
2477 while(ctx
-> token
== IDENT
)
2479 oberon_var_decl(ctx
);
2480 oberon_assert_token(ctx
, SEMICOLON
);
2484 oberon_prevent_recursive_decl(ctx
);
2485 oberon_initialize_decl(ctx
);
2487 while(ctx
-> token
== PROCEDURE
)
2489 oberon_proc_decl(ctx
);
2490 oberon_assert_token(ctx
, SEMICOLON
);
2493 oberon_prevent_undeclarated_procedures(ctx
);
2497 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2499 if(dst
-> read_only
)
2501 oberon_error(ctx
, "read-only destination");
2504 oberon_autocast_to(ctx
, src
, dst
-> result
);
2505 oberon_generate_assign(ctx
, src
, dst
);
2509 oberon_statement(oberon_context_t
* ctx
)
2511 oberon_expr_t
* item1
;
2512 oberon_expr_t
* item2
;
2514 if(ctx
-> token
== IDENT
)
2516 item1
= oberon_designator(ctx
);
2517 if(ctx
-> token
== ASSIGN
)
2519 oberon_assert_token(ctx
, ASSIGN
);
2520 item2
= oberon_expr(ctx
);
2521 oberon_assign(ctx
, item2
, item1
);
2525 oberon_opt_proc_parens(ctx
, item1
);
2528 else if(ctx
-> token
== RETURN
)
2530 oberon_assert_token(ctx
, RETURN
);
2531 if(ISEXPR(ctx
-> token
))
2533 oberon_expr_t
* expr
;
2534 expr
= oberon_expr(ctx
);
2535 oberon_make_return(ctx
, expr
);
2539 oberon_make_return(ctx
, NULL
);
2545 oberon_statement_seq(oberon_context_t
* ctx
)
2547 oberon_statement(ctx
);
2548 while(ctx
-> token
== SEMICOLON
)
2550 oberon_assert_token(ctx
, SEMICOLON
);
2551 oberon_statement(ctx
);
2556 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2558 oberon_module_t
* m
= ctx
-> module_list
;
2559 while(m
&& strcmp(m
-> name
, name
) != 0)
2567 code
= ctx
-> import_module(name
);
2570 oberon_error(ctx
, "no such module");
2573 m
= oberon_compile_module(ctx
, code
);
2579 oberon_error(ctx
, "cyclic module import");
2582 oberon_object_t
* ident
;
2583 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, 0, 0);
2584 ident
-> module
= m
;
2588 oberon_import_decl(oberon_context_t
* ctx
)
2593 alias
= name
= oberon_assert_ident(ctx
);
2594 if(ctx
-> token
== ASSIGN
)
2596 oberon_assert_token(ctx
, ASSIGN
);
2597 name
= oberon_assert_ident(ctx
);
2600 oberon_import_module(ctx
, alias
, name
);
2604 oberon_import_list(oberon_context_t
* ctx
)
2606 oberon_assert_token(ctx
, IMPORT
);
2608 oberon_import_decl(ctx
);
2609 while(ctx
-> token
== COMMA
)
2611 oberon_assert_token(ctx
, COMMA
);
2612 oberon_import_decl(ctx
);
2615 oberon_assert_token(ctx
, SEMICOLON
);
2619 oberon_parse_module(oberon_context_t
* ctx
)
2623 oberon_read_token(ctx
);
2625 oberon_assert_token(ctx
, MODULE
);
2626 name1
= oberon_assert_ident(ctx
);
2627 oberon_assert_token(ctx
, SEMICOLON
);
2628 ctx
-> mod
-> name
= name1
;
2630 if(ctx
-> token
== IMPORT
)
2632 oberon_import_list(ctx
);
2635 oberon_decl_seq(ctx
);
2637 oberon_generate_begin_module(ctx
);
2638 if(ctx
-> token
== BEGIN
)
2640 oberon_assert_token(ctx
, BEGIN
);
2641 oberon_statement_seq(ctx
);
2643 oberon_generate_end_module(ctx
);
2645 oberon_assert_token(ctx
, END
);
2646 name2
= oberon_assert_ident(ctx
);
2647 oberon_assert_token(ctx
, DOT
);
2649 if(strcmp(name1
, name2
) != 0)
2651 oberon_error(ctx
, "module name not matched");
2655 // =======================================================================
2657 // =======================================================================
2660 register_default_types(oberon_context_t
* ctx
)
2662 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2663 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2665 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2666 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2667 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2669 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
2670 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1);
2672 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(bool));
2673 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1);
2675 ctx
-> real_type
= oberon_new_type_real(sizeof(float));
2676 oberon_define_type(ctx
-> world_scope
, "REAL", ctx
-> real_type
, 1);
2680 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2682 oberon_object_t
* proc
;
2683 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, 1, 0);
2684 proc
-> sysproc
= 1;
2685 proc
-> genfunc
= f
;
2686 proc
-> genproc
= p
;
2687 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2690 static oberon_expr_t
*
2691 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2695 oberon_error(ctx
, "too few arguments");
2700 oberon_error(ctx
, "too mach arguments");
2703 oberon_expr_t
* arg
;
2706 oberon_type_t
* result_type
;
2707 result_type
= arg
-> result
;
2709 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2711 oberon_error(ctx
, "ABS accepts only integers");
2715 oberon_expr_t
* expr
;
2716 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2721 oberon_make_new_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2725 oberon_error(ctx
, "too few arguments");
2730 oberon_error(ctx
, "too mach arguments");
2733 oberon_expr_t
* dst
;
2736 oberon_type_t
* type
;
2737 type
= dst
-> result
;
2739 if(type
-> class != OBERON_TYPE_POINTER
)
2741 oberon_error(ctx
, "not a pointer");
2744 type
= type
-> base
;
2746 oberon_expr_t
* src
;
2747 src
= oberon_new_item(MODE_NEW
, dst
-> result
, 0);
2748 src
-> item
.num_args
= 0;
2749 src
-> item
.args
= NULL
;
2751 if(type
-> class == OBERON_TYPE_ARRAY
)
2753 // Пригодится при работе с открытыми массивами
2756 oberon_expr_t * sizes = NULL;
2757 oberon_expr_t * last_size = NULL;
2758 sizes = last_size = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
2759 sizes -> item.integer = type -> size;
2760 oberon_type_t * base = type -> base;
2761 while(base -> class == OBERON_TYPE_ARRAY)
2763 oberon_expr_t * size;
2764 size = last_size = oberon_new_item(MODE_INTEGER, ctx -> int_type, 1);
2765 size -> item.integer = base -> size;
2767 last_size -> next = size;
2769 base = base -> base;
2774 src
-> item
.num_args
= 0;
2775 src
-> item
.args
= NULL
;
2777 else if(type
-> class != OBERON_TYPE_RECORD
)
2779 oberon_error(ctx
, "oberon_make_new_call: wat");
2782 oberon_assign(ctx
, src
, dst
);
2786 oberon_create_context(ModuleImportCallback import_module
)
2788 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2790 oberon_scope_t
* world_scope
;
2791 world_scope
= oberon_open_scope(ctx
);
2792 ctx
-> world_scope
= world_scope
;
2794 ctx
-> import_module
= import_module
;
2796 oberon_generator_init_context(ctx
);
2798 register_default_types(ctx
);
2799 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2800 oberon_new_intrinsic(ctx
, "NEW", NULL
, oberon_make_new_call
);
2806 oberon_destroy_context(oberon_context_t
* ctx
)
2808 oberon_generator_destroy_context(ctx
);
2813 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2815 const char * code
= ctx
-> code
;
2816 int code_index
= ctx
-> code_index
;
2818 int token
= ctx
-> token
;
2819 char * string
= ctx
-> string
;
2820 int integer
= ctx
-> integer
;
2821 oberon_scope_t
* decl
= ctx
-> decl
;
2822 oberon_module_t
* mod
= ctx
-> mod
;
2824 oberon_scope_t
* module_scope
;
2825 module_scope
= oberon_open_scope(ctx
);
2827 oberon_module_t
* module
;
2828 module
= calloc(1, sizeof *module
);
2829 module
-> decl
= module_scope
;
2830 module
-> next
= ctx
-> module_list
;
2832 ctx
-> mod
= module
;
2833 ctx
-> module_list
= module
;
2835 oberon_init_scaner(ctx
, newcode
);
2836 oberon_parse_module(ctx
);
2838 module
-> ready
= 1;
2841 ctx
-> code_index
= code_index
;
2843 ctx
-> token
= token
;
2844 ctx
-> string
= string
;
2845 ctx
-> integer
= integer
;