bd5498bbccc06ee9a4ac7ff684ca9f2532149bf9
54 // =======================================================================
56 // =======================================================================
59 oberon_error(oberon_context_t
* ctx
, const char * fmt
, ...)
63 fprintf(stderr
, "error: ");
64 vfprintf(stderr
, fmt
, ptr
);
65 fprintf(stderr
, "\n");
66 fprintf(stderr
, " code_index = %i\n", ctx
-> code_index
);
67 fprintf(stderr
, " c = %c\n", ctx
-> c
);
68 fprintf(stderr
, " token = %i\n", ctx
-> token
);
73 static oberon_type_t
*
74 oberon_new_type_ptr(int class)
76 oberon_type_t
* x
= malloc(sizeof *x
);
77 memset(x
, 0, sizeof *x
);
82 static oberon_type_t
*
83 oberon_new_type_integer(int size
)
86 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
91 static oberon_type_t
*
92 oberon_new_type_boolean(int size
)
95 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
100 // =======================================================================
102 // =======================================================================
104 static oberon_scope_t
*
105 oberon_open_scope(oberon_context_t
* ctx
)
107 oberon_scope_t
* scope
= malloc(sizeof *scope
);
108 memset(scope
, 0, sizeof *scope
);
110 oberon_object_t
* list
= malloc(sizeof *list
);
111 memset(list
, 0, sizeof *list
);
114 scope
-> list
= list
;
115 scope
-> up
= ctx
-> decl
;
122 oberon_close_scope(oberon_scope_t
* scope
)
124 oberon_context_t
* ctx
= scope
-> ctx
;
125 ctx
-> decl
= scope
-> up
;
128 static oberon_object_t
*
129 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class)
131 oberon_object_t
* x
= scope
-> list
;
132 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
139 oberon_error(scope
-> ctx
, "already defined");
142 oberon_object_t
* newvar
= malloc(sizeof *newvar
);
143 memset(newvar
, 0, sizeof *newvar
);
144 newvar
-> name
= name
;
145 newvar
-> class = class;
153 oberon_define_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
, oberon_type_t
* type
)
155 oberon_object_t
* x
= rec
-> decl
;
156 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
163 oberon_error(ctx
, "multiple definition");
166 oberon_object_t
* field
= malloc(sizeof *field
);
167 memset(field
, 0, sizeof *field
);
168 field
-> name
= name
;
169 field
-> class = OBERON_CLASS_FIELD
;
170 field
-> type
= type
;
172 rec
-> num_decl
+= 1;
173 oberon_generator_init_var(ctx
, field
);
178 static oberon_object_t
*
179 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
181 oberon_object_t
* x
= list
;
182 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
189 static oberon_object_t
*
190 oberon_find_object(oberon_scope_t
* scope
, char * name
)
192 oberon_object_t
* result
= NULL
;
194 oberon_scope_t
* s
= scope
;
195 while(result
== NULL
&& s
!= NULL
)
197 result
= oberon_find_object_in_list(s
-> list
, name
);
203 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
209 static oberon_object_t
*
210 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
212 oberon_object_t
* x
= rec
-> decl
;
213 for(int i
= 0; i
< rec
-> num_decl
; i
++)
215 if(strcmp(x
-> name
, name
) == 0)
222 oberon_error(ctx
, "field not defined");
227 static oberon_object_t
*
228 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
)
230 oberon_object_t
* id
;
231 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
);
233 oberon_generator_init_type(scope
-> ctx
, type
);
237 static oberon_type_t
*
238 oberon_find_type(oberon_scope_t
* scope
, char * name
)
240 oberon_object_t
* x
= oberon_find_object(scope
, name
);
241 if(x
-> class != OBERON_CLASS_TYPE
)
243 oberon_error(scope
-> ctx
, "%s not a type", name
);
249 static oberon_object_t
*
250 oberon_define_var(oberon_scope_t
* scope
, int class, char * name
, oberon_type_t
* type
)
252 oberon_object_t
* var
;
253 var
= oberon_define_object(scope
, name
, class);
255 oberon_generator_init_var(scope
-> ctx
, var
);
260 static oberon_object_t *
261 oberon_find_var(oberon_scope_t * scope, char * name)
263 oberon_object_t * x = oberon_find_object(scope, name);
265 if(x -> class != OBERON_CLASS_VAR)
267 oberon_error(scope -> ctx, "%s not a var", name);
274 static oberon_object_t
*
275 oberon_define_proc(oberon_scope_t
* scope
, char * name
, oberon_type_t
* signature
)
277 oberon_object_t
* proc
;
278 proc
= oberon_define_object(scope
, name
, OBERON_CLASS_PROC
);
279 proc
-> type
= signature
;
280 oberon_generator_init_proc(scope
-> ctx
, proc
);
284 // =======================================================================
286 // =======================================================================
289 oberon_get_char(oberon_context_t
* ctx
)
291 ctx
-> code_index
+= 1;
292 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
296 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
299 ctx
-> code_index
= 0;
300 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
304 oberon_read_ident(oberon_context_t
* ctx
)
307 int i
= ctx
-> code_index
;
309 int c
= ctx
-> code
[i
];
317 char * ident
= malloc(len
+ 1);
318 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
321 ctx
-> code_index
= i
;
322 ctx
-> c
= ctx
-> code
[i
];
323 ctx
-> string
= ident
;
324 ctx
-> token
= IDENT
;
326 if(strcmp(ident
, "MODULE") == 0)
328 ctx
-> token
= MODULE
;
330 else if(strcmp(ident
, "END") == 0)
334 else if(strcmp(ident
, "VAR") == 0)
338 else if(strcmp(ident
, "BEGIN") == 0)
340 ctx
-> token
= BEGIN
;
342 else if(strcmp(ident
, "TRUE") == 0)
346 else if(strcmp(ident
, "FALSE") == 0)
348 ctx
-> token
= FALSE
;
350 else if(strcmp(ident
, "OR") == 0)
354 else if(strcmp(ident
, "DIV") == 0)
358 else if(strcmp(ident
, "MOD") == 0)
362 else if(strcmp(ident
, "PROCEDURE") == 0)
364 ctx
-> token
= PROCEDURE
;
366 else if(strcmp(ident
, "RETURN") == 0)
368 ctx
-> token
= RETURN
;
370 else if(strcmp(ident
, "CONST") == 0)
372 ctx
-> token
= CONST
;
374 else if(strcmp(ident
, "TYPE") == 0)
378 else if(strcmp(ident
, "ARRAY") == 0)
380 ctx
-> token
= ARRAY
;
382 else if(strcmp(ident
, "OF") == 0)
386 else if(strcmp(ident
, "RECORD") == 0)
388 ctx
-> token
= RECORD
;
393 oberon_read_integer(oberon_context_t
* ctx
)
396 int i
= ctx
-> code_index
;
398 int c
= ctx
-> code
[i
];
406 char * ident
= malloc(len
+ 2);
407 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
410 ctx
-> code_index
= i
;
411 ctx
-> c
= ctx
-> code
[i
];
412 ctx
-> string
= ident
;
413 ctx
-> integer
= atoi(ident
);
414 ctx
-> token
= INTEGER
;
418 oberon_skip_space(oberon_context_t
* ctx
)
420 while(isspace(ctx
-> c
))
422 oberon_get_char(ctx
);
427 oberon_read_symbol(oberon_context_t
* ctx
)
436 ctx
-> token
= SEMICOLON
;
437 oberon_get_char(ctx
);
440 ctx
-> token
= COLON
;
441 oberon_get_char(ctx
);
444 ctx
-> token
= ASSIGN
;
445 oberon_get_char(ctx
);
450 oberon_get_char(ctx
);
453 ctx
-> token
= LPAREN
;
454 oberon_get_char(ctx
);
457 ctx
-> token
= RPAREN
;
458 oberon_get_char(ctx
);
461 ctx
-> token
= EQUAL
;
462 oberon_get_char(ctx
);
466 oberon_get_char(ctx
);
470 oberon_get_char(ctx
);
474 oberon_get_char(ctx
);
478 ctx
-> token
= GREAT
;
479 oberon_get_char(ctx
);
483 oberon_get_char(ctx
);
488 oberon_get_char(ctx
);
491 ctx
-> token
= MINUS
;
492 oberon_get_char(ctx
);
496 oberon_get_char(ctx
);
499 ctx
-> token
= SLASH
;
500 oberon_get_char(ctx
);
504 oberon_get_char(ctx
);
508 oberon_get_char(ctx
);
511 ctx
-> token
= COMMA
;
512 oberon_get_char(ctx
);
515 ctx
-> token
= LBRACE
;
516 oberon_get_char(ctx
);
519 ctx
-> token
= RBRACE
;
520 oberon_get_char(ctx
);
523 oberon_error(ctx
, "invalid char");
529 oberon_read_token(oberon_context_t
* ctx
)
531 oberon_skip_space(ctx
);
536 oberon_read_ident(ctx
);
540 oberon_read_integer(ctx
);
544 oberon_read_symbol(ctx
);
548 // =======================================================================
550 // =======================================================================
552 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
553 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
554 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
555 static char * oberon_assert_ident(oberon_context_t
* ctx
);
556 static oberon_type_t
* oberon_type(oberon_context_t
* ctx
);
558 static oberon_expr_t
*
559 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
561 oberon_oper_t
* operator;
562 operator = malloc(sizeof *operator);
563 memset(operator, 0, sizeof *operator);
565 operator -> is_item
= 0;
566 operator -> result
= result
;
568 operator -> left
= left
;
569 operator -> right
= right
;
571 return (oberon_expr_t
*) operator;
574 static oberon_expr_t
*
575 oberon_new_item(int mode
, oberon_type_t
* result
)
577 oberon_item_t
* item
;
578 item
= malloc(sizeof *item
);
579 memset(item
, 0, sizeof *item
);
582 item
-> result
= result
;
585 return (oberon_expr_t
*)item
;
588 static oberon_expr_t
*
589 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
591 oberon_expr_t
* expr
;
592 oberon_type_t
* result
;
594 result
= a
-> result
;
598 if(result
-> class != OBERON_TYPE_INTEGER
)
600 oberon_error(ctx
, "incompatible operator type");
603 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
605 else if(token
== NOT
)
607 if(result
-> class != OBERON_TYPE_BOOLEAN
)
609 oberon_error(ctx
, "incompatible operator type");
612 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
616 oberon_error(ctx
, "oberon_make_unary_op: wat");
623 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
)
625 oberon_expr_t
* last
;
628 *first
= last
= oberon_expr(ctx
);
629 while(ctx
-> token
== COMMA
)
631 oberon_assert_token(ctx
, COMMA
);
632 oberon_expr_t
* current
;
633 current
= oberon_expr(ctx
);
634 last
-> next
= current
;
640 static oberon_expr_t
*
641 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
643 if(pref
-> class != expr
-> result
-> class)
645 oberon_error(ctx
, "incompatible types");
649 if(pref
-> class == OBERON_TYPE_INTEGER
)
651 if(expr
-> result
-> class > pref
-> class)
653 oberon_error(ctx
, "incompatible size");
656 else if(pref
-> class == OBERON_TYPE_RECORD
)
658 if(expr
-> result
!= pref
)
660 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
661 oberon_error(ctx
, "incompatible record types");
671 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
673 if(desig
-> is_item
== 0)
675 oberon_error(ctx
, "expected item");
678 if(desig
-> item
.mode
!= MODE_CALL
)
680 oberon_error(ctx
, "expected mode CALL");
683 if(desig
-> item
.var
-> class != OBERON_CLASS_PROC
)
685 oberon_error(ctx
, "only procedures can be called");
688 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
689 int num_args
= desig
-> item
.num_args
;
690 int num_decl
= fn
-> num_decl
;
692 if(num_args
< num_decl
)
694 oberon_error(ctx
, "too few arguments");
696 else if(num_args
> num_decl
)
698 oberon_error(ctx
, "too many arguments");
701 oberon_expr_t
* arg
= desig
-> item
.args
;
702 oberon_object_t
* param
= fn
-> decl
;
703 for(int i
= 0; i
< num_args
; i
++)
705 oberon_autocast_to(ctx
, arg
, param
-> type
);
707 param
= param
-> next
;
715 || ((x) == INTEGER) \
721 #define ISSELECTOR(x) \
725 static oberon_expr_t
*
726 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, int num_indexes
, oberon_expr_t
* indexes
)
728 assert(desig
-> is_item
== 1);
730 if(desig
-> item
.mode
!= MODE_VAR
)
732 oberon_error(ctx
, "not MODE_VAR");
735 int class = desig
-> item
.var
-> class;
738 case OBERON_CLASS_VAR
:
739 case OBERON_CLASS_VAR_PARAM
:
740 case OBERON_CLASS_PARAM
:
743 oberon_error(ctx
, "not variable");
747 oberon_type_t
* type
= desig
-> item
.var
-> type
;
748 if(type
-> class != OBERON_TYPE_ARRAY
)
750 oberon_error(ctx
, "not array");
753 int dim
= desig
-> item
.var
-> type
-> dim
;
754 if(num_indexes
!= dim
)
756 oberon_error(ctx
, "dimesions not matched");
759 oberon_type_t
* base
= desig
-> item
.var
-> type
-> base
;
761 oberon_expr_t
* selector
;
762 selector
= oberon_new_item(MODE_INDEX
, base
);
763 selector
-> item
.parent
= (oberon_item_t
*) desig
;
764 selector
-> item
.num_args
= num_indexes
;
765 selector
-> item
.args
= indexes
;
770 static oberon_expr_t
*
771 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
773 assert(expr
-> is_item
== 1);
775 int class = expr
-> result
-> class;
776 if(class != OBERON_TYPE_RECORD
)
778 oberon_error(ctx
, "not record");
781 oberon_type_t
* rec
= expr
-> result
;
783 oberon_object_t
* field
;
784 field
= oberon_find_field(ctx
, rec
, name
);
786 oberon_expr_t
* selector
;
787 selector
= oberon_new_item(MODE_FIELD
, field
-> type
);
788 selector
-> item
.var
= field
;
789 selector
-> item
.parent
= (oberon_item_t
*) expr
;
794 static oberon_expr_t
*
795 oberon_designator(oberon_context_t
* ctx
)
798 oberon_object_t
* var
;
799 oberon_expr_t
* expr
;
801 name
= oberon_assert_ident(ctx
);
802 var
= oberon_find_object(ctx
-> decl
, name
);
806 case OBERON_CLASS_CONST
:
808 expr
= (oberon_expr_t
*) var
-> value
;
810 case OBERON_CLASS_VAR
:
811 case OBERON_CLASS_VAR_PARAM
:
812 case OBERON_CLASS_PARAM
:
813 expr
= oberon_new_item(MODE_VAR
, var
-> type
);
815 case OBERON_CLASS_PROC
:
816 expr
= oberon_new_item(MODE_CALL
, var
-> type
);
819 oberon_error(ctx
, "invalid designator");
822 expr
-> item
.var
= var
;
824 while(ISSELECTOR(ctx
-> token
))
829 oberon_assert_token(ctx
, DOT
);
830 name
= oberon_assert_ident(ctx
);
831 expr
= oberon_make_record_selector(ctx
, expr
, name
);
834 oberon_assert_token(ctx
, LBRACE
);
836 oberon_expr_t
* indexes
= NULL
;
837 oberon_expr_list(ctx
, &num_indexes
, &indexes
);
838 oberon_assert_token(ctx
, RBRACE
);
839 expr
= oberon_make_array_selector(ctx
, expr
, num_indexes
, indexes
);
842 oberon_error(ctx
, "oberon_designator: wat");
849 static oberon_expr_t
*
850 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
852 assert(expr
-> is_item
== 1);
854 if(ctx
-> token
== LPAREN
)
856 if(expr
-> result
-> class != OBERON_TYPE_PROCEDURE
)
858 oberon_error(ctx
, "not a procedure");
861 oberon_assert_token(ctx
, LPAREN
);
864 oberon_expr_t
* arguments
= NULL
;
866 if(ISEXPR(ctx
-> token
))
868 oberon_expr_list(ctx
, &num_args
, &arguments
);
871 expr
-> result
= expr
-> item
.var
-> type
-> base
;
872 expr
-> item
.mode
= MODE_CALL
;
873 expr
-> item
.num_args
= num_args
;
874 expr
-> item
.args
= arguments
;
875 oberon_assert_token(ctx
, RPAREN
);
877 oberon_autocast_call(ctx
, expr
);
883 static oberon_expr_t
*
884 oberon_factor(oberon_context_t
* ctx
)
886 oberon_expr_t
* expr
;
891 expr
= oberon_designator(ctx
);
892 expr
= oberon_opt_proc_parens(ctx
, expr
);
895 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
);
896 expr
-> item
.integer
= ctx
-> integer
;
897 oberon_assert_token(ctx
, INTEGER
);
900 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
901 expr
-> item
.boolean
= 1;
902 oberon_assert_token(ctx
, TRUE
);
905 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
906 expr
-> item
.boolean
= 0;
907 oberon_assert_token(ctx
, FALSE
);
910 oberon_assert_token(ctx
, LPAREN
);
911 expr
= oberon_expr(ctx
);
912 oberon_assert_token(ctx
, RPAREN
);
915 oberon_assert_token(ctx
, NOT
);
916 expr
= oberon_factor(ctx
);
917 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
920 oberon_error(ctx
, "invalid expression");
927 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
928 * 1. Классы обоих типов должны быть одинаковы
929 * 2. В качестве результата должен быть выбран больший тип.
930 * 3. Если размер результат не должен быть меньше чем базовый int
934 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
936 if((a
-> class) != (b
-> class))
938 oberon_error(ctx
, "incompatible types");
941 if((a
-> size
) > (b
-> size
))
950 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
952 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
954 *result
= ctx
-> int_type
;
958 /* TODO: cast types */
961 #define ITMAKESBOOLEAN(x) \
962 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
964 #define ITUSEONLYINTEGER(x) \
965 ((x) >= LESS && (x) <= GEQ)
967 #define ITUSEONLYBOOLEAN(x) \
968 (((x) == OR) || ((x) == AND))
970 static oberon_expr_t
*
971 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
973 oberon_expr_t
* expr
;
974 oberon_type_t
* result
;
976 if(ITMAKESBOOLEAN(token
))
978 if(ITUSEONLYINTEGER(token
))
980 if(a
-> result
-> class != OBERON_TYPE_INTEGER
981 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
983 oberon_error(ctx
, "used only with integer types");
986 else if(ITUSEONLYBOOLEAN(token
))
988 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
989 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
991 oberon_error(ctx
, "used only with boolean type");
995 result
= ctx
-> bool_type
;
999 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1001 else if(token
== NEQ
)
1003 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1005 else if(token
== LESS
)
1007 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1009 else if(token
== LEQ
)
1011 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1013 else if(token
== GREAT
)
1015 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1017 else if(token
== GEQ
)
1019 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1021 else if(token
== OR
)
1023 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1025 else if(token
== AND
)
1027 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1031 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1036 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1040 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1042 else if(token
== MINUS
)
1044 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1046 else if(token
== STAR
)
1048 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1050 else if(token
== SLASH
)
1052 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1054 else if(token
== DIV
)
1056 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1058 else if(token
== MOD
)
1060 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1064 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1071 #define ISMULOP(x) \
1072 ((x) >= STAR && (x) <= AND)
1074 static oberon_expr_t
*
1075 oberon_term_expr(oberon_context_t
* ctx
)
1077 oberon_expr_t
* expr
;
1079 expr
= oberon_factor(ctx
);
1080 while(ISMULOP(ctx
-> token
))
1082 int token
= ctx
-> token
;
1083 oberon_read_token(ctx
);
1085 oberon_expr_t
* inter
= oberon_factor(ctx
);
1086 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1092 #define ISADDOP(x) \
1093 ((x) >= PLUS && (x) <= OR)
1095 static oberon_expr_t
*
1096 oberon_simple_expr(oberon_context_t
* ctx
)
1098 oberon_expr_t
* expr
;
1101 if(ctx
-> token
== PLUS
)
1104 oberon_assert_token(ctx
, PLUS
);
1106 else if(ctx
-> token
== MINUS
)
1109 oberon_assert_token(ctx
, MINUS
);
1112 expr
= oberon_term_expr(ctx
);
1113 while(ISADDOP(ctx
-> token
))
1115 int token
= ctx
-> token
;
1116 oberon_read_token(ctx
);
1118 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1119 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1124 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1130 #define ISRELATION(x) \
1131 ((x) >= EQUAL && (x) <= GEQ)
1133 static oberon_expr_t
*
1134 oberon_expr(oberon_context_t
* ctx
)
1136 oberon_expr_t
* expr
;
1138 expr
= oberon_simple_expr(ctx
);
1139 while(ISRELATION(ctx
-> token
))
1141 int token
= ctx
-> token
;
1142 oberon_read_token(ctx
);
1144 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1145 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1151 static oberon_item_t
*
1152 oberon_const_expr(oberon_context_t
* ctx
)
1154 oberon_expr_t
* expr
;
1155 expr
= oberon_expr(ctx
);
1157 if(expr
-> is_item
== 0)
1159 oberon_error(ctx
, "const expression are required");
1162 return (oberon_item_t
*) expr
;
1165 // =======================================================================
1167 // =======================================================================
1169 static void oberon_statement_seq(oberon_context_t
* ctx
);
1172 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1174 if(ctx
-> token
!= token
)
1176 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1181 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1183 oberon_expect_token(ctx
, token
);
1184 oberon_read_token(ctx
);
1188 oberon_assert_ident(oberon_context_t
* ctx
)
1190 oberon_expect_token(ctx
, IDENT
);
1191 char * ident
= ctx
-> string
;
1192 oberon_read_token(ctx
);
1196 static oberon_type_t
*
1197 oberon_make_array_type(oberon_context_t
* ctx
, int dim
, oberon_item_t
* size
, oberon_type_t
* base
)
1200 oberon_type_t
* newtype
;
1202 if(size
-> mode
!= MODE_INTEGER
)
1204 oberon_error(ctx
, "requires integer constant");
1207 newtype
= oberon_new_type_ptr(OBERON_TYPE_ARRAY
);
1208 newtype
-> dim
= dim
;
1209 newtype
-> size
= size
-> integer
;
1210 newtype
-> base
= base
;
1211 oberon_generator_init_type(ctx
, newtype
);
1217 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1219 if(ctx
-> token
== IDENT
)
1222 oberon_type_t
* type
;
1223 name
= oberon_assert_ident(ctx
);
1224 oberon_assert_token(ctx
, COLON
);
1225 type
= oberon_type(ctx
);
1226 oberon_define_field(ctx
, rec
, name
, type
);
1230 static oberon_type_t
* oberon_opt_formal_pars(oberon_context_t
* ctx
, int class);
1232 static oberon_type_t
*
1233 oberon_type(oberon_context_t
* ctx
)
1235 oberon_type_t
* type
;
1237 if(ctx
-> token
== IDENT
)
1239 char * name
= oberon_assert_ident(ctx
);
1240 type
= oberon_find_type(ctx
-> decl
, name
);
1242 else if(ctx
-> token
== ARRAY
)
1244 oberon_assert_token(ctx
, ARRAY
);
1245 oberon_item_t
* size
= oberon_const_expr(ctx
);
1246 oberon_assert_token(ctx
, OF
);
1247 oberon_type_t
* base
= oberon_type(ctx
);
1248 type
= oberon_make_array_type(ctx
, 1, size
, base
);
1250 else if(ctx
-> token
== RECORD
)
1252 type
= oberon_new_type_ptr(OBERON_TYPE_RECORD
);
1253 oberon_object_t
* list
= malloc(sizeof *list
);
1254 memset(list
, 0, sizeof *list
);
1255 type
-> num_decl
= 0;
1256 type
-> base
= NULL
;
1257 type
-> decl
= list
;
1259 oberon_assert_token(ctx
, RECORD
);
1260 oberon_field_list(ctx
, type
);
1261 while(ctx
-> token
== SEMICOLON
)
1263 oberon_assert_token(ctx
, SEMICOLON
);
1264 oberon_field_list(ctx
, type
);
1266 oberon_assert_token(ctx
, END
);
1268 type
-> decl
= type
-> decl
-> next
;
1269 oberon_generator_init_type(ctx
, type
);
1271 else if(ctx
-> token
== PROCEDURE
)
1273 oberon_assert_token(ctx
, PROCEDURE
);
1274 type
= oberon_opt_formal_pars(ctx
, OBERON_TYPE_PROCEDURE
);
1278 oberon_error(ctx
, "invalid type declaration");
1285 oberon_var_decl(oberon_context_t
* ctx
)
1287 char * name
= oberon_assert_ident(ctx
);
1288 oberon_assert_token(ctx
, COLON
);
1289 oberon_type_t
* type
= oberon_type(ctx
);
1290 oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR
, name
, type
);
1293 static oberon_object_t
*
1294 oberon_make_param(oberon_context_t
* ctx
, int token
, char * name
, oberon_type_t
* type
)
1296 oberon_object_t
* param
;
1300 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR_PARAM
, name
, type
);
1302 else if(token
== IDENT
)
1304 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_PARAM
, name
, type
);
1308 oberon_error(ctx
, "oberon_make_param: wat");
1314 static oberon_object_t
*
1315 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1317 int modifer_token
= ctx
-> token
;
1318 if(ctx
-> token
== VAR
)
1320 oberon_read_token(ctx
);
1324 name
= oberon_assert_ident(ctx
);
1326 oberon_assert_token(ctx
, COLON
);
1328 oberon_type_t
* type
;
1329 type
= oberon_type(ctx
);
1331 oberon_object_t
* first
;
1332 first
= oberon_make_param(ctx
, modifer_token
, name
, type
);
1338 #define ISFPSECTION \
1339 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1341 static oberon_type_t
*
1342 oberon_formal_pars(oberon_context_t
* ctx
)
1345 tp
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
1347 tp
-> base
= ctx
-> void_type
;
1350 oberon_assert_token(ctx
, LPAREN
);
1354 tp
-> decl
= oberon_fp_section(ctx
, &tp
-> num_decl
);
1355 while(ctx
-> token
== SEMICOLON
)
1357 oberon_assert_token(ctx
, SEMICOLON
);
1358 oberon_fp_section(ctx
, &tp
-> num_decl
);
1362 oberon_assert_token(ctx
, RPAREN
);
1364 if(ctx
-> token
== COLON
)
1366 oberon_assert_token(ctx
, COLON
);
1367 tp
-> base
= oberon_type(ctx
);
1370 oberon_generator_init_type(ctx
, tp
);
1374 static oberon_type_t
*
1375 oberon_opt_formal_pars(oberon_context_t
* ctx
, int class)
1377 oberon_type_t
* signature
;
1379 if(ctx
-> token
== LPAREN
)
1381 signature
= oberon_formal_pars(ctx
);
1385 signature
= oberon_new_type_ptr(class);
1386 signature
-> num_decl
= 0;
1387 signature
-> base
= ctx
-> void_type
;
1388 signature
-> decl
= NULL
;
1389 oberon_generator_init_type(ctx
, signature
);
1396 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1398 if(ctx
-> result_type
-> class == OBERON_TYPE_VOID
)
1402 oberon_error(ctx
, "procedure has no result type");
1409 oberon_error(ctx
, "procedure requires expression on result");
1412 oberon_autocast_to(ctx
, expr
, ctx
-> result_type
);
1415 ctx
-> has_return
= 1;
1417 oberon_generate_return(ctx
, expr
);
1421 oberon_proc_decl(oberon_context_t
* ctx
)
1423 oberon_assert_token(ctx
, PROCEDURE
);
1426 name
= oberon_assert_ident(ctx
);
1428 oberon_scope_t
* this_proc_def_scope
= ctx
-> decl
;
1429 oberon_open_scope(ctx
);
1431 oberon_type_t
* signature
;
1432 signature
= oberon_opt_formal_pars(ctx
, OBERON_TYPE_PROCEDURE
);
1434 oberon_object_t
* proc
;
1435 proc
= oberon_define_proc(this_proc_def_scope
, name
, signature
);
1437 ctx
-> result_type
= signature
-> base
;
1438 ctx
-> has_return
= 0;
1440 oberon_assert_token(ctx
, SEMICOLON
);
1442 oberon_generate_begin_proc(ctx
, proc
);
1444 // TODO declarations
1446 if(ctx
-> token
== BEGIN
)
1448 oberon_assert_token(ctx
, BEGIN
);
1449 oberon_statement_seq(ctx
);
1452 oberon_assert_token(ctx
, END
);
1453 char * name2
= oberon_assert_ident(ctx
);
1454 if(strcmp(name2
, name
) != 0)
1456 oberon_error(ctx
, "procedure name not matched");
1459 if(signature
-> base
-> class == OBERON_TYPE_VOID
)
1461 oberon_make_return(ctx
, NULL
);
1464 if(ctx
-> has_return
== 0)
1466 oberon_error(ctx
, "procedure requires return");
1468 ctx
-> result_type
= NULL
;
1470 oberon_generate_end_proc(ctx
);
1471 oberon_close_scope(ctx
-> decl
);
1475 oberon_const_decl(oberon_context_t
* ctx
)
1478 oberon_item_t
* value
;
1479 oberon_object_t
* constant
;
1481 name
= oberon_assert_ident(ctx
);
1482 oberon_assert_token(ctx
, EQUAL
);
1483 value
= oberon_const_expr(ctx
);
1485 constant
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_CONST
);
1486 constant
-> value
= value
;
1490 oberon_type_decl(oberon_context_t
* ctx
)
1493 oberon_object_t
* newtype
;
1494 oberon_type_t
* type
;
1496 name
= oberon_assert_ident(ctx
);
1497 oberon_assert_token(ctx
, EQUAL
);
1498 type
= oberon_type(ctx
);
1500 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
);
1501 newtype
-> type
= type
;
1505 oberon_decl_seq(oberon_context_t
* ctx
)
1507 if(ctx
-> token
== CONST
)
1509 oberon_assert_token(ctx
, CONST
);
1510 while(ctx
-> token
== IDENT
)
1512 oberon_const_decl(ctx
);
1513 oberon_assert_token(ctx
, SEMICOLON
);
1517 if(ctx
-> token
== TYPE
)
1519 oberon_assert_token(ctx
, TYPE
);
1520 while(ctx
-> token
== IDENT
)
1522 oberon_type_decl(ctx
);
1523 oberon_assert_token(ctx
, SEMICOLON
);
1527 if(ctx
-> token
== VAR
)
1529 oberon_assert_token(ctx
, VAR
);
1530 while(ctx
-> token
== IDENT
)
1532 oberon_var_decl(ctx
);
1533 oberon_assert_token(ctx
, SEMICOLON
);
1537 while(ctx
-> token
== PROCEDURE
)
1539 oberon_proc_decl(ctx
);
1540 oberon_assert_token(ctx
, SEMICOLON
);
1545 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
1547 oberon_autocast_to(ctx
, src
, dst
-> result
);
1548 oberon_generate_assign(ctx
, src
, dst
);
1552 oberon_make_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
1554 oberon_autocast_call(ctx
, desig
);
1555 oberon_generate_call_proc(ctx
, desig
);
1559 oberon_statement(oberon_context_t
* ctx
)
1561 oberon_expr_t
* item1
;
1562 oberon_expr_t
* item2
;
1564 if(ctx
-> token
== IDENT
)
1566 item1
= oberon_designator(ctx
);
1567 if(ctx
-> token
== ASSIGN
)
1569 oberon_assert_token(ctx
, ASSIGN
);
1570 item2
= oberon_expr(ctx
);
1571 oberon_assign(ctx
, item2
, item1
);
1575 item1
= oberon_opt_proc_parens(ctx
, item1
);
1576 oberon_make_call(ctx
, item1
);
1579 else if(ctx
-> token
== RETURN
)
1581 oberon_assert_token(ctx
, RETURN
);
1582 if(ISEXPR(ctx
-> token
))
1584 oberon_expr_t
* expr
;
1585 expr
= oberon_expr(ctx
);
1586 oberon_make_return(ctx
, expr
);
1590 oberon_make_return(ctx
, NULL
);
1596 oberon_statement_seq(oberon_context_t
* ctx
)
1598 oberon_statement(ctx
);
1599 while(ctx
-> token
== SEMICOLON
)
1601 oberon_assert_token(ctx
, SEMICOLON
);
1602 oberon_statement(ctx
);
1607 oberon_parse_module(oberon_context_t
* ctx
)
1609 char *name1
, *name2
;
1610 oberon_read_token(ctx
);
1612 oberon_assert_token(ctx
, MODULE
);
1613 name1
= oberon_assert_ident(ctx
);
1614 oberon_assert_token(ctx
, SEMICOLON
);
1615 ctx
-> mod
-> name
= name1
;
1617 oberon_decl_seq(ctx
);
1619 if(ctx
-> token
== BEGIN
)
1621 oberon_assert_token(ctx
, BEGIN
);
1622 oberon_generate_begin_module(ctx
);
1623 oberon_statement_seq(ctx
);
1624 oberon_generate_end_module(ctx
);
1627 oberon_assert_token(ctx
, END
);
1628 name2
= oberon_assert_ident(ctx
);
1629 oberon_assert_token(ctx
, DOT
);
1631 if(strcmp(name1
, name2
) != 0)
1633 oberon_error(ctx
, "module name not matched");
1637 // =======================================================================
1639 // =======================================================================
1642 register_default_types(oberon_context_t
* ctx
)
1644 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1645 oberon_generator_init_type(ctx
, ctx
-> void_type
);
1647 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
1648 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
);
1650 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
1651 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
);
1655 oberon_create_context()
1657 oberon_context_t
* ctx
= malloc(sizeof *ctx
);
1658 memset(ctx
, 0, sizeof *ctx
);
1660 oberon_scope_t
* world_scope
;
1661 world_scope
= oberon_open_scope(ctx
);
1662 ctx
-> world_scope
= world_scope
;
1664 oberon_generator_init_context(ctx
);
1666 register_default_types(ctx
);
1672 oberon_destroy_context(oberon_context_t
* ctx
)
1674 oberon_generator_destroy_context(ctx
);
1679 oberon_compile_module(oberon_context_t
* ctx
, const char * code
)
1681 oberon_module_t
* mod
= malloc(sizeof *mod
);
1682 memset(mod
, 0, sizeof *mod
);
1685 oberon_scope_t
* module_scope
;
1686 module_scope
= oberon_open_scope(ctx
);
1687 mod
-> decl
= module_scope
;
1689 oberon_init_scaner(ctx
, code
);
1690 oberon_parse_module(ctx
);
1692 oberon_generate_code(ctx
);