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(desig
-> result
-> size
!= 0)
1029 if(index
-> is_item
)
1031 if(index
-> item
.mode
== MODE_INTEGER
)
1033 int arr_size
= desig
-> result
-> size
;
1034 int index_int
= index
-> item
.integer
;
1035 if(index_int
< 0 || index_int
> arr_size
- 1)
1037 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
1043 oberon_expr_t
* selector
;
1044 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
1045 selector
-> item
.parent
= (oberon_item_t
*) desig
;
1046 selector
-> item
.num_args
= 1;
1047 selector
-> item
.args
= index
;
1052 static oberon_expr_t
*
1053 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
1055 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
1057 expr
= oberno_make_dereferencing(ctx
, expr
);
1060 assert(expr
-> is_item
== 1);
1062 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
1064 oberon_error(ctx
, "not record");
1067 oberon_type_t
* rec
= expr
-> result
;
1069 oberon_object_t
* field
;
1070 field
= oberon_find_field(ctx
, rec
, name
);
1072 if(field
-> export
== 0)
1074 if(field
-> module
!= ctx
-> mod
)
1076 oberon_error(ctx
, "field not exported");
1081 if(field
-> read_only
)
1083 if(field
-> module
!= ctx
-> mod
)
1089 oberon_expr_t
* selector
;
1090 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
1091 selector
-> item
.var
= field
;
1092 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1097 #define ISSELECTOR(x) \
1100 || ((x) == UPARROW))
1102 static oberon_object_t
*
1103 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
1106 oberon_object_t
* x
;
1108 name
= oberon_assert_ident(ctx
);
1109 x
= oberon_find_object(ctx
-> decl
, name
, check
);
1113 if(x
-> class == OBERON_CLASS_MODULE
)
1115 oberon_assert_token(ctx
, DOT
);
1116 name
= oberon_assert_ident(ctx
);
1117 /* Наличие объектов в левых модулях всегда проверяется */
1118 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1120 if(x
-> export
== 0)
1122 oberon_error(ctx
, "not exported");
1135 static oberon_expr_t
*
1136 oberon_designator(oberon_context_t
* ctx
)
1139 oberon_object_t
* var
;
1140 oberon_expr_t
* expr
;
1142 var
= oberon_qualident(ctx
, NULL
, 1);
1145 if(var
-> read_only
)
1147 if(var
-> module
!= ctx
-> mod
)
1153 switch(var
-> class)
1155 case OBERON_CLASS_CONST
:
1157 expr
= (oberon_expr_t
*) var
-> value
;
1159 case OBERON_CLASS_VAR
:
1160 case OBERON_CLASS_VAR_PARAM
:
1161 case OBERON_CLASS_PARAM
:
1162 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
1164 case OBERON_CLASS_PROC
:
1165 expr
= oberon_new_item(MODE_VAR
, var
-> type
, 1);
1168 oberon_error(ctx
, "invalid designator");
1171 expr
-> item
.var
= var
;
1173 while(ISSELECTOR(ctx
-> token
))
1175 switch(ctx
-> token
)
1178 oberon_assert_token(ctx
, DOT
);
1179 name
= oberon_assert_ident(ctx
);
1180 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1183 oberon_assert_token(ctx
, LBRACE
);
1184 int num_indexes
= 0;
1185 oberon_expr_t
* indexes
= NULL
;
1186 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1187 oberon_assert_token(ctx
, RBRACE
);
1189 for(int i
= 0; i
< num_indexes
; i
++)
1191 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1192 indexes
= indexes
-> next
;
1196 oberon_assert_token(ctx
, UPARROW
);
1197 expr
= oberno_make_dereferencing(ctx
, expr
);
1200 oberon_error(ctx
, "oberon_designator: wat");
1207 static oberon_expr_t
*
1208 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1210 assert(expr
-> is_item
== 1);
1212 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1213 if(ctx
-> token
== LPAREN
)
1215 oberon_assert_token(ctx
, LPAREN
);
1218 oberon_expr_t
* arguments
= NULL
;
1220 if(ISEXPR(ctx
-> token
))
1222 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1225 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1227 oberon_assert_token(ctx
, RPAREN
);
1234 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1236 assert(expr
-> is_item
== 1);
1239 oberon_expr_t
* arguments
= NULL
;
1241 if(ctx
-> token
== LPAREN
)
1243 oberon_assert_token(ctx
, LPAREN
);
1245 if(ISEXPR(ctx
-> token
))
1247 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1250 oberon_assert_token(ctx
, RPAREN
);
1253 /* Вызов происходит даже без скобок */
1254 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1257 static oberon_expr_t
*
1258 oberon_factor(oberon_context_t
* ctx
)
1260 oberon_expr_t
* expr
;
1262 switch(ctx
-> token
)
1265 expr
= oberon_designator(ctx
);
1266 expr
= oberon_opt_func_parens(ctx
, expr
);
1269 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
, 1);
1270 expr
-> item
.integer
= ctx
-> integer
;
1271 oberon_assert_token(ctx
, INTEGER
);
1274 expr
= oberon_new_item(MODE_REAL
, ctx
-> real_type
, 1);
1275 expr
-> item
.real
= ctx
-> real
;
1276 oberon_assert_token(ctx
, REAL
);
1279 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1280 expr
-> item
.boolean
= 1;
1281 oberon_assert_token(ctx
, TRUE
);
1284 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1285 expr
-> item
.boolean
= 0;
1286 oberon_assert_token(ctx
, FALSE
);
1289 oberon_assert_token(ctx
, LPAREN
);
1290 expr
= oberon_expr(ctx
);
1291 oberon_assert_token(ctx
, RPAREN
);
1294 oberon_assert_token(ctx
, NOT
);
1295 expr
= oberon_factor(ctx
);
1296 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1299 oberon_assert_token(ctx
, NIL
);
1300 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
, 1);
1303 oberon_error(ctx
, "invalid expression");
1310 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1311 * 1. Классы обоих типов должны быть одинаковы
1312 * 2. В качестве результата должен быть выбран больший тип.
1313 * 3. Если размер результат не должен быть меньше чем базовый int
1317 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
1319 if((a
-> class) != (b
-> class))
1321 oberon_error(ctx
, "incompatible types");
1324 if((a
-> size
) > (b
-> size
))
1333 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
1335 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
1337 *result
= ctx
-> int_type
;
1341 /* TODO: cast types */
1344 #define ITMAKESBOOLEAN(x) \
1345 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1347 #define ITUSEONLYINTEGER(x) \
1348 ((x) >= LESS && (x) <= GEQ)
1350 #define ITUSEONLYBOOLEAN(x) \
1351 (((x) == OR) || ((x) == AND))
1353 static oberon_expr_t
*
1354 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1356 oberon_expr_t
* expr
;
1357 oberon_type_t
* result
;
1359 if(ITMAKESBOOLEAN(token
))
1361 if(ITUSEONLYINTEGER(token
))
1363 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1364 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1366 oberon_error(ctx
, "used only with integer types");
1369 else if(ITUSEONLYBOOLEAN(token
))
1371 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1372 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1374 oberon_error(ctx
, "used only with boolean type");
1378 result
= ctx
-> bool_type
;
1382 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1384 else if(token
== NEQ
)
1386 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1388 else if(token
== LESS
)
1390 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1392 else if(token
== LEQ
)
1394 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1396 else if(token
== GREAT
)
1398 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1400 else if(token
== GEQ
)
1402 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1404 else if(token
== OR
)
1406 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1408 else if(token
== AND
)
1410 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1414 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1417 else if(token
== SLASH
)
1419 if(a
-> result
-> class != OBERON_TYPE_REAL
)
1421 if(a
-> result
-> class == OBERON_TYPE_INTEGER
)
1423 oberon_error(ctx
, "TODO cast int -> real");
1427 oberon_error(ctx
, "operator / requires numeric type");
1431 if(b
-> result
-> class != OBERON_TYPE_REAL
)
1433 if(b
-> result
-> class == OBERON_TYPE_INTEGER
)
1435 oberon_error(ctx
, "TODO cast int -> real");
1439 oberon_error(ctx
, "operator / requires numeric type");
1443 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1444 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1446 else if(token
== DIV
)
1448 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1449 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1451 oberon_error(ctx
, "operator DIV requires integer type");
1454 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1455 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1459 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1463 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1465 else if(token
== MINUS
)
1467 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1469 else if(token
== STAR
)
1471 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1473 else if(token
== MOD
)
1475 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1479 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1486 #define ISMULOP(x) \
1487 ((x) >= STAR && (x) <= AND)
1489 static oberon_expr_t
*
1490 oberon_term_expr(oberon_context_t
* ctx
)
1492 oberon_expr_t
* expr
;
1494 expr
= oberon_factor(ctx
);
1495 while(ISMULOP(ctx
-> token
))
1497 int token
= ctx
-> token
;
1498 oberon_read_token(ctx
);
1500 oberon_expr_t
* inter
= oberon_factor(ctx
);
1501 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1507 #define ISADDOP(x) \
1508 ((x) >= PLUS && (x) <= OR)
1510 static oberon_expr_t
*
1511 oberon_simple_expr(oberon_context_t
* ctx
)
1513 oberon_expr_t
* expr
;
1516 if(ctx
-> token
== PLUS
)
1519 oberon_assert_token(ctx
, PLUS
);
1521 else if(ctx
-> token
== MINUS
)
1524 oberon_assert_token(ctx
, MINUS
);
1527 expr
= oberon_term_expr(ctx
);
1528 while(ISADDOP(ctx
-> token
))
1530 int token
= ctx
-> token
;
1531 oberon_read_token(ctx
);
1533 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1534 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1539 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1545 #define ISRELATION(x) \
1546 ((x) >= EQUAL && (x) <= GEQ)
1548 static oberon_expr_t
*
1549 oberon_expr(oberon_context_t
* ctx
)
1551 oberon_expr_t
* expr
;
1553 expr
= oberon_simple_expr(ctx
);
1554 while(ISRELATION(ctx
-> token
))
1556 int token
= ctx
-> token
;
1557 oberon_read_token(ctx
);
1559 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1560 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1566 static oberon_item_t
*
1567 oberon_const_expr(oberon_context_t
* ctx
)
1569 oberon_expr_t
* expr
;
1570 expr
= oberon_expr(ctx
);
1572 if(expr
-> is_item
== 0)
1574 oberon_error(ctx
, "const expression are required");
1577 return (oberon_item_t
*) expr
;
1580 // =======================================================================
1582 // =======================================================================
1584 static void oberon_decl_seq(oberon_context_t
* ctx
);
1585 static void oberon_statement_seq(oberon_context_t
* ctx
);
1586 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1589 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1591 if(ctx
-> token
!= token
)
1593 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1598 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1600 oberon_expect_token(ctx
, token
);
1601 oberon_read_token(ctx
);
1605 oberon_assert_ident(oberon_context_t
* ctx
)
1607 oberon_expect_token(ctx
, IDENT
);
1608 char * ident
= ctx
-> string
;
1609 oberon_read_token(ctx
);
1614 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1616 switch(ctx
-> token
)
1619 oberon_assert_token(ctx
, STAR
);
1624 oberon_assert_token(ctx
, MINUS
);
1635 static oberon_object_t
*
1636 oberon_ident_def(oberon_context_t
* ctx
, int class)
1641 oberon_object_t
* x
;
1643 name
= oberon_assert_ident(ctx
);
1644 oberon_def(ctx
, &export
, &read_only
);
1646 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
);
1651 oberon_ident_list(oberon_context_t
* ctx
, int class, int * num
, oberon_object_t
** list
)
1654 *list
= oberon_ident_def(ctx
, class);
1655 while(ctx
-> token
== COMMA
)
1657 oberon_assert_token(ctx
, COMMA
);
1658 oberon_ident_def(ctx
, class);
1664 oberon_var_decl(oberon_context_t
* ctx
)
1667 oberon_object_t
* list
;
1668 oberon_type_t
* type
;
1669 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1671 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, &num
, &list
);
1672 oberon_assert_token(ctx
, COLON
);
1673 oberon_type(ctx
, &type
);
1675 oberon_object_t
* var
= list
;
1676 for(int i
= 0; i
< num
; i
++)
1683 static oberon_object_t
*
1684 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1686 int class = OBERON_CLASS_PARAM
;
1687 if(ctx
-> token
== VAR
)
1689 oberon_read_token(ctx
);
1690 class = OBERON_CLASS_VAR_PARAM
;
1694 oberon_object_t
* list
;
1695 oberon_ident_list(ctx
, class, &num
, &list
);
1697 oberon_assert_token(ctx
, COLON
);
1699 oberon_type_t
* type
;
1700 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1701 oberon_type(ctx
, &type
);
1703 oberon_object_t
* param
= list
;
1704 for(int i
= 0; i
< num
; i
++)
1706 param
-> type
= type
;
1707 param
= param
-> next
;
1714 #define ISFPSECTION \
1715 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1718 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1720 oberon_assert_token(ctx
, LPAREN
);
1724 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1725 while(ctx
-> token
== SEMICOLON
)
1727 oberon_assert_token(ctx
, SEMICOLON
);
1728 oberon_fp_section(ctx
, &signature
-> num_decl
);
1732 oberon_assert_token(ctx
, RPAREN
);
1734 if(ctx
-> token
== COLON
)
1736 oberon_assert_token(ctx
, COLON
);
1738 oberon_object_t
* typeobj
;
1739 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1740 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1742 oberon_error(ctx
, "function result is not type");
1744 signature
-> base
= typeobj
-> type
;
1749 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1751 oberon_type_t
* signature
;
1753 signature
-> class = OBERON_TYPE_PROCEDURE
;
1754 signature
-> num_decl
= 0;
1755 signature
-> base
= ctx
-> void_type
;
1756 signature
-> decl
= NULL
;
1758 if(ctx
-> token
== LPAREN
)
1760 oberon_formal_pars(ctx
, signature
);
1765 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1767 if(a
-> num_decl
!= b
-> num_decl
)
1769 oberon_error(ctx
, "number parameters not matched");
1772 int num_param
= a
-> num_decl
;
1773 oberon_object_t
* param_a
= a
-> decl
;
1774 oberon_object_t
* param_b
= b
-> decl
;
1775 for(int i
= 0; i
< num_param
; i
++)
1777 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1779 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1782 if(param_a
-> type
!= param_b
-> type
)
1784 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1787 param_a
= param_a
-> next
;
1788 param_b
= param_b
-> next
;
1793 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1795 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1796 oberon_type_t
* result_type
= proc
-> type
-> base
;
1798 if(result_type
-> class == OBERON_TYPE_VOID
)
1802 oberon_error(ctx
, "procedure has no result type");
1809 oberon_error(ctx
, "procedure requires expression on result");
1812 oberon_autocast_to(ctx
, expr
, result_type
);
1815 proc
-> has_return
= 1;
1817 oberon_generate_return(ctx
, expr
);
1821 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1823 oberon_assert_token(ctx
, SEMICOLON
);
1825 ctx
-> decl
= proc
-> scope
;
1827 oberon_decl_seq(ctx
);
1829 oberon_generate_begin_proc(ctx
, proc
);
1831 if(ctx
-> token
== BEGIN
)
1833 oberon_assert_token(ctx
, BEGIN
);
1834 oberon_statement_seq(ctx
);
1837 oberon_assert_token(ctx
, END
);
1838 char * name
= oberon_assert_ident(ctx
);
1839 if(strcmp(name
, proc
-> name
) != 0)
1841 oberon_error(ctx
, "procedure name not matched");
1844 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1845 && proc
-> has_return
== 0)
1847 oberon_make_return(ctx
, NULL
);
1850 if(proc
-> has_return
== 0)
1852 oberon_error(ctx
, "procedure requires return");
1855 oberon_generate_end_proc(ctx
);
1856 oberon_close_scope(ctx
-> decl
);
1860 oberon_proc_decl(oberon_context_t
* ctx
)
1862 oberon_assert_token(ctx
, PROCEDURE
);
1865 if(ctx
-> token
== UPARROW
)
1867 oberon_assert_token(ctx
, UPARROW
);
1874 name
= oberon_assert_ident(ctx
);
1875 oberon_def(ctx
, &export
, &read_only
);
1877 oberon_scope_t
* proc_scope
;
1878 proc_scope
= oberon_open_scope(ctx
);
1879 ctx
-> decl
-> local
= 1;
1881 oberon_type_t
* signature
;
1882 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1883 oberon_opt_formal_pars(ctx
, &signature
);
1885 oberon_initialize_decl(ctx
);
1886 oberon_generator_init_type(ctx
, signature
);
1887 oberon_close_scope(ctx
-> decl
);
1889 oberon_object_t
* proc
;
1890 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1893 if(proc
-> class != OBERON_CLASS_PROC
)
1895 oberon_error(ctx
, "mult definition");
1902 oberon_error(ctx
, "mult procedure definition");
1906 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
1908 oberon_error(ctx
, "export type not matched");
1911 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1915 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
);
1916 proc
-> type
= signature
;
1917 proc
-> scope
= proc_scope
;
1918 oberon_generator_init_proc(ctx
, proc
);
1921 proc
-> scope
-> parent
= proc
;
1926 oberon_proc_decl_body(ctx
, proc
);
1931 oberon_const_decl(oberon_context_t
* ctx
)
1933 oberon_item_t
* value
;
1934 oberon_object_t
* constant
;
1936 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
);
1937 oberon_assert_token(ctx
, EQUAL
);
1938 value
= oberon_const_expr(ctx
);
1939 constant
-> value
= value
;
1943 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
1945 if(size
-> is_item
== 0)
1947 oberon_error(ctx
, "requires constant");
1950 if(size
-> item
.mode
!= MODE_INTEGER
)
1952 oberon_error(ctx
, "requires integer constant");
1955 oberon_type_t
* arr
;
1957 arr
-> class = OBERON_TYPE_ARRAY
;
1958 arr
-> size
= size
-> item
.integer
;
1963 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1965 if(ctx
-> token
== IDENT
)
1968 oberon_object_t
* list
;
1969 oberon_type_t
* type
;
1970 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1972 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, &num
, &list
);
1973 oberon_assert_token(ctx
, COLON
);
1974 oberon_type(ctx
, &type
);
1976 oberon_object_t
* field
= list
;
1977 for(int i
= 0; i
< num
; i
++)
1979 field
-> type
= type
;
1980 field
= field
-> next
;
1983 rec
-> num_decl
+= num
;
1988 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1991 oberon_object_t
* to
;
1993 to
= oberon_qualident(ctx
, &name
, 0);
1995 //name = oberon_assert_ident(ctx);
1996 //to = oberon_find_object(ctx -> decl, name, 0);
2000 if(to
-> class != OBERON_CLASS_TYPE
)
2002 oberon_error(ctx
, "not a type");
2007 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, 0, 0);
2008 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2014 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
2017 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2021 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
2029 oberon_type_t
* dim
;
2030 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2032 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
2034 oberon_make_array_type(ctx
, sizes
, dim
, type
);
2038 oberon_make_open_array(oberon_context_t
* ctx
, oberon_type_t
* base
, oberon_type_t
* type
)
2040 type
-> class = OBERON_TYPE_ARRAY
;
2042 type
-> base
= base
;
2046 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2048 if(ctx
-> token
== IDENT
)
2050 oberon_qualident_type(ctx
, type
);
2052 else if(ctx
-> token
== ARRAY
)
2054 oberon_assert_token(ctx
, ARRAY
);
2057 oberon_expr_t
* sizes
;
2059 if(ISEXPR(ctx
-> token
))
2061 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
2064 oberon_assert_token(ctx
, OF
);
2066 oberon_type_t
* base
;
2067 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2068 oberon_type(ctx
, &base
);
2072 oberon_make_open_array(ctx
, base
, *type
);
2076 oberon_make_multiarray(ctx
, sizes
, base
, type
);
2079 else if(ctx
-> token
== RECORD
)
2081 oberon_type_t
* rec
;
2083 rec
-> class = OBERON_TYPE_RECORD
;
2085 oberon_scope_t
* record_scope
;
2086 record_scope
= oberon_open_scope(ctx
);
2087 // TODO parent object
2088 //record_scope -> parent = NULL;
2089 record_scope
-> local
= 1;
2091 oberon_assert_token(ctx
, RECORD
);
2092 oberon_field_list(ctx
, rec
);
2093 while(ctx
-> token
== SEMICOLON
)
2095 oberon_assert_token(ctx
, SEMICOLON
);
2096 oberon_field_list(ctx
, rec
);
2098 oberon_assert_token(ctx
, END
);
2100 rec
-> decl
= record_scope
-> list
-> next
;
2101 oberon_close_scope(record_scope
);
2105 else if(ctx
-> token
== POINTER
)
2107 oberon_assert_token(ctx
, POINTER
);
2108 oberon_assert_token(ctx
, TO
);
2110 oberon_type_t
* base
;
2111 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2112 oberon_type(ctx
, &base
);
2114 oberon_type_t
* ptr
;
2116 ptr
-> class = OBERON_TYPE_POINTER
;
2119 else if(ctx
-> token
== PROCEDURE
)
2121 oberon_open_scope(ctx
);
2122 oberon_assert_token(ctx
, PROCEDURE
);
2123 oberon_opt_formal_pars(ctx
, type
);
2124 oberon_close_scope(ctx
-> decl
);
2128 oberon_error(ctx
, "invalid type declaration");
2133 oberon_type_decl(oberon_context_t
* ctx
)
2136 oberon_object_t
* newtype
;
2137 oberon_type_t
* type
;
2141 name
= oberon_assert_ident(ctx
);
2142 oberon_def(ctx
, &export
, &read_only
);
2144 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
2147 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
2148 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2149 assert(newtype
-> type
);
2153 if(newtype
-> class != OBERON_CLASS_TYPE
)
2155 oberon_error(ctx
, "mult definition");
2158 if(newtype
-> linked
)
2160 oberon_error(ctx
, "mult definition - already linked");
2163 newtype
-> export
= export
;
2164 newtype
-> read_only
= read_only
;
2167 oberon_assert_token(ctx
, EQUAL
);
2169 type
= newtype
-> type
;
2170 oberon_type(ctx
, &type
);
2172 if(type
-> class == OBERON_TYPE_VOID
)
2174 oberon_error(ctx
, "recursive alias declaration");
2177 newtype
-> type
= type
;
2178 newtype
-> linked
= 1;
2181 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2182 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2185 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
2187 if(type
-> class != OBERON_TYPE_POINTER
2188 && type
-> class != OBERON_TYPE_ARRAY
)
2193 if(type
-> recursive
)
2195 oberon_error(ctx
, "recursive pointer declaration");
2198 if(type
-> base
-> class == OBERON_TYPE_POINTER
)
2200 oberon_error(ctx
, "attempt to make pointer to pointer");
2203 type
-> recursive
= 1;
2205 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
2207 type
-> recursive
= 0;
2211 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
2213 if(type
-> class != OBERON_TYPE_RECORD
)
2218 if(type
-> recursive
)
2220 oberon_error(ctx
, "recursive record declaration");
2223 type
-> recursive
= 1;
2225 int num_fields
= type
-> num_decl
;
2226 oberon_object_t
* field
= type
-> decl
;
2227 for(int i
= 0; i
< num_fields
; i
++)
2229 oberon_prevent_recursive_object(ctx
, field
);
2230 field
= field
-> next
;
2233 type
-> recursive
= 0;
2236 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2238 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2243 if(type
-> recursive
)
2245 oberon_error(ctx
, "recursive procedure declaration");
2248 type
-> recursive
= 1;
2250 int num_fields
= type
-> num_decl
;
2251 oberon_object_t
* field
= type
-> decl
;
2252 for(int i
= 0; i
< num_fields
; i
++)
2254 oberon_prevent_recursive_object(ctx
, field
);
2255 field
= field
-> next
;
2258 type
-> recursive
= 0;
2262 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2264 if(type
-> class != OBERON_TYPE_ARRAY
)
2269 if(type
-> recursive
)
2271 oberon_error(ctx
, "recursive array declaration");
2274 type
-> recursive
= 1;
2276 oberon_prevent_recursive_type(ctx
, type
-> base
);
2278 type
-> recursive
= 0;
2282 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2284 if(type
-> class == OBERON_TYPE_POINTER
)
2286 oberon_prevent_recursive_pointer(ctx
, type
);
2288 else if(type
-> class == OBERON_TYPE_RECORD
)
2290 oberon_prevent_recursive_record(ctx
, type
);
2292 else if(type
-> class == OBERON_TYPE_ARRAY
)
2294 oberon_prevent_recursive_array(ctx
, type
);
2296 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2298 oberon_prevent_recursive_procedure(ctx
, type
);
2303 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2307 case OBERON_CLASS_VAR
:
2308 case OBERON_CLASS_TYPE
:
2309 case OBERON_CLASS_PARAM
:
2310 case OBERON_CLASS_VAR_PARAM
:
2311 case OBERON_CLASS_FIELD
:
2312 oberon_prevent_recursive_type(ctx
, x
-> type
);
2314 case OBERON_CLASS_CONST
:
2315 case OBERON_CLASS_PROC
:
2316 case OBERON_CLASS_MODULE
:
2319 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2325 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2327 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2331 oberon_prevent_recursive_object(ctx
, x
);
2336 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2337 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2340 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2342 if(type
-> class != OBERON_TYPE_RECORD
)
2347 int num_fields
= type
-> num_decl
;
2348 oberon_object_t
* field
= type
-> decl
;
2349 for(int i
= 0; i
< num_fields
; i
++)
2351 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2353 oberon_initialize_type(ctx
, field
-> type
);
2356 oberon_initialize_object(ctx
, field
);
2357 field
= field
-> next
;
2360 oberon_generator_init_record(ctx
, type
);
2364 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2366 if(type
-> class == OBERON_TYPE_VOID
)
2368 oberon_error(ctx
, "undeclarated type");
2371 if(type
-> initialized
)
2376 type
-> initialized
= 1;
2378 if(type
-> class == OBERON_TYPE_POINTER
)
2380 oberon_initialize_type(ctx
, type
-> base
);
2381 oberon_generator_init_type(ctx
, type
);
2383 else if(type
-> class == OBERON_TYPE_ARRAY
)
2385 if(type
-> size
!= 0)
2387 if(type
-> base
-> class == OBERON_TYPE_ARRAY
)
2389 if(type
-> base
-> size
== 0)
2391 oberon_error(ctx
, "open array not allowed as array element");
2396 oberon_initialize_type(ctx
, type
-> base
);
2397 oberon_generator_init_type(ctx
, type
);
2399 else if(type
-> class == OBERON_TYPE_RECORD
)
2401 oberon_generator_init_type(ctx
, type
);
2402 oberon_initialize_record_fields(ctx
, type
);
2404 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2406 int num_fields
= type
-> num_decl
;
2407 oberon_object_t
* field
= type
-> decl
;
2408 for(int i
= 0; i
< num_fields
; i
++)
2410 oberon_initialize_object(ctx
, field
);
2411 field
= field
-> next
;
2414 oberon_generator_init_type(ctx
, type
);
2418 oberon_generator_init_type(ctx
, type
);
2423 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2425 if(x
-> initialized
)
2430 x
-> initialized
= 1;
2434 case OBERON_CLASS_TYPE
:
2435 oberon_initialize_type(ctx
, x
-> type
);
2437 case OBERON_CLASS_VAR
:
2438 case OBERON_CLASS_FIELD
:
2439 if(x
-> type
-> class == OBERON_TYPE_ARRAY
)
2441 if(x
-> type
-> size
== 0)
2443 oberon_error(ctx
, "open array not allowed as variable or field");
2446 oberon_initialize_type(ctx
, x
-> type
);
2447 oberon_generator_init_var(ctx
, x
);
2449 case OBERON_CLASS_PARAM
:
2450 case OBERON_CLASS_VAR_PARAM
:
2451 oberon_initialize_type(ctx
, x
-> type
);
2452 oberon_generator_init_var(ctx
, x
);
2454 case OBERON_CLASS_CONST
:
2455 case OBERON_CLASS_PROC
:
2456 case OBERON_CLASS_MODULE
:
2459 oberon_error(ctx
, "oberon_initialize_object: wat");
2465 oberon_initialize_decl(oberon_context_t
* ctx
)
2467 oberon_object_t
* x
= ctx
-> decl
-> list
;
2471 oberon_initialize_object(ctx
, x
-> next
);
2477 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2479 oberon_object_t
* x
= ctx
-> decl
-> list
;
2483 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2485 if(x
-> next
-> linked
== 0)
2487 oberon_error(ctx
, "unresolved forward declaration");
2495 oberon_decl_seq(oberon_context_t
* ctx
)
2497 if(ctx
-> token
== CONST
)
2499 oberon_assert_token(ctx
, CONST
);
2500 while(ctx
-> token
== IDENT
)
2502 oberon_const_decl(ctx
);
2503 oberon_assert_token(ctx
, SEMICOLON
);
2507 if(ctx
-> token
== TYPE
)
2509 oberon_assert_token(ctx
, TYPE
);
2510 while(ctx
-> token
== IDENT
)
2512 oberon_type_decl(ctx
);
2513 oberon_assert_token(ctx
, SEMICOLON
);
2517 if(ctx
-> token
== VAR
)
2519 oberon_assert_token(ctx
, VAR
);
2520 while(ctx
-> token
== IDENT
)
2522 oberon_var_decl(ctx
);
2523 oberon_assert_token(ctx
, SEMICOLON
);
2527 oberon_prevent_recursive_decl(ctx
);
2528 oberon_initialize_decl(ctx
);
2530 while(ctx
-> token
== PROCEDURE
)
2532 oberon_proc_decl(ctx
);
2533 oberon_assert_token(ctx
, SEMICOLON
);
2536 oberon_prevent_undeclarated_procedures(ctx
);
2540 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2542 if(dst
-> read_only
)
2544 oberon_error(ctx
, "read-only destination");
2547 oberon_autocast_to(ctx
, src
, dst
-> result
);
2548 oberon_generate_assign(ctx
, src
, dst
);
2552 oberon_statement(oberon_context_t
* ctx
)
2554 oberon_expr_t
* item1
;
2555 oberon_expr_t
* item2
;
2557 if(ctx
-> token
== IDENT
)
2559 item1
= oberon_designator(ctx
);
2560 if(ctx
-> token
== ASSIGN
)
2562 oberon_assert_token(ctx
, ASSIGN
);
2563 item2
= oberon_expr(ctx
);
2564 oberon_assign(ctx
, item2
, item1
);
2568 oberon_opt_proc_parens(ctx
, item1
);
2571 else if(ctx
-> token
== RETURN
)
2573 oberon_assert_token(ctx
, RETURN
);
2574 if(ISEXPR(ctx
-> token
))
2576 oberon_expr_t
* expr
;
2577 expr
= oberon_expr(ctx
);
2578 oberon_make_return(ctx
, expr
);
2582 oberon_make_return(ctx
, NULL
);
2588 oberon_statement_seq(oberon_context_t
* ctx
)
2590 oberon_statement(ctx
);
2591 while(ctx
-> token
== SEMICOLON
)
2593 oberon_assert_token(ctx
, SEMICOLON
);
2594 oberon_statement(ctx
);
2599 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2601 oberon_module_t
* m
= ctx
-> module_list
;
2602 while(m
&& strcmp(m
-> name
, name
) != 0)
2610 code
= ctx
-> import_module(name
);
2613 oberon_error(ctx
, "no such module");
2616 m
= oberon_compile_module(ctx
, code
);
2622 oberon_error(ctx
, "cyclic module import");
2625 oberon_object_t
* ident
;
2626 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, 0, 0);
2627 ident
-> module
= m
;
2631 oberon_import_decl(oberon_context_t
* ctx
)
2636 alias
= name
= oberon_assert_ident(ctx
);
2637 if(ctx
-> token
== ASSIGN
)
2639 oberon_assert_token(ctx
, ASSIGN
);
2640 name
= oberon_assert_ident(ctx
);
2643 oberon_import_module(ctx
, alias
, name
);
2647 oberon_import_list(oberon_context_t
* ctx
)
2649 oberon_assert_token(ctx
, IMPORT
);
2651 oberon_import_decl(ctx
);
2652 while(ctx
-> token
== COMMA
)
2654 oberon_assert_token(ctx
, COMMA
);
2655 oberon_import_decl(ctx
);
2658 oberon_assert_token(ctx
, SEMICOLON
);
2662 oberon_parse_module(oberon_context_t
* ctx
)
2666 oberon_read_token(ctx
);
2668 oberon_assert_token(ctx
, MODULE
);
2669 name1
= oberon_assert_ident(ctx
);
2670 oberon_assert_token(ctx
, SEMICOLON
);
2671 ctx
-> mod
-> name
= name1
;
2673 if(ctx
-> token
== IMPORT
)
2675 oberon_import_list(ctx
);
2678 oberon_decl_seq(ctx
);
2680 oberon_generate_begin_module(ctx
);
2681 if(ctx
-> token
== BEGIN
)
2683 oberon_assert_token(ctx
, BEGIN
);
2684 oberon_statement_seq(ctx
);
2686 oberon_generate_end_module(ctx
);
2688 oberon_assert_token(ctx
, END
);
2689 name2
= oberon_assert_ident(ctx
);
2690 oberon_assert_token(ctx
, DOT
);
2692 if(strcmp(name1
, name2
) != 0)
2694 oberon_error(ctx
, "module name not matched");
2698 // =======================================================================
2700 // =======================================================================
2703 register_default_types(oberon_context_t
* ctx
)
2705 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2706 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2708 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2709 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2710 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2712 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
2713 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1);
2715 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(bool));
2716 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1);
2718 ctx
-> real_type
= oberon_new_type_real(sizeof(float));
2719 oberon_define_type(ctx
-> world_scope
, "REAL", ctx
-> real_type
, 1);
2723 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2725 oberon_object_t
* proc
;
2726 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, 1, 0);
2727 proc
-> sysproc
= 1;
2728 proc
-> genfunc
= f
;
2729 proc
-> genproc
= p
;
2730 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2733 static oberon_expr_t
*
2734 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2738 oberon_error(ctx
, "too few arguments");
2743 oberon_error(ctx
, "too mach arguments");
2746 oberon_expr_t
* arg
;
2749 oberon_type_t
* result_type
;
2750 result_type
= arg
-> result
;
2752 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2754 oberon_error(ctx
, "ABS accepts only integers");
2758 oberon_expr_t
* expr
;
2759 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2764 oberon_make_new_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2768 oberon_error(ctx
, "too few arguments");
2771 oberon_expr_t
* dst
;
2774 oberon_type_t
* type
;
2775 type
= dst
-> result
;
2777 if(type
-> class != OBERON_TYPE_POINTER
)
2779 oberon_error(ctx
, "not a pointer");
2782 type
= type
-> base
;
2784 oberon_expr_t
* src
;
2785 src
= oberon_new_item(MODE_NEW
, dst
-> result
, 0);
2786 src
-> item
.num_args
= 0;
2787 src
-> item
.args
= NULL
;
2790 if(type
-> class == OBERON_TYPE_ARRAY
)
2792 if(type
-> size
== 0)
2794 oberon_type_t
* x
= type
;
2795 while(x
-> class == OBERON_TYPE_ARRAY
)
2805 if(num_args
< max_args
)
2807 oberon_error(ctx
, "too few arguments");
2810 if(num_args
> max_args
)
2812 oberon_error(ctx
, "too mach arguments");
2815 int num_sizes
= max_args
- 1;
2816 oberon_expr_t
* size_list
= list_args
-> next
;
2818 oberon_expr_t
* arg
= size_list
;
2819 for(int i
= 0; i
< max_args
- 1; i
++)
2821 if(arg
-> result
-> class != OBERON_TYPE_INTEGER
)
2823 oberon_error(ctx
, "size must be integer");
2828 src
-> item
.num_args
= num_sizes
;
2829 src
-> item
.args
= size_list
;
2831 else if(type
-> class != OBERON_TYPE_RECORD
)
2833 oberon_error(ctx
, "oberon_make_new_call: wat");
2836 if(num_args
> max_args
)
2838 oberon_error(ctx
, "too mach arguments");
2841 oberon_assign(ctx
, src
, dst
);
2845 oberon_create_context(ModuleImportCallback import_module
)
2847 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2849 oberon_scope_t
* world_scope
;
2850 world_scope
= oberon_open_scope(ctx
);
2851 ctx
-> world_scope
= world_scope
;
2853 ctx
-> import_module
= import_module
;
2855 oberon_generator_init_context(ctx
);
2857 register_default_types(ctx
);
2858 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2859 oberon_new_intrinsic(ctx
, "NEW", NULL
, oberon_make_new_call
);
2865 oberon_destroy_context(oberon_context_t
* ctx
)
2867 oberon_generator_destroy_context(ctx
);
2872 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2874 const char * code
= ctx
-> code
;
2875 int code_index
= ctx
-> code_index
;
2877 int token
= ctx
-> token
;
2878 char * string
= ctx
-> string
;
2879 int integer
= ctx
-> integer
;
2880 oberon_scope_t
* decl
= ctx
-> decl
;
2881 oberon_module_t
* mod
= ctx
-> mod
;
2883 oberon_scope_t
* module_scope
;
2884 module_scope
= oberon_open_scope(ctx
);
2886 oberon_module_t
* module
;
2887 module
= calloc(1, sizeof *module
);
2888 module
-> decl
= module_scope
;
2889 module
-> next
= ctx
-> module_list
;
2891 ctx
-> mod
= module
;
2892 ctx
-> module_list
= module
;
2894 oberon_init_scaner(ctx
, newcode
);
2895 oberon_parse_module(ctx
);
2897 module
-> ready
= 1;
2900 ctx
-> code_index
= code_index
;
2902 ctx
-> token
= token
;
2903 ctx
-> string
= string
;
2904 ctx
-> integer
= integer
;