b56a458a6c1e979a743c9d4139b5df3044f1cdc3
59 // =======================================================================
61 // =======================================================================
64 oberon_error(oberon_context_t
* ctx
, const char * fmt
, ...)
68 fprintf(stderr
, "error: ");
69 vfprintf(stderr
, fmt
, ptr
);
70 fprintf(stderr
, "\n");
71 fprintf(stderr
, " code_index = %i\n", ctx
-> code_index
);
72 fprintf(stderr
, " c = %c\n", ctx
-> c
);
73 fprintf(stderr
, " token = %i\n", ctx
-> token
);
78 static oberon_type_t
*
79 oberon_new_type_ptr(int class)
81 oberon_type_t
* x
= malloc(sizeof *x
);
82 memset(x
, 0, sizeof *x
);
87 static oberon_type_t
*
88 oberon_new_type_integer(int size
)
91 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
96 static oberon_type_t
*
97 oberon_new_type_boolean(int size
)
100 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
105 // =======================================================================
107 // =======================================================================
109 static oberon_scope_t
*
110 oberon_open_scope(oberon_context_t
* ctx
)
112 oberon_scope_t
* scope
= calloc(1, sizeof *scope
);
113 oberon_object_t
* list
= calloc(1, sizeof *list
);
116 scope
-> list
= list
;
117 scope
-> up
= ctx
-> decl
;
121 scope
-> parent
= scope
-> up
-> parent
;
122 scope
-> local
= scope
-> up
-> local
;
130 oberon_close_scope(oberon_scope_t
* scope
)
132 oberon_context_t
* ctx
= scope
-> ctx
;
133 ctx
-> decl
= scope
-> up
;
136 static oberon_object_t
*
137 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class, int export
, int read_only
)
139 oberon_object_t
* x
= scope
-> list
;
140 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
147 oberon_error(scope
-> ctx
, "already defined");
150 oberon_object_t
* newvar
= malloc(sizeof *newvar
);
151 memset(newvar
, 0, sizeof *newvar
);
152 newvar
-> name
= name
;
153 newvar
-> class = class;
154 newvar
-> export
= export
;
155 newvar
-> read_only
= read_only
;
156 newvar
-> local
= scope
-> local
;
157 newvar
-> parent
= scope
-> parent
;
158 newvar
-> module
= scope
-> ctx
-> mod
;
165 static oberon_object_t
*
166 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
168 oberon_object_t
* x
= list
;
169 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
176 static oberon_object_t
*
177 oberon_find_object(oberon_scope_t
* scope
, char * name
, int check_it
)
179 oberon_object_t
* result
= NULL
;
181 oberon_scope_t
* s
= scope
;
182 while(result
== NULL
&& s
!= NULL
)
184 result
= oberon_find_object_in_list(s
-> list
, name
);
188 if(check_it
&& result
== NULL
)
190 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
196 static oberon_object_t
*
197 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
199 oberon_object_t
* x
= rec
-> decl
;
200 for(int i
= 0; i
< rec
-> num_decl
; i
++)
202 if(strcmp(x
-> name
, name
) == 0)
209 oberon_error(ctx
, "field not defined");
214 static oberon_object_t
*
215 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
, int export
)
217 oberon_object_t
* id
;
218 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
, export
, 0);
220 oberon_generator_init_type(scope
-> ctx
, type
);
224 // =======================================================================
226 // =======================================================================
229 oberon_get_char(oberon_context_t
* ctx
)
231 ctx
-> code_index
+= 1;
232 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
236 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
239 ctx
-> code_index
= 0;
240 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
244 oberon_read_ident(oberon_context_t
* ctx
)
247 int i
= ctx
-> code_index
;
249 int c
= ctx
-> code
[i
];
257 char * ident
= malloc(len
+ 1);
258 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
261 ctx
-> code_index
= i
;
262 ctx
-> c
= ctx
-> code
[i
];
263 ctx
-> string
= ident
;
264 ctx
-> token
= IDENT
;
266 if(strcmp(ident
, "MODULE") == 0)
268 ctx
-> token
= MODULE
;
270 else if(strcmp(ident
, "END") == 0)
274 else if(strcmp(ident
, "VAR") == 0)
278 else if(strcmp(ident
, "BEGIN") == 0)
280 ctx
-> token
= BEGIN
;
282 else if(strcmp(ident
, "TRUE") == 0)
286 else if(strcmp(ident
, "FALSE") == 0)
288 ctx
-> token
= FALSE
;
290 else if(strcmp(ident
, "OR") == 0)
294 else if(strcmp(ident
, "DIV") == 0)
298 else if(strcmp(ident
, "MOD") == 0)
302 else if(strcmp(ident
, "PROCEDURE") == 0)
304 ctx
-> token
= PROCEDURE
;
306 else if(strcmp(ident
, "RETURN") == 0)
308 ctx
-> token
= RETURN
;
310 else if(strcmp(ident
, "CONST") == 0)
312 ctx
-> token
= CONST
;
314 else if(strcmp(ident
, "TYPE") == 0)
318 else if(strcmp(ident
, "ARRAY") == 0)
320 ctx
-> token
= ARRAY
;
322 else if(strcmp(ident
, "OF") == 0)
326 else if(strcmp(ident
, "RECORD") == 0)
328 ctx
-> token
= RECORD
;
330 else if(strcmp(ident
, "POINTER") == 0)
332 ctx
-> token
= POINTER
;
334 else if(strcmp(ident
, "TO") == 0)
338 else if(strcmp(ident
, "NIL") == 0)
342 else if(strcmp(ident
, "IMPORT") == 0)
344 ctx
-> token
= IMPORT
;
349 oberon_read_integer(oberon_context_t
* ctx
)
352 int i
= ctx
-> code_index
;
354 int c
= ctx
-> code
[i
];
362 char * ident
= malloc(len
+ 2);
363 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
366 ctx
-> code_index
= i
;
367 ctx
-> c
= ctx
-> code
[i
];
368 ctx
-> string
= ident
;
369 ctx
-> integer
= atoi(ident
);
370 ctx
-> token
= INTEGER
;
374 oberon_skip_space(oberon_context_t
* ctx
)
376 while(isspace(ctx
-> c
))
378 oberon_get_char(ctx
);
383 oberon_read_symbol(oberon_context_t
* ctx
)
392 ctx
-> token
= SEMICOLON
;
393 oberon_get_char(ctx
);
396 ctx
-> token
= COLON
;
397 oberon_get_char(ctx
);
400 ctx
-> token
= ASSIGN
;
401 oberon_get_char(ctx
);
406 oberon_get_char(ctx
);
409 ctx
-> token
= LPAREN
;
410 oberon_get_char(ctx
);
413 ctx
-> token
= RPAREN
;
414 oberon_get_char(ctx
);
417 ctx
-> token
= EQUAL
;
418 oberon_get_char(ctx
);
422 oberon_get_char(ctx
);
426 oberon_get_char(ctx
);
430 oberon_get_char(ctx
);
434 ctx
-> token
= GREAT
;
435 oberon_get_char(ctx
);
439 oberon_get_char(ctx
);
444 oberon_get_char(ctx
);
447 ctx
-> token
= MINUS
;
448 oberon_get_char(ctx
);
452 oberon_get_char(ctx
);
455 ctx
-> token
= SLASH
;
456 oberon_get_char(ctx
);
460 oberon_get_char(ctx
);
464 oberon_get_char(ctx
);
467 ctx
-> token
= COMMA
;
468 oberon_get_char(ctx
);
471 ctx
-> token
= LBRACE
;
472 oberon_get_char(ctx
);
475 ctx
-> token
= RBRACE
;
476 oberon_get_char(ctx
);
479 ctx
-> token
= UPARROW
;
480 oberon_get_char(ctx
);
483 oberon_error(ctx
, "invalid char");
489 oberon_read_token(oberon_context_t
* ctx
)
491 oberon_skip_space(ctx
);
496 oberon_read_ident(ctx
);
500 oberon_read_integer(ctx
);
504 oberon_read_symbol(ctx
);
508 // =======================================================================
510 // =======================================================================
512 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
513 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
514 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
515 static char * oberon_assert_ident(oberon_context_t
* ctx
);
516 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
517 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
519 static oberon_expr_t
*
520 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
522 oberon_oper_t
* operator;
523 operator = malloc(sizeof *operator);
524 memset(operator, 0, sizeof *operator);
526 operator -> is_item
= 0;
527 operator -> result
= result
;
528 operator -> read_only
= 1;
530 operator -> left
= left
;
531 operator -> right
= right
;
533 return (oberon_expr_t
*) operator;
536 static oberon_expr_t
*
537 oberon_new_item(int mode
, oberon_type_t
* result
, int read_only
)
539 oberon_item_t
* item
;
540 item
= malloc(sizeof *item
);
541 memset(item
, 0, sizeof *item
);
544 item
-> result
= result
;
545 item
-> read_only
= read_only
;
548 return (oberon_expr_t
*)item
;
551 static oberon_expr_t
*
552 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
554 oberon_expr_t
* expr
;
555 oberon_type_t
* result
;
557 result
= a
-> result
;
561 if(result
-> class != OBERON_TYPE_INTEGER
)
563 oberon_error(ctx
, "incompatible operator type");
566 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
568 else if(token
== NOT
)
570 if(result
-> class != OBERON_TYPE_BOOLEAN
)
572 oberon_error(ctx
, "incompatible operator type");
575 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
579 oberon_error(ctx
, "oberon_make_unary_op: wat");
586 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
588 oberon_expr_t
* last
;
591 *first
= last
= oberon_expr(ctx
);
592 while(ctx
-> token
== COMMA
)
594 oberon_assert_token(ctx
, COMMA
);
595 oberon_expr_t
* current
;
599 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
603 current
= oberon_expr(ctx
);
606 last
-> next
= current
;
612 static oberon_expr_t
*
613 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
615 if(pref
-> class != expr
-> result
-> class)
617 oberon_error(ctx
, "incompatible types");
620 if(pref
-> class == OBERON_TYPE_INTEGER
)
622 if(expr
-> result
-> class > pref
-> class)
624 oberon_error(ctx
, "incompatible size");
627 else if(pref
-> class == OBERON_TYPE_RECORD
)
629 if(expr
-> result
!= pref
)
631 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
632 oberon_error(ctx
, "incompatible record types");
635 else if(pref
-> class == OBERON_TYPE_POINTER
)
637 if(expr
-> result
-> base
!= pref
-> base
)
639 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
641 oberon_error(ctx
, "incompatible pointer types");
652 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
654 if(desig
-> is_item
== 0)
656 oberon_error(ctx
, "expected item");
659 if(desig
-> item
.mode
!= MODE_CALL
)
661 oberon_error(ctx
, "expected mode CALL");
664 if(desig
-> item
.var
-> type
-> class != OBERON_TYPE_PROCEDURE
)
666 oberon_error(ctx
, "only procedures can be called");
669 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
670 int num_args
= desig
-> item
.num_args
;
671 int num_decl
= fn
-> num_decl
;
673 if(num_args
< num_decl
)
675 oberon_error(ctx
, "too few arguments");
677 else if(num_args
> num_decl
)
679 oberon_error(ctx
, "too many arguments");
682 oberon_expr_t
* arg
= desig
-> item
.args
;
683 oberon_object_t
* param
= fn
-> decl
;
684 for(int i
= 0; i
< num_args
; i
++)
686 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
690 switch(arg
-> item
.mode
)
695 // Допустимо разыменование?
699 oberon_error(ctx
, "var-parameter accept only variables");
704 oberon_autocast_to(ctx
, arg
, param
-> type
);
706 param
= param
-> next
;
710 static oberon_expr_t
*
711 oberon_make_call_func(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
713 switch(proc
-> class)
715 case OBERON_CLASS_PROC
:
716 if(proc
-> class != OBERON_CLASS_PROC
)
718 oberon_error(ctx
, "not a procedure");
721 case OBERON_CLASS_VAR
:
722 case OBERON_CLASS_VAR_PARAM
:
723 case OBERON_CLASS_PARAM
:
724 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
726 oberon_error(ctx
, "not a procedure");
730 oberon_error(ctx
, "not a procedure");
734 oberon_expr_t
* call
;
738 if(proc
-> genfunc
== NULL
)
740 oberon_error(ctx
, "not a function-procedure");
743 call
= proc
-> genfunc(ctx
, num_args
, list_args
);
747 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
)
749 oberon_error(ctx
, "attempt to call procedure in expression");
752 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
753 call
-> item
.var
= proc
;
754 call
-> item
.num_args
= num_args
;
755 call
-> item
.args
= list_args
;
756 oberon_autocast_call(ctx
, call
);
763 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
765 switch(proc
-> class)
767 case OBERON_CLASS_PROC
:
768 if(proc
-> class != OBERON_CLASS_PROC
)
770 oberon_error(ctx
, "not a procedure");
773 case OBERON_CLASS_VAR
:
774 case OBERON_CLASS_VAR_PARAM
:
775 case OBERON_CLASS_PARAM
:
776 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
778 oberon_error(ctx
, "not a procedure");
782 oberon_error(ctx
, "not a procedure");
788 if(proc
-> genproc
== NULL
)
790 oberon_error(ctx
, "requres non-typed procedure");
793 proc
-> genproc(ctx
, num_args
, list_args
);
797 if(proc
-> type
-> base
-> class != OBERON_TYPE_VOID
)
799 oberon_error(ctx
, "attempt to call function as non-typed procedure");
802 oberon_expr_t
* call
;
803 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
804 call
-> item
.var
= proc
;
805 call
-> item
.num_args
= num_args
;
806 call
-> item
.args
= list_args
;
807 oberon_autocast_call(ctx
, call
);
808 oberon_generate_call_proc(ctx
, call
);
816 || ((x) == INTEGER) \
822 static oberon_expr_t
*
823 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
825 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
827 oberon_error(ctx
, "not a pointer");
830 assert(expr
-> is_item
);
832 oberon_expr_t
* selector
;
833 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
, expr
-> read_only
);
834 selector
-> item
.parent
= (oberon_item_t
*) expr
;
839 static oberon_expr_t
*
840 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
842 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
844 desig
= oberno_make_dereferencing(ctx
, desig
);
847 assert(desig
-> is_item
);
849 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
851 oberon_error(ctx
, "not array");
854 oberon_type_t
* base
;
855 base
= desig
-> result
-> base
;
857 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
859 oberon_error(ctx
, "index must be integer");
862 // Статическая проверка границ массива
865 if(index
-> item
.mode
== MODE_INTEGER
)
867 int arr_size
= desig
-> result
-> size
;
868 int index_int
= index
-> item
.integer
;
869 if(index_int
< 0 || index_int
> arr_size
- 1)
871 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
876 oberon_expr_t
* selector
;
877 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
878 selector
-> item
.parent
= (oberon_item_t
*) desig
;
879 selector
-> item
.num_args
= 1;
880 selector
-> item
.args
= index
;
885 static oberon_expr_t
*
886 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
888 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
890 expr
= oberno_make_dereferencing(ctx
, expr
);
893 assert(expr
-> is_item
== 1);
895 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
897 oberon_error(ctx
, "not record");
900 oberon_type_t
* rec
= expr
-> result
;
902 oberon_object_t
* field
;
903 field
= oberon_find_field(ctx
, rec
, name
);
905 if(field
-> export
== 0)
907 if(field
-> module
!= ctx
-> mod
)
909 oberon_error(ctx
, "field not exported");
914 if(field
-> read_only
)
916 if(field
-> module
!= ctx
-> mod
)
922 oberon_expr_t
* selector
;
923 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
924 selector
-> item
.var
= field
;
925 selector
-> item
.parent
= (oberon_item_t
*) expr
;
930 #define ISSELECTOR(x) \
935 static oberon_object_t
*
936 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
941 name
= oberon_assert_ident(ctx
);
942 x
= oberon_find_object(ctx
-> decl
, name
, check
);
946 if(x
-> class == OBERON_CLASS_MODULE
)
948 oberon_assert_token(ctx
, DOT
);
949 name
= oberon_assert_ident(ctx
);
950 /* Наличие объектов в левых модулях всегда проверяется */
951 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
955 oberon_error(ctx
, "not exported");
968 static oberon_expr_t
*
969 oberon_designator(oberon_context_t
* ctx
)
972 oberon_object_t
* var
;
973 oberon_expr_t
* expr
;
975 var
= oberon_qualident(ctx
, NULL
, 1);
980 if(var
-> module
!= ctx
-> mod
)
988 case OBERON_CLASS_CONST
:
990 expr
= (oberon_expr_t
*) var
-> value
;
992 case OBERON_CLASS_VAR
:
993 case OBERON_CLASS_VAR_PARAM
:
994 case OBERON_CLASS_PARAM
:
995 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
997 case OBERON_CLASS_PROC
:
998 expr
= oberon_new_item(MODE_VAR
, var
-> type
, 1);
1001 oberon_error(ctx
, "invalid designator");
1004 expr
-> item
.var
= var
;
1006 while(ISSELECTOR(ctx
-> token
))
1008 switch(ctx
-> token
)
1011 oberon_assert_token(ctx
, DOT
);
1012 name
= oberon_assert_ident(ctx
);
1013 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1016 oberon_assert_token(ctx
, LBRACE
);
1017 int num_indexes
= 0;
1018 oberon_expr_t
* indexes
= NULL
;
1019 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1020 oberon_assert_token(ctx
, RBRACE
);
1022 for(int i
= 0; i
< num_indexes
; i
++)
1024 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1025 indexes
= indexes
-> next
;
1029 oberon_assert_token(ctx
, UPARROW
);
1030 expr
= oberno_make_dereferencing(ctx
, expr
);
1033 oberon_error(ctx
, "oberon_designator: wat");
1040 static oberon_expr_t
*
1041 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1043 assert(expr
-> is_item
== 1);
1045 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1046 if(ctx
-> token
== LPAREN
)
1048 oberon_assert_token(ctx
, LPAREN
);
1051 oberon_expr_t
* arguments
= NULL
;
1053 if(ISEXPR(ctx
-> token
))
1055 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1058 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1060 oberon_assert_token(ctx
, RPAREN
);
1067 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1069 assert(expr
-> is_item
== 1);
1072 oberon_expr_t
* arguments
= NULL
;
1074 if(ctx
-> token
== LPAREN
)
1076 oberon_assert_token(ctx
, LPAREN
);
1078 if(ISEXPR(ctx
-> token
))
1080 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1083 oberon_assert_token(ctx
, RPAREN
);
1086 /* Вызов происходит даже без скобок */
1087 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1090 static oberon_expr_t
*
1091 oberon_factor(oberon_context_t
* ctx
)
1093 oberon_expr_t
* expr
;
1095 switch(ctx
-> token
)
1098 expr
= oberon_designator(ctx
);
1099 expr
= oberon_opt_func_parens(ctx
, expr
);
1102 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
, 1);
1103 expr
-> item
.integer
= ctx
-> integer
;
1104 oberon_assert_token(ctx
, INTEGER
);
1107 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1108 expr
-> item
.boolean
= 1;
1109 oberon_assert_token(ctx
, TRUE
);
1112 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1113 expr
-> item
.boolean
= 0;
1114 oberon_assert_token(ctx
, FALSE
);
1117 oberon_assert_token(ctx
, LPAREN
);
1118 expr
= oberon_expr(ctx
);
1119 oberon_assert_token(ctx
, RPAREN
);
1122 oberon_assert_token(ctx
, NOT
);
1123 expr
= oberon_factor(ctx
);
1124 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1127 oberon_assert_token(ctx
, NIL
);
1128 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
, 1);
1131 oberon_error(ctx
, "invalid expression");
1138 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
1139 * 1. Классы обоих типов должны быть одинаковы
1140 * 2. В качестве результата должен быть выбран больший тип.
1141 * 3. Если размер результат не должен быть меньше чем базовый int
1145 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
1147 if((a
-> class) != (b
-> class))
1149 oberon_error(ctx
, "incompatible types");
1152 if((a
-> size
) > (b
-> size
))
1161 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
1163 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
1165 *result
= ctx
-> int_type
;
1169 /* TODO: cast types */
1172 #define ITMAKESBOOLEAN(x) \
1173 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1175 #define ITUSEONLYINTEGER(x) \
1176 ((x) >= LESS && (x) <= GEQ)
1178 #define ITUSEONLYBOOLEAN(x) \
1179 (((x) == OR) || ((x) == AND))
1181 static oberon_expr_t
*
1182 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1184 oberon_expr_t
* expr
;
1185 oberon_type_t
* result
;
1187 if(ITMAKESBOOLEAN(token
))
1189 if(ITUSEONLYINTEGER(token
))
1191 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1192 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1194 oberon_error(ctx
, "used only with integer types");
1197 else if(ITUSEONLYBOOLEAN(token
))
1199 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1200 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1202 oberon_error(ctx
, "used only with boolean type");
1206 result
= ctx
-> bool_type
;
1210 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1212 else if(token
== NEQ
)
1214 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1216 else if(token
== LESS
)
1218 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1220 else if(token
== LEQ
)
1222 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1224 else if(token
== GREAT
)
1226 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1228 else if(token
== GEQ
)
1230 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1232 else if(token
== OR
)
1234 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1236 else if(token
== AND
)
1238 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1242 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1247 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1251 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1253 else if(token
== MINUS
)
1255 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1257 else if(token
== STAR
)
1259 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1261 else if(token
== SLASH
)
1263 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1265 else if(token
== DIV
)
1267 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1269 else if(token
== MOD
)
1271 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1275 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1282 #define ISMULOP(x) \
1283 ((x) >= STAR && (x) <= AND)
1285 static oberon_expr_t
*
1286 oberon_term_expr(oberon_context_t
* ctx
)
1288 oberon_expr_t
* expr
;
1290 expr
= oberon_factor(ctx
);
1291 while(ISMULOP(ctx
-> token
))
1293 int token
= ctx
-> token
;
1294 oberon_read_token(ctx
);
1296 oberon_expr_t
* inter
= oberon_factor(ctx
);
1297 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1303 #define ISADDOP(x) \
1304 ((x) >= PLUS && (x) <= OR)
1306 static oberon_expr_t
*
1307 oberon_simple_expr(oberon_context_t
* ctx
)
1309 oberon_expr_t
* expr
;
1312 if(ctx
-> token
== PLUS
)
1315 oberon_assert_token(ctx
, PLUS
);
1317 else if(ctx
-> token
== MINUS
)
1320 oberon_assert_token(ctx
, MINUS
);
1323 expr
= oberon_term_expr(ctx
);
1324 while(ISADDOP(ctx
-> token
))
1326 int token
= ctx
-> token
;
1327 oberon_read_token(ctx
);
1329 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1330 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1335 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1341 #define ISRELATION(x) \
1342 ((x) >= EQUAL && (x) <= GEQ)
1344 static oberon_expr_t
*
1345 oberon_expr(oberon_context_t
* ctx
)
1347 oberon_expr_t
* expr
;
1349 expr
= oberon_simple_expr(ctx
);
1350 while(ISRELATION(ctx
-> token
))
1352 int token
= ctx
-> token
;
1353 oberon_read_token(ctx
);
1355 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1356 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1362 static oberon_item_t
*
1363 oberon_const_expr(oberon_context_t
* ctx
)
1365 oberon_expr_t
* expr
;
1366 expr
= oberon_expr(ctx
);
1368 if(expr
-> is_item
== 0)
1370 oberon_error(ctx
, "const expression are required");
1373 return (oberon_item_t
*) expr
;
1376 // =======================================================================
1378 // =======================================================================
1380 static void oberon_decl_seq(oberon_context_t
* ctx
);
1381 static void oberon_statement_seq(oberon_context_t
* ctx
);
1382 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1385 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1387 if(ctx
-> token
!= token
)
1389 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1394 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1396 oberon_expect_token(ctx
, token
);
1397 oberon_read_token(ctx
);
1401 oberon_assert_ident(oberon_context_t
* ctx
)
1403 oberon_expect_token(ctx
, IDENT
);
1404 char * ident
= ctx
-> string
;
1405 oberon_read_token(ctx
);
1410 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1412 switch(ctx
-> token
)
1415 oberon_assert_token(ctx
, STAR
);
1420 oberon_assert_token(ctx
, MINUS
);
1431 static oberon_object_t
*
1432 oberon_ident_def(oberon_context_t
* ctx
, int class)
1437 oberon_object_t
* x
;
1439 name
= oberon_assert_ident(ctx
);
1440 oberon_def(ctx
, &export
, &read_only
);
1442 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
);
1447 oberon_ident_list(oberon_context_t
* ctx
, int class, int * num
, oberon_object_t
** list
)
1450 *list
= oberon_ident_def(ctx
, class);
1451 while(ctx
-> token
== COMMA
)
1453 oberon_assert_token(ctx
, COMMA
);
1454 oberon_ident_def(ctx
, class);
1460 oberon_var_decl(oberon_context_t
* ctx
)
1463 oberon_object_t
* list
;
1464 oberon_type_t
* type
;
1465 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1467 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, &num
, &list
);
1468 oberon_assert_token(ctx
, COLON
);
1469 oberon_type(ctx
, &type
);
1471 oberon_object_t
* var
= list
;
1472 for(int i
= 0; i
< num
; i
++)
1479 static oberon_object_t
*
1480 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1482 int class = OBERON_CLASS_PARAM
;
1483 if(ctx
-> token
== VAR
)
1485 oberon_read_token(ctx
);
1486 class = OBERON_CLASS_VAR_PARAM
;
1490 oberon_object_t
* list
;
1491 oberon_ident_list(ctx
, class, &num
, &list
);
1493 oberon_assert_token(ctx
, COLON
);
1495 oberon_type_t
* type
;
1496 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1497 oberon_type(ctx
, &type
);
1499 oberon_object_t
* param
= list
;
1500 for(int i
= 0; i
< num
; i
++)
1502 param
-> type
= type
;
1503 param
= param
-> next
;
1510 #define ISFPSECTION \
1511 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1514 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1516 oberon_assert_token(ctx
, LPAREN
);
1520 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1521 while(ctx
-> token
== SEMICOLON
)
1523 oberon_assert_token(ctx
, SEMICOLON
);
1524 oberon_fp_section(ctx
, &signature
-> num_decl
);
1528 oberon_assert_token(ctx
, RPAREN
);
1530 if(ctx
-> token
== COLON
)
1532 oberon_assert_token(ctx
, COLON
);
1534 oberon_object_t
* typeobj
;
1535 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1536 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1538 oberon_error(ctx
, "function result is not type");
1540 signature
-> base
= typeobj
-> type
;
1545 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1547 oberon_type_t
* signature
;
1549 signature
-> class = OBERON_TYPE_PROCEDURE
;
1550 signature
-> num_decl
= 0;
1551 signature
-> base
= ctx
-> void_type
;
1552 signature
-> decl
= NULL
;
1554 if(ctx
-> token
== LPAREN
)
1556 oberon_formal_pars(ctx
, signature
);
1561 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1563 if(a
-> num_decl
!= b
-> num_decl
)
1565 oberon_error(ctx
, "number parameters not matched");
1568 int num_param
= a
-> num_decl
;
1569 oberon_object_t
* param_a
= a
-> decl
;
1570 oberon_object_t
* param_b
= b
-> decl
;
1571 for(int i
= 0; i
< num_param
; i
++)
1573 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1575 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1578 if(param_a
-> type
!= param_b
-> type
)
1580 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1583 param_a
= param_a
-> next
;
1584 param_b
= param_b
-> next
;
1589 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1591 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1592 oberon_type_t
* result_type
= proc
-> type
-> base
;
1594 if(result_type
-> class == OBERON_TYPE_VOID
)
1598 oberon_error(ctx
, "procedure has no result type");
1605 oberon_error(ctx
, "procedure requires expression on result");
1608 oberon_autocast_to(ctx
, expr
, result_type
);
1611 proc
-> has_return
= 1;
1613 oberon_generate_return(ctx
, expr
);
1617 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1619 oberon_assert_token(ctx
, SEMICOLON
);
1621 ctx
-> decl
= proc
-> scope
;
1623 oberon_decl_seq(ctx
);
1625 oberon_generate_begin_proc(ctx
, proc
);
1627 if(ctx
-> token
== BEGIN
)
1629 oberon_assert_token(ctx
, BEGIN
);
1630 oberon_statement_seq(ctx
);
1633 oberon_assert_token(ctx
, END
);
1634 char * name
= oberon_assert_ident(ctx
);
1635 if(strcmp(name
, proc
-> name
) != 0)
1637 oberon_error(ctx
, "procedure name not matched");
1640 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1641 && proc
-> has_return
== 0)
1643 oberon_make_return(ctx
, NULL
);
1646 if(proc
-> has_return
== 0)
1648 oberon_error(ctx
, "procedure requires return");
1651 oberon_generate_end_proc(ctx
);
1652 oberon_close_scope(ctx
-> decl
);
1656 oberon_proc_decl(oberon_context_t
* ctx
)
1658 oberon_assert_token(ctx
, PROCEDURE
);
1661 if(ctx
-> token
== UPARROW
)
1663 oberon_assert_token(ctx
, UPARROW
);
1670 name
= oberon_assert_ident(ctx
);
1671 oberon_def(ctx
, &export
, &read_only
);
1673 oberon_scope_t
* proc_scope
;
1674 proc_scope
= oberon_open_scope(ctx
);
1675 ctx
-> decl
-> local
= 1;
1677 oberon_type_t
* signature
;
1678 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1679 oberon_opt_formal_pars(ctx
, &signature
);
1681 oberon_initialize_decl(ctx
);
1682 oberon_generator_init_type(ctx
, signature
);
1683 oberon_close_scope(ctx
-> decl
);
1685 oberon_object_t
* proc
;
1686 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1689 if(proc
-> class != OBERON_CLASS_PROC
)
1691 oberon_error(ctx
, "mult definition");
1698 oberon_error(ctx
, "mult procedure definition");
1702 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
1704 oberon_error(ctx
, "export type not matched");
1707 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1711 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
);
1712 proc
-> type
= signature
;
1713 proc
-> scope
= proc_scope
;
1714 oberon_generator_init_proc(ctx
, proc
);
1717 proc
-> scope
-> parent
= proc
;
1722 oberon_proc_decl_body(ctx
, proc
);
1727 oberon_const_decl(oberon_context_t
* ctx
)
1729 oberon_item_t
* value
;
1730 oberon_object_t
* constant
;
1732 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
);
1733 oberon_assert_token(ctx
, EQUAL
);
1734 value
= oberon_const_expr(ctx
);
1735 constant
-> value
= value
;
1739 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
1741 if(size
-> is_item
== 0)
1743 oberon_error(ctx
, "requires constant");
1746 if(size
-> item
.mode
!= MODE_INTEGER
)
1748 oberon_error(ctx
, "requires integer constant");
1751 oberon_type_t
* arr
;
1753 arr
-> class = OBERON_TYPE_ARRAY
;
1754 arr
-> size
= size
-> item
.integer
;
1759 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1761 if(ctx
-> token
== IDENT
)
1764 oberon_object_t
* list
;
1765 oberon_type_t
* type
;
1766 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1768 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, &num
, &list
);
1769 oberon_assert_token(ctx
, COLON
);
1770 oberon_type(ctx
, &type
);
1772 oberon_object_t
* field
= list
;
1773 for(int i
= 0; i
< num
; i
++)
1775 field
-> type
= type
;
1776 field
= field
-> next
;
1779 rec
-> num_decl
+= num
;
1784 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1787 oberon_object_t
* to
;
1789 to
= oberon_qualident(ctx
, &name
, 0);
1791 //name = oberon_assert_ident(ctx);
1792 //to = oberon_find_object(ctx -> decl, name, 0);
1796 if(to
-> class != OBERON_CLASS_TYPE
)
1798 oberon_error(ctx
, "not a type");
1803 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, 0, 0);
1804 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1810 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
1813 * Правило граматики "type". Указатель type должен указывать на существующий объект!
1817 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
1825 oberon_type_t
* dim
;
1826 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1828 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
1830 oberon_make_array_type(ctx
, sizes
, dim
, type
);
1834 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
1836 if(ctx
-> token
== IDENT
)
1838 oberon_qualident_type(ctx
, type
);
1840 else if(ctx
-> token
== ARRAY
)
1842 oberon_assert_token(ctx
, ARRAY
);
1845 oberon_expr_t
* sizes
;
1846 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
1848 oberon_assert_token(ctx
, OF
);
1850 oberon_type_t
* base
;
1851 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1852 oberon_type(ctx
, &base
);
1854 oberon_make_multiarray(ctx
, sizes
, base
, type
);
1856 else if(ctx
-> token
== RECORD
)
1858 oberon_type_t
* rec
;
1860 rec
-> class = OBERON_TYPE_RECORD
;
1862 oberon_scope_t
* record_scope
;
1863 record_scope
= oberon_open_scope(ctx
);
1864 // TODO parent object
1865 //record_scope -> parent = NULL;
1866 record_scope
-> local
= 1;
1868 oberon_assert_token(ctx
, RECORD
);
1869 oberon_field_list(ctx
, rec
);
1870 while(ctx
-> token
== SEMICOLON
)
1872 oberon_assert_token(ctx
, SEMICOLON
);
1873 oberon_field_list(ctx
, rec
);
1875 oberon_assert_token(ctx
, END
);
1877 rec
-> decl
= record_scope
-> list
-> next
;
1878 oberon_close_scope(record_scope
);
1882 else if(ctx
-> token
== POINTER
)
1884 oberon_assert_token(ctx
, POINTER
);
1885 oberon_assert_token(ctx
, TO
);
1887 oberon_type_t
* base
;
1888 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1889 oberon_type(ctx
, &base
);
1891 oberon_type_t
* ptr
;
1893 ptr
-> class = OBERON_TYPE_POINTER
;
1896 else if(ctx
-> token
== PROCEDURE
)
1898 oberon_open_scope(ctx
);
1899 oberon_assert_token(ctx
, PROCEDURE
);
1900 oberon_opt_formal_pars(ctx
, type
);
1901 oberon_close_scope(ctx
-> decl
);
1905 oberon_error(ctx
, "invalid type declaration");
1910 oberon_type_decl(oberon_context_t
* ctx
)
1913 oberon_object_t
* newtype
;
1914 oberon_type_t
* type
;
1918 name
= oberon_assert_ident(ctx
);
1919 oberon_def(ctx
, &export
, &read_only
);
1921 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
1924 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
1925 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1926 assert(newtype
-> type
);
1930 if(newtype
-> class != OBERON_CLASS_TYPE
)
1932 oberon_error(ctx
, "mult definition");
1935 if(newtype
-> linked
)
1937 oberon_error(ctx
, "mult definition - already linked");
1940 newtype
-> export
= export
;
1941 newtype
-> read_only
= read_only
;
1944 oberon_assert_token(ctx
, EQUAL
);
1946 type
= newtype
-> type
;
1947 oberon_type(ctx
, &type
);
1949 if(type
-> class == OBERON_TYPE_VOID
)
1951 oberon_error(ctx
, "recursive alias declaration");
1954 newtype
-> type
= type
;
1955 newtype
-> linked
= 1;
1958 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
1959 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
1962 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
1964 if(type
-> class != OBERON_TYPE_POINTER
1965 && type
-> class != OBERON_TYPE_ARRAY
)
1970 if(type
-> recursive
)
1972 oberon_error(ctx
, "recursive pointer declaration");
1975 if(type
-> base
-> class == OBERON_TYPE_POINTER
)
1977 oberon_error(ctx
, "attempt to make pointer to pointer");
1980 type
-> recursive
= 1;
1982 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
1984 type
-> recursive
= 0;
1988 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
1990 if(type
-> class != OBERON_TYPE_RECORD
)
1995 if(type
-> recursive
)
1997 oberon_error(ctx
, "recursive record declaration");
2000 type
-> recursive
= 1;
2002 int num_fields
= type
-> num_decl
;
2003 oberon_object_t
* field
= type
-> decl
;
2004 for(int i
= 0; i
< num_fields
; i
++)
2006 oberon_prevent_recursive_object(ctx
, field
);
2007 field
= field
-> next
;
2010 type
-> recursive
= 0;
2013 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2015 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2020 if(type
-> recursive
)
2022 oberon_error(ctx
, "recursive procedure declaration");
2025 type
-> recursive
= 1;
2027 int num_fields
= type
-> num_decl
;
2028 oberon_object_t
* field
= type
-> decl
;
2029 for(int i
= 0; i
< num_fields
; i
++)
2031 oberon_prevent_recursive_object(ctx
, field
);
2032 field
= field
-> next
;
2035 type
-> recursive
= 0;
2039 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2041 if(type
-> class != OBERON_TYPE_ARRAY
)
2046 if(type
-> recursive
)
2048 oberon_error(ctx
, "recursive array declaration");
2051 type
-> recursive
= 1;
2053 oberon_prevent_recursive_type(ctx
, type
-> base
);
2055 type
-> recursive
= 0;
2059 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2061 if(type
-> class == OBERON_TYPE_POINTER
)
2063 oberon_prevent_recursive_pointer(ctx
, type
);
2065 else if(type
-> class == OBERON_TYPE_RECORD
)
2067 oberon_prevent_recursive_record(ctx
, type
);
2069 else if(type
-> class == OBERON_TYPE_ARRAY
)
2071 oberon_prevent_recursive_array(ctx
, type
);
2073 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2075 oberon_prevent_recursive_procedure(ctx
, type
);
2080 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2084 case OBERON_CLASS_VAR
:
2085 case OBERON_CLASS_TYPE
:
2086 case OBERON_CLASS_PARAM
:
2087 case OBERON_CLASS_VAR_PARAM
:
2088 case OBERON_CLASS_FIELD
:
2089 oberon_prevent_recursive_type(ctx
, x
-> type
);
2091 case OBERON_CLASS_CONST
:
2092 case OBERON_CLASS_PROC
:
2093 case OBERON_CLASS_MODULE
:
2096 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2102 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2104 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2108 oberon_prevent_recursive_object(ctx
, x
);
2113 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2114 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2117 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2119 if(type
-> class != OBERON_TYPE_RECORD
)
2124 int num_fields
= type
-> num_decl
;
2125 oberon_object_t
* field
= type
-> decl
;
2126 for(int i
= 0; i
< num_fields
; i
++)
2128 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2130 oberon_initialize_type(ctx
, field
-> type
);
2133 oberon_initialize_object(ctx
, field
);
2134 field
= field
-> next
;
2137 oberon_generator_init_record(ctx
, type
);
2141 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2143 if(type
-> class == OBERON_TYPE_VOID
)
2145 oberon_error(ctx
, "undeclarated type");
2148 if(type
-> initialized
)
2153 type
-> initialized
= 1;
2155 if(type
-> class == OBERON_TYPE_POINTER
)
2157 oberon_initialize_type(ctx
, type
-> base
);
2158 oberon_generator_init_type(ctx
, type
);
2160 else if(type
-> class == OBERON_TYPE_ARRAY
)
2162 oberon_initialize_type(ctx
, type
-> base
);
2163 oberon_generator_init_type(ctx
, type
);
2165 else if(type
-> class == OBERON_TYPE_RECORD
)
2167 oberon_generator_init_type(ctx
, type
);
2168 oberon_initialize_record_fields(ctx
, type
);
2170 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2172 int num_fields
= type
-> num_decl
;
2173 oberon_object_t
* field
= type
-> decl
;
2174 for(int i
= 0; i
< num_fields
; i
++)
2176 oberon_initialize_object(ctx
, field
);
2177 field
= field
-> next
;
2180 oberon_generator_init_type(ctx
, type
);
2184 oberon_generator_init_type(ctx
, type
);
2189 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2191 if(x
-> initialized
)
2196 x
-> initialized
= 1;
2200 case OBERON_CLASS_TYPE
:
2201 oberon_initialize_type(ctx
, x
-> type
);
2203 case OBERON_CLASS_VAR
:
2204 case OBERON_CLASS_PARAM
:
2205 case OBERON_CLASS_VAR_PARAM
:
2206 case OBERON_CLASS_FIELD
:
2207 oberon_initialize_type(ctx
, x
-> type
);
2208 oberon_generator_init_var(ctx
, x
);
2210 case OBERON_CLASS_CONST
:
2211 case OBERON_CLASS_PROC
:
2212 case OBERON_CLASS_MODULE
:
2215 oberon_error(ctx
, "oberon_initialize_object: wat");
2221 oberon_initialize_decl(oberon_context_t
* ctx
)
2223 oberon_object_t
* x
= ctx
-> decl
-> list
;
2227 oberon_initialize_object(ctx
, x
-> next
);
2233 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2235 oberon_object_t
* x
= ctx
-> decl
-> list
;
2239 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2241 if(x
-> next
-> linked
== 0)
2243 oberon_error(ctx
, "unresolved forward declaration");
2251 oberon_decl_seq(oberon_context_t
* ctx
)
2253 if(ctx
-> token
== CONST
)
2255 oberon_assert_token(ctx
, CONST
);
2256 while(ctx
-> token
== IDENT
)
2258 oberon_const_decl(ctx
);
2259 oberon_assert_token(ctx
, SEMICOLON
);
2263 if(ctx
-> token
== TYPE
)
2265 oberon_assert_token(ctx
, TYPE
);
2266 while(ctx
-> token
== IDENT
)
2268 oberon_type_decl(ctx
);
2269 oberon_assert_token(ctx
, SEMICOLON
);
2273 if(ctx
-> token
== VAR
)
2275 oberon_assert_token(ctx
, VAR
);
2276 while(ctx
-> token
== IDENT
)
2278 oberon_var_decl(ctx
);
2279 oberon_assert_token(ctx
, SEMICOLON
);
2283 oberon_prevent_recursive_decl(ctx
);
2284 oberon_initialize_decl(ctx
);
2286 while(ctx
-> token
== PROCEDURE
)
2288 oberon_proc_decl(ctx
);
2289 oberon_assert_token(ctx
, SEMICOLON
);
2292 oberon_prevent_undeclarated_procedures(ctx
);
2296 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2298 if(dst
-> read_only
)
2300 oberon_error(ctx
, "read-only destination");
2303 oberon_autocast_to(ctx
, src
, dst
-> result
);
2304 oberon_generate_assign(ctx
, src
, dst
);
2308 oberon_statement(oberon_context_t
* ctx
)
2310 oberon_expr_t
* item1
;
2311 oberon_expr_t
* item2
;
2313 if(ctx
-> token
== IDENT
)
2315 item1
= oberon_designator(ctx
);
2316 if(ctx
-> token
== ASSIGN
)
2318 oberon_assert_token(ctx
, ASSIGN
);
2319 item2
= oberon_expr(ctx
);
2320 oberon_assign(ctx
, item2
, item1
);
2324 oberon_opt_proc_parens(ctx
, item1
);
2327 else if(ctx
-> token
== RETURN
)
2329 oberon_assert_token(ctx
, RETURN
);
2330 if(ISEXPR(ctx
-> token
))
2332 oberon_expr_t
* expr
;
2333 expr
= oberon_expr(ctx
);
2334 oberon_make_return(ctx
, expr
);
2338 oberon_make_return(ctx
, NULL
);
2344 oberon_statement_seq(oberon_context_t
* ctx
)
2346 oberon_statement(ctx
);
2347 while(ctx
-> token
== SEMICOLON
)
2349 oberon_assert_token(ctx
, SEMICOLON
);
2350 oberon_statement(ctx
);
2355 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2357 oberon_module_t
* m
= ctx
-> module_list
;
2358 while(m
&& strcmp(m
-> name
, name
) != 0)
2366 code
= ctx
-> import_module(name
);
2369 oberon_error(ctx
, "no such module");
2372 m
= oberon_compile_module(ctx
, code
);
2378 oberon_error(ctx
, "cyclic module import");
2381 oberon_object_t
* ident
;
2382 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, 0, 0);
2383 ident
-> module
= m
;
2387 oberon_import_decl(oberon_context_t
* ctx
)
2392 alias
= name
= oberon_assert_ident(ctx
);
2393 if(ctx
-> token
== ASSIGN
)
2395 oberon_assert_token(ctx
, ASSIGN
);
2396 name
= oberon_assert_ident(ctx
);
2399 oberon_import_module(ctx
, alias
, name
);
2403 oberon_import_list(oberon_context_t
* ctx
)
2405 oberon_assert_token(ctx
, IMPORT
);
2407 oberon_import_decl(ctx
);
2408 while(ctx
-> token
== COMMA
)
2410 oberon_assert_token(ctx
, COMMA
);
2411 oberon_import_decl(ctx
);
2414 oberon_assert_token(ctx
, SEMICOLON
);
2418 oberon_parse_module(oberon_context_t
* ctx
)
2422 oberon_read_token(ctx
);
2424 oberon_assert_token(ctx
, MODULE
);
2425 name1
= oberon_assert_ident(ctx
);
2426 oberon_assert_token(ctx
, SEMICOLON
);
2427 ctx
-> mod
-> name
= name1
;
2429 if(ctx
-> token
== IMPORT
)
2431 oberon_import_list(ctx
);
2434 oberon_decl_seq(ctx
);
2436 oberon_generate_begin_module(ctx
);
2437 if(ctx
-> token
== BEGIN
)
2439 oberon_assert_token(ctx
, BEGIN
);
2440 oberon_statement_seq(ctx
);
2442 oberon_generate_end_module(ctx
);
2444 oberon_assert_token(ctx
, END
);
2445 name2
= oberon_assert_ident(ctx
);
2446 oberon_assert_token(ctx
, DOT
);
2448 if(strcmp(name1
, name2
) != 0)
2450 oberon_error(ctx
, "module name not matched");
2454 // =======================================================================
2456 // =======================================================================
2459 register_default_types(oberon_context_t
* ctx
)
2461 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2462 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2464 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2465 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2466 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2468 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
2469 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1);
2471 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
2472 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1);
2476 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2478 oberon_object_t
* proc
;
2479 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, 1, 0);
2480 proc
-> sysproc
= 1;
2481 proc
-> genfunc
= f
;
2482 proc
-> genproc
= p
;
2483 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2486 static oberon_expr_t
*
2487 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2491 oberon_error(ctx
, "too few arguments");
2496 oberon_error(ctx
, "too mach arguments");
2499 oberon_expr_t
* arg
;
2502 oberon_type_t
* result_type
;
2503 result_type
= arg
-> result
;
2505 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2507 oberon_error(ctx
, "ABS accepts only integers");
2511 oberon_expr_t
* expr
;
2512 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2517 oberon_create_context(ModuleImportCallback import_module
)
2519 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2521 oberon_scope_t
* world_scope
;
2522 world_scope
= oberon_open_scope(ctx
);
2523 ctx
-> world_scope
= world_scope
;
2525 ctx
-> import_module
= import_module
;
2527 oberon_generator_init_context(ctx
);
2529 register_default_types(ctx
);
2530 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2536 oberon_destroy_context(oberon_context_t
* ctx
)
2538 oberon_generator_destroy_context(ctx
);
2543 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2545 const char * code
= ctx
-> code
;
2546 int code_index
= ctx
-> code_index
;
2548 int token
= ctx
-> token
;
2549 char * string
= ctx
-> string
;
2550 int integer
= ctx
-> integer
;
2551 oberon_scope_t
* decl
= ctx
-> decl
;
2552 oberon_module_t
* mod
= ctx
-> mod
;
2554 oberon_scope_t
* module_scope
;
2555 module_scope
= oberon_open_scope(ctx
);
2557 oberon_module_t
* module
;
2558 module
= calloc(1, sizeof *module
);
2559 module
-> decl
= module_scope
;
2560 module
-> next
= ctx
-> module_list
;
2562 ctx
-> mod
= module
;
2563 ctx
-> module_list
= module
;
2565 oberon_init_scaner(ctx
, newcode
);
2566 oberon_parse_module(ctx
);
2568 module
-> ready
= 1;
2571 ctx
-> code_index
= code_index
;
2573 ctx
-> token
= token
;
2574 ctx
-> string
= string
;
2575 ctx
-> integer
= integer
;