2b4e09f5e8a3ca7e95e4923a6d4773fa9e5202bf
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");
663 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
665 if(desig
-> is_item
== 0)
667 oberon_error(ctx
, "expected item");
670 if(desig
-> item
.mode
!= MODE_CALL
)
672 oberon_error(ctx
, "expected mode CALL");
675 if(desig
-> item
.var
-> class != OBERON_CLASS_PROC
)
677 oberon_error(ctx
, "only procedures can be called");
680 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
681 int num_args
= desig
-> item
.num_args
;
682 int num_decl
= fn
-> num_decl
;
684 if(num_args
< num_decl
)
686 oberon_error(ctx
, "too few arguments");
688 else if(num_args
> num_decl
)
690 oberon_error(ctx
, "too many arguments");
693 oberon_expr_t
* arg
= desig
-> item
.args
;
694 oberon_object_t
* param
= fn
-> decl
;
695 for(int i
= 0; i
< num_args
; i
++)
697 oberon_autocast_to(ctx
, arg
, param
-> type
);
699 param
= param
-> next
;
707 || ((x) == INTEGER) \
713 #define ISSELECTOR(x) \
717 static oberon_expr_t
*
718 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, int num_indexes
, oberon_expr_t
* indexes
)
720 assert(desig
-> is_item
== 1);
722 if(desig
-> item
.mode
!= MODE_VAR
)
724 oberon_error(ctx
, "not MODE_VAR");
727 int class = desig
-> item
.var
-> class;
730 case OBERON_CLASS_VAR
:
731 case OBERON_CLASS_VAR_PARAM
:
732 case OBERON_CLASS_PARAM
:
735 oberon_error(ctx
, "not variable");
739 oberon_type_t
* type
= desig
-> item
.var
-> type
;
740 if(type
-> class != OBERON_TYPE_ARRAY
)
742 oberon_error(ctx
, "not array");
745 int dim
= desig
-> item
.var
-> type
-> dim
;
746 if(num_indexes
!= dim
)
748 oberon_error(ctx
, "dimesions not matched");
751 oberon_type_t
* base
= desig
-> item
.var
-> type
-> base
;
753 oberon_expr_t
* selector
;
754 selector
= oberon_new_item(MODE_INDEX
, base
);
755 selector
-> item
.parent
= (oberon_item_t
*) desig
;
756 selector
-> item
.num_args
= num_indexes
;
757 selector
-> item
.args
= indexes
;
762 static oberon_expr_t
*
763 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
765 assert(expr
-> is_item
== 1);
767 int class = expr
-> result
-> class;
768 if(class != OBERON_TYPE_RECORD
)
770 oberon_error(ctx
, "not record");
773 oberon_type_t
* rec
= expr
-> result
;
775 oberon_object_t
* field
;
776 field
= oberon_find_field(ctx
, rec
, name
);
778 oberon_expr_t
* selector
;
779 selector
= oberon_new_item(MODE_FIELD
, field
-> type
);
780 selector
-> item
.var
= field
;
781 selector
-> item
.parent
= (oberon_item_t
*) expr
;
786 static oberon_expr_t
*
787 oberon_designator(oberon_context_t
* ctx
)
790 oberon_object_t
* var
;
791 oberon_expr_t
* expr
;
793 name
= oberon_assert_ident(ctx
);
794 var
= oberon_find_object(ctx
-> decl
, name
);
798 case OBERON_CLASS_CONST
:
800 expr
= (oberon_expr_t
*) var
-> value
;
802 case OBERON_CLASS_VAR
:
803 case OBERON_CLASS_VAR_PARAM
:
804 case OBERON_CLASS_PARAM
:
805 expr
= oberon_new_item(MODE_VAR
, var
-> type
);
807 case OBERON_CLASS_PROC
:
808 expr
= oberon_new_item(MODE_CALL
, var
-> type
);
811 oberon_error(ctx
, "invalid designator");
814 expr
-> item
.var
= var
;
816 while(ISSELECTOR(ctx
-> token
))
821 oberon_assert_token(ctx
, DOT
);
822 name
= oberon_assert_ident(ctx
);
823 expr
= oberon_make_record_selector(ctx
, expr
, name
);
826 oberon_assert_token(ctx
, LBRACE
);
828 oberon_expr_t
* indexes
= NULL
;
829 oberon_expr_list(ctx
, &num_indexes
, &indexes
);
830 oberon_assert_token(ctx
, RBRACE
);
831 expr
= oberon_make_array_selector(ctx
, expr
, num_indexes
, indexes
);
834 oberon_error(ctx
, "oberon_designator: wat");
841 static oberon_expr_t
*
842 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
844 assert(expr
-> is_item
== 1);
846 if(ctx
-> token
== LPAREN
)
848 if(expr
-> result
-> class != OBERON_TYPE_PROCEDURE
)
850 oberon_error(ctx
, "not a procedure");
853 oberon_assert_token(ctx
, LPAREN
);
856 oberon_expr_t
* arguments
= NULL
;
858 if(ISEXPR(ctx
-> token
))
860 oberon_expr_list(ctx
, &num_args
, &arguments
);
863 expr
-> result
= expr
-> item
.var
-> type
-> base
;
864 expr
-> item
.mode
= MODE_CALL
;
865 expr
-> item
.num_args
= num_args
;
866 expr
-> item
.args
= arguments
;
867 oberon_assert_token(ctx
, RPAREN
);
869 oberon_autocast_call(ctx
, expr
);
875 static oberon_expr_t
*
876 oberon_factor(oberon_context_t
* ctx
)
878 oberon_expr_t
* expr
;
883 expr
= oberon_designator(ctx
);
884 expr
= oberon_opt_proc_parens(ctx
, expr
);
887 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
);
888 expr
-> item
.integer
= ctx
-> integer
;
889 oberon_assert_token(ctx
, INTEGER
);
892 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
893 expr
-> item
.boolean
= 1;
894 oberon_assert_token(ctx
, TRUE
);
897 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
898 expr
-> item
.boolean
= 0;
899 oberon_assert_token(ctx
, FALSE
);
902 oberon_assert_token(ctx
, LPAREN
);
903 expr
= oberon_expr(ctx
);
904 oberon_assert_token(ctx
, RPAREN
);
907 oberon_assert_token(ctx
, NOT
);
908 expr
= oberon_factor(ctx
);
909 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
912 oberon_error(ctx
, "invalid expression");
919 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
920 * 1. Классы обоих типов должны быть одинаковы
921 * 2. В качестве результата должен быть выбран больший тип.
922 * 3. Если размер результат не должен быть меньше чем базовый int
926 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
928 if((a
-> class) != (b
-> class))
930 oberon_error(ctx
, "incompatible types");
933 if((a
-> size
) > (b
-> size
))
942 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
944 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
946 *result
= ctx
-> int_type
;
950 /* TODO: cast types */
953 #define ITMAKESBOOLEAN(x) \
954 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
956 #define ITUSEONLYINTEGER(x) \
957 ((x) >= LESS && (x) <= GEQ)
959 #define ITUSEONLYBOOLEAN(x) \
960 (((x) == OR) || ((x) == AND))
962 static oberon_expr_t
*
963 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
965 oberon_expr_t
* expr
;
966 oberon_type_t
* result
;
968 if(ITMAKESBOOLEAN(token
))
970 if(ITUSEONLYINTEGER(token
))
972 if(a
-> result
-> class != OBERON_TYPE_INTEGER
973 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
975 oberon_error(ctx
, "used only with integer types");
978 else if(ITUSEONLYBOOLEAN(token
))
980 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
981 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
983 oberon_error(ctx
, "used only with boolean type");
987 result
= ctx
-> bool_type
;
991 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
993 else if(token
== NEQ
)
995 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
997 else if(token
== LESS
)
999 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1001 else if(token
== LEQ
)
1003 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1005 else if(token
== GREAT
)
1007 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1009 else if(token
== GEQ
)
1011 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1013 else if(token
== OR
)
1015 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1017 else if(token
== AND
)
1019 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1023 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1028 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1032 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1034 else if(token
== MINUS
)
1036 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1038 else if(token
== STAR
)
1040 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1042 else if(token
== SLASH
)
1044 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1046 else if(token
== DIV
)
1048 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1050 else if(token
== MOD
)
1052 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1056 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1063 #define ISMULOP(x) \
1064 ((x) >= STAR && (x) <= AND)
1066 static oberon_expr_t
*
1067 oberon_term_expr(oberon_context_t
* ctx
)
1069 oberon_expr_t
* expr
;
1071 expr
= oberon_factor(ctx
);
1072 while(ISMULOP(ctx
-> token
))
1074 int token
= ctx
-> token
;
1075 oberon_read_token(ctx
);
1077 oberon_expr_t
* inter
= oberon_factor(ctx
);
1078 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1084 #define ISADDOP(x) \
1085 ((x) >= PLUS && (x) <= OR)
1087 static oberon_expr_t
*
1088 oberon_simple_expr(oberon_context_t
* ctx
)
1090 oberon_expr_t
* expr
;
1093 if(ctx
-> token
== PLUS
)
1096 oberon_assert_token(ctx
, PLUS
);
1098 else if(ctx
-> token
== MINUS
)
1101 oberon_assert_token(ctx
, MINUS
);
1104 expr
= oberon_term_expr(ctx
);
1105 while(ISADDOP(ctx
-> token
))
1107 int token
= ctx
-> token
;
1108 oberon_read_token(ctx
);
1110 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1111 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1116 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1122 #define ISRELATION(x) \
1123 ((x) >= EQUAL && (x) <= GEQ)
1125 static oberon_expr_t
*
1126 oberon_expr(oberon_context_t
* ctx
)
1128 oberon_expr_t
* expr
;
1130 expr
= oberon_simple_expr(ctx
);
1131 while(ISRELATION(ctx
-> token
))
1133 int token
= ctx
-> token
;
1134 oberon_read_token(ctx
);
1136 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1137 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1143 static oberon_item_t
*
1144 oberon_const_expr(oberon_context_t
* ctx
)
1146 oberon_expr_t
* expr
;
1147 expr
= oberon_expr(ctx
);
1149 if(expr
-> is_item
== 0)
1151 oberon_error(ctx
, "const expression are required");
1154 return (oberon_item_t
*) expr
;
1157 // =======================================================================
1159 // =======================================================================
1161 static void oberon_statement_seq(oberon_context_t
* ctx
);
1164 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1166 if(ctx
-> token
!= token
)
1168 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1173 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1175 oberon_expect_token(ctx
, token
);
1176 oberon_read_token(ctx
);
1180 oberon_assert_ident(oberon_context_t
* ctx
)
1182 oberon_expect_token(ctx
, IDENT
);
1183 char * ident
= ctx
-> string
;
1184 oberon_read_token(ctx
);
1188 static oberon_type_t
*
1189 oberon_make_array_type(oberon_context_t
* ctx
, int dim
, oberon_item_t
* size
, oberon_type_t
* base
)
1192 oberon_type_t
* newtype
;
1194 if(size
-> mode
!= MODE_INTEGER
)
1196 oberon_error(ctx
, "requires integer constant");
1199 newtype
= oberon_new_type_ptr(OBERON_TYPE_ARRAY
);
1200 newtype
-> dim
= dim
;
1201 newtype
-> size
= size
-> integer
;
1202 newtype
-> base
= base
;
1203 oberon_generator_init_type(ctx
, newtype
);
1209 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1211 if(ctx
-> token
== IDENT
)
1214 oberon_type_t
* type
;
1215 name
= oberon_assert_ident(ctx
);
1216 oberon_assert_token(ctx
, COLON
);
1217 type
= oberon_type(ctx
);
1218 oberon_define_field(ctx
, rec
, name
, type
);
1222 static oberon_type_t
* oberon_opt_formal_pars(oberon_context_t
* ctx
, int class);
1224 static oberon_type_t
*
1225 oberon_type(oberon_context_t
* ctx
)
1227 oberon_type_t
* type
;
1229 if(ctx
-> token
== IDENT
)
1231 char * name
= oberon_assert_ident(ctx
);
1232 type
= oberon_find_type(ctx
-> decl
, name
);
1234 else if(ctx
-> token
== ARRAY
)
1236 oberon_assert_token(ctx
, ARRAY
);
1237 oberon_item_t
* size
= oberon_const_expr(ctx
);
1238 oberon_assert_token(ctx
, OF
);
1239 oberon_type_t
* base
= oberon_type(ctx
);
1240 type
= oberon_make_array_type(ctx
, 1, size
, base
);
1242 else if(ctx
-> token
== RECORD
)
1244 type
= oberon_new_type_ptr(OBERON_TYPE_RECORD
);
1245 oberon_object_t
* list
= malloc(sizeof *list
);
1246 memset(list
, 0, sizeof *list
);
1247 type
-> num_decl
= 0;
1248 type
-> base
= NULL
;
1249 type
-> decl
= list
;
1251 oberon_assert_token(ctx
, RECORD
);
1252 oberon_field_list(ctx
, type
);
1253 while(ctx
-> token
== SEMICOLON
)
1255 oberon_assert_token(ctx
, SEMICOLON
);
1256 oberon_field_list(ctx
, type
);
1258 oberon_assert_token(ctx
, END
);
1260 type
-> decl
= type
-> decl
-> next
;
1261 oberon_generator_init_type(ctx
, type
);
1263 else if(ctx
-> token
== PROCEDURE
)
1265 oberon_assert_token(ctx
, PROCEDURE
);
1266 type
= oberon_opt_formal_pars(ctx
, OBERON_TYPE_PROCEDURE
);
1270 oberon_error(ctx
, "invalid type declaration");
1277 oberon_var_decl(oberon_context_t
* ctx
)
1279 char * name
= oberon_assert_ident(ctx
);
1280 oberon_assert_token(ctx
, COLON
);
1281 oberon_type_t
* type
= oberon_type(ctx
);
1282 oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR
, name
, type
);
1285 static oberon_object_t
*
1286 oberon_make_param(oberon_context_t
* ctx
, int token
, char * name
, oberon_type_t
* type
)
1288 oberon_object_t
* param
;
1292 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR_PARAM
, name
, type
);
1294 else if(token
== IDENT
)
1296 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_PARAM
, name
, type
);
1300 oberon_error(ctx
, "oberon_make_param: wat");
1306 static oberon_object_t
*
1307 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1309 int modifer_token
= ctx
-> token
;
1310 if(ctx
-> token
== VAR
)
1312 oberon_read_token(ctx
);
1316 name
= oberon_assert_ident(ctx
);
1318 oberon_assert_token(ctx
, COLON
);
1320 oberon_type_t
* type
;
1321 type
= oberon_type(ctx
);
1323 oberon_object_t
* first
;
1324 first
= oberon_make_param(ctx
, modifer_token
, name
, type
);
1330 #define ISFPSECTION \
1331 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1333 static oberon_type_t
*
1334 oberon_formal_pars(oberon_context_t
* ctx
)
1337 tp
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
1339 tp
-> base
= ctx
-> void_type
;
1342 oberon_assert_token(ctx
, LPAREN
);
1346 tp
-> decl
= oberon_fp_section(ctx
, &tp
-> num_decl
);
1347 while(ctx
-> token
== SEMICOLON
)
1349 oberon_assert_token(ctx
, SEMICOLON
);
1350 oberon_fp_section(ctx
, &tp
-> num_decl
);
1354 oberon_assert_token(ctx
, RPAREN
);
1356 if(ctx
-> token
== COLON
)
1358 oberon_assert_token(ctx
, COLON
);
1359 tp
-> base
= oberon_type(ctx
);
1362 oberon_generator_init_type(ctx
, tp
);
1366 static oberon_type_t
*
1367 oberon_opt_formal_pars(oberon_context_t
* ctx
, int class)
1369 oberon_type_t
* signature
;
1371 if(ctx
-> token
== LPAREN
)
1373 signature
= oberon_formal_pars(ctx
);
1377 signature
= oberon_new_type_ptr(class);
1378 signature
-> num_decl
= 0;
1379 signature
-> base
= ctx
-> void_type
;
1380 signature
-> decl
= NULL
;
1381 oberon_generator_init_type(ctx
, signature
);
1388 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1390 if(ctx
-> result_type
-> class == OBERON_TYPE_VOID
)
1394 oberon_error(ctx
, "procedure has no result type");
1401 oberon_error(ctx
, "procedure requires expression on result");
1404 oberon_autocast_to(ctx
, expr
, ctx
-> result_type
);
1407 ctx
-> has_return
= 1;
1409 oberon_generate_return(ctx
, expr
);
1413 oberon_proc_decl(oberon_context_t
* ctx
)
1415 oberon_assert_token(ctx
, PROCEDURE
);
1418 name
= oberon_assert_ident(ctx
);
1420 oberon_scope_t
* this_proc_def_scope
= ctx
-> decl
;
1421 oberon_open_scope(ctx
);
1423 oberon_type_t
* signature
;
1424 signature
= oberon_opt_formal_pars(ctx
, OBERON_TYPE_PROCEDURE
);
1426 oberon_object_t
* proc
;
1427 proc
= oberon_define_proc(this_proc_def_scope
, name
, signature
);
1429 ctx
-> result_type
= signature
-> base
;
1430 ctx
-> has_return
= 0;
1432 oberon_assert_token(ctx
, SEMICOLON
);
1434 oberon_generate_begin_proc(ctx
, proc
);
1436 // TODO declarations
1438 if(ctx
-> token
== BEGIN
)
1440 oberon_assert_token(ctx
, BEGIN
);
1441 oberon_statement_seq(ctx
);
1444 oberon_assert_token(ctx
, END
);
1445 char * name2
= oberon_assert_ident(ctx
);
1446 if(strcmp(name2
, name
) != 0)
1448 oberon_error(ctx
, "procedure name not matched");
1451 if(signature
-> base
-> class == OBERON_TYPE_VOID
)
1453 oberon_make_return(ctx
, NULL
);
1456 if(ctx
-> has_return
== 0)
1458 oberon_error(ctx
, "procedure requires return");
1460 ctx
-> result_type
= NULL
;
1462 oberon_generate_end_proc(ctx
);
1463 oberon_close_scope(ctx
-> decl
);
1467 oberon_const_decl(oberon_context_t
* ctx
)
1470 oberon_item_t
* value
;
1471 oberon_object_t
* constant
;
1473 name
= oberon_assert_ident(ctx
);
1474 oberon_assert_token(ctx
, EQUAL
);
1475 value
= oberon_const_expr(ctx
);
1477 constant
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_CONST
);
1478 constant
-> value
= value
;
1482 oberon_type_decl(oberon_context_t
* ctx
)
1485 oberon_object_t
* newtype
;
1486 oberon_type_t
* type
;
1488 name
= oberon_assert_ident(ctx
);
1489 oberon_assert_token(ctx
, EQUAL
);
1490 type
= oberon_type(ctx
);
1492 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
);
1493 newtype
-> type
= type
;
1497 oberon_decl_seq(oberon_context_t
* ctx
)
1499 if(ctx
-> token
== CONST
)
1501 oberon_assert_token(ctx
, CONST
);
1502 while(ctx
-> token
== IDENT
)
1504 oberon_const_decl(ctx
);
1505 oberon_assert_token(ctx
, SEMICOLON
);
1509 if(ctx
-> token
== TYPE
)
1511 oberon_assert_token(ctx
, TYPE
);
1512 while(ctx
-> token
== IDENT
)
1514 oberon_type_decl(ctx
);
1515 oberon_assert_token(ctx
, SEMICOLON
);
1519 if(ctx
-> token
== VAR
)
1521 oberon_assert_token(ctx
, VAR
);
1522 while(ctx
-> token
== IDENT
)
1524 oberon_var_decl(ctx
);
1525 oberon_assert_token(ctx
, SEMICOLON
);
1529 while(ctx
-> token
== PROCEDURE
)
1531 oberon_proc_decl(ctx
);
1532 oberon_assert_token(ctx
, SEMICOLON
);
1537 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
1539 oberon_autocast_to(ctx
, src
, dst
-> result
);
1540 oberon_generate_assign(ctx
, src
, dst
);
1544 oberon_make_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
1546 oberon_autocast_call(ctx
, desig
);
1547 oberon_generate_call_proc(ctx
, desig
);
1551 oberon_statement(oberon_context_t
* ctx
)
1553 oberon_expr_t
* item1
;
1554 oberon_expr_t
* item2
;
1556 if(ctx
-> token
== IDENT
)
1558 item1
= oberon_designator(ctx
);
1559 if(ctx
-> token
== ASSIGN
)
1561 oberon_assert_token(ctx
, ASSIGN
);
1562 item2
= oberon_expr(ctx
);
1563 oberon_assign(ctx
, item2
, item1
);
1567 item1
= oberon_opt_proc_parens(ctx
, item1
);
1568 oberon_make_call(ctx
, item1
);
1571 else if(ctx
-> token
== RETURN
)
1573 oberon_assert_token(ctx
, RETURN
);
1574 if(ISEXPR(ctx
-> token
))
1576 oberon_expr_t
* expr
;
1577 expr
= oberon_expr(ctx
);
1578 oberon_make_return(ctx
, expr
);
1582 oberon_make_return(ctx
, NULL
);
1588 oberon_statement_seq(oberon_context_t
* ctx
)
1590 oberon_statement(ctx
);
1591 while(ctx
-> token
== SEMICOLON
)
1593 oberon_assert_token(ctx
, SEMICOLON
);
1594 oberon_statement(ctx
);
1599 oberon_parse_module(oberon_context_t
* ctx
)
1601 char *name1
, *name2
;
1602 oberon_read_token(ctx
);
1604 oberon_assert_token(ctx
, MODULE
);
1605 name1
= oberon_assert_ident(ctx
);
1606 oberon_assert_token(ctx
, SEMICOLON
);
1607 ctx
-> mod
-> name
= name1
;
1609 oberon_decl_seq(ctx
);
1611 if(ctx
-> token
== BEGIN
)
1613 oberon_assert_token(ctx
, BEGIN
);
1614 oberon_generate_begin_module(ctx
);
1615 oberon_statement_seq(ctx
);
1616 oberon_generate_end_module(ctx
);
1619 oberon_assert_token(ctx
, END
);
1620 name2
= oberon_assert_ident(ctx
);
1621 oberon_assert_token(ctx
, DOT
);
1623 if(strcmp(name1
, name2
) != 0)
1625 oberon_error(ctx
, "module name not matched");
1629 // =======================================================================
1631 // =======================================================================
1634 register_default_types(oberon_context_t
* ctx
)
1636 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1637 oberon_generator_init_type(ctx
, ctx
-> void_type
);
1639 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
1640 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
);
1642 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
1643 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
);
1647 oberon_create_context()
1649 oberon_context_t
* ctx
= malloc(sizeof *ctx
);
1650 memset(ctx
, 0, sizeof *ctx
);
1652 oberon_scope_t
* world_scope
;
1653 world_scope
= oberon_open_scope(ctx
);
1654 ctx
-> world_scope
= world_scope
;
1656 oberon_generator_init_context(ctx
);
1658 register_default_types(ctx
);
1664 oberon_destroy_context(oberon_context_t
* ctx
)
1666 oberon_generator_destroy_context(ctx
);
1671 oberon_compile_module(oberon_context_t
* ctx
, const char * code
)
1673 oberon_module_t
* mod
= malloc(sizeof *mod
);
1674 memset(mod
, 0, sizeof *mod
);
1677 oberon_scope_t
* module_scope
;
1678 module_scope
= oberon_open_scope(ctx
);
1679 mod
-> decl
= module_scope
;
1681 oberon_init_scaner(ctx
, code
);
1682 oberon_parse_module(ctx
);
1684 oberon_generate_code(ctx
);