7ca600e205a26e377f25bea0de64ff7ad0c758cf
56 // =======================================================================
58 // =======================================================================
61 oberon_error(oberon_context_t
* ctx
, const char * fmt
, ...)
65 fprintf(stderr
, "error: ");
66 vfprintf(stderr
, fmt
, ptr
);
67 fprintf(stderr
, "\n");
68 fprintf(stderr
, " code_index = %i\n", ctx
-> code_index
);
69 fprintf(stderr
, " c = %c\n", ctx
-> c
);
70 fprintf(stderr
, " token = %i\n", ctx
-> token
);
75 static oberon_type_t
*
76 oberon_new_type_ptr(int class)
78 oberon_type_t
* x
= malloc(sizeof *x
);
79 memset(x
, 0, sizeof *x
);
84 static oberon_type_t
*
85 oberon_new_type_integer(int size
)
88 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
93 static oberon_type_t
*
94 oberon_new_type_boolean(int size
)
97 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
102 // =======================================================================
104 // =======================================================================
106 static oberon_scope_t
*
107 oberon_open_scope(oberon_context_t
* ctx
)
109 oberon_scope_t
* scope
= malloc(sizeof *scope
);
110 memset(scope
, 0, sizeof *scope
);
112 oberon_object_t
* list
= malloc(sizeof *list
);
113 memset(list
, 0, sizeof *list
);
116 scope
-> list
= list
;
117 scope
-> up
= ctx
-> decl
;
124 oberon_close_scope(oberon_scope_t
* scope
)
126 oberon_context_t
* ctx
= scope
-> ctx
;
127 ctx
-> decl
= scope
-> up
;
130 static oberon_object_t
*
131 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class)
133 oberon_object_t
* x
= scope
-> list
;
134 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
141 oberon_error(scope
-> ctx
, "already defined");
144 oberon_object_t
* newvar
= malloc(sizeof *newvar
);
145 memset(newvar
, 0, sizeof *newvar
);
146 newvar
-> name
= name
;
147 newvar
-> class = class;
155 oberon_define_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
, oberon_type_t
* type
)
157 oberon_object_t
* x
= rec
-> decl
;
158 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
165 oberon_error(ctx
, "multiple definition");
168 oberon_object_t
* field
= malloc(sizeof *field
);
169 memset(field
, 0, sizeof *field
);
170 field
-> name
= name
;
171 field
-> class = OBERON_CLASS_FIELD
;
172 field
-> type
= type
;
174 rec
-> num_decl
+= 1;
175 oberon_generator_init_var(ctx
, field
);
180 static oberon_object_t
*
181 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
183 oberon_object_t
* x
= list
;
184 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
191 static oberon_object_t
*
192 oberon_find_object(oberon_scope_t
* scope
, char * name
)
194 oberon_object_t
* result
= NULL
;
196 oberon_scope_t
* s
= scope
;
197 while(result
== NULL
&& s
!= NULL
)
199 result
= oberon_find_object_in_list(s
-> list
, name
);
205 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
211 static oberon_object_t
*
212 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
214 oberon_object_t
* x
= rec
-> decl
;
215 for(int i
= 0; i
< rec
-> num_decl
; i
++)
217 if(strcmp(x
-> name
, name
) == 0)
224 oberon_error(ctx
, "field not defined");
229 static oberon_object_t
*
230 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
)
232 oberon_object_t
* id
;
233 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
);
235 oberon_generator_init_type(scope
-> ctx
, type
);
239 static oberon_type_t
*
240 oberon_find_type(oberon_scope_t
* scope
, char * name
)
242 oberon_object_t
* x
= oberon_find_object(scope
, name
);
243 if(x
-> class != OBERON_CLASS_TYPE
)
245 oberon_error(scope
-> ctx
, "%s not a type", name
);
251 static oberon_object_t
*
252 oberon_define_var(oberon_scope_t
* scope
, int class, char * name
, oberon_type_t
* type
)
254 oberon_object_t
* var
;
255 var
= oberon_define_object(scope
, name
, class);
257 oberon_generator_init_var(scope
-> ctx
, var
);
262 static oberon_object_t *
263 oberon_find_var(oberon_scope_t * scope, char * name)
265 oberon_object_t * x = oberon_find_object(scope, name);
267 if(x -> class != OBERON_CLASS_VAR)
269 oberon_error(scope -> ctx, "%s not a var", name);
276 static oberon_object_t
*
277 oberon_define_proc(oberon_scope_t
* scope
, char * name
, oberon_type_t
* signature
)
279 oberon_object_t
* proc
;
280 proc
= oberon_define_object(scope
, name
, OBERON_CLASS_PROC
);
281 proc
-> type
= signature
;
282 oberon_generator_init_proc(scope
-> ctx
, proc
);
286 // =======================================================================
288 // =======================================================================
291 oberon_get_char(oberon_context_t
* ctx
)
293 ctx
-> code_index
+= 1;
294 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
298 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
301 ctx
-> code_index
= 0;
302 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
306 oberon_read_ident(oberon_context_t
* ctx
)
309 int i
= ctx
-> code_index
;
311 int c
= ctx
-> code
[i
];
319 char * ident
= malloc(len
+ 1);
320 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
323 ctx
-> code_index
= i
;
324 ctx
-> c
= ctx
-> code
[i
];
325 ctx
-> string
= ident
;
326 ctx
-> token
= IDENT
;
328 if(strcmp(ident
, "MODULE") == 0)
330 ctx
-> token
= MODULE
;
332 else if(strcmp(ident
, "END") == 0)
336 else if(strcmp(ident
, "VAR") == 0)
340 else if(strcmp(ident
, "BEGIN") == 0)
342 ctx
-> token
= BEGIN
;
344 else if(strcmp(ident
, "TRUE") == 0)
348 else if(strcmp(ident
, "FALSE") == 0)
350 ctx
-> token
= FALSE
;
352 else if(strcmp(ident
, "OR") == 0)
356 else if(strcmp(ident
, "DIV") == 0)
360 else if(strcmp(ident
, "MOD") == 0)
364 else if(strcmp(ident
, "PROCEDURE") == 0)
366 ctx
-> token
= PROCEDURE
;
368 else if(strcmp(ident
, "RETURN") == 0)
370 ctx
-> token
= RETURN
;
372 else if(strcmp(ident
, "CONST") == 0)
374 ctx
-> token
= CONST
;
376 else if(strcmp(ident
, "TYPE") == 0)
380 else if(strcmp(ident
, "ARRAY") == 0)
382 ctx
-> token
= ARRAY
;
384 else if(strcmp(ident
, "OF") == 0)
388 else if(strcmp(ident
, "RECORD") == 0)
390 ctx
-> token
= RECORD
;
392 else if(strcmp(ident
, "POINTER") == 0)
394 ctx
-> token
= POINTER
;
396 else if(strcmp(ident
, "TO") == 0)
403 oberon_read_integer(oberon_context_t
* ctx
)
406 int i
= ctx
-> code_index
;
408 int c
= ctx
-> code
[i
];
416 char * ident
= malloc(len
+ 2);
417 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
420 ctx
-> code_index
= i
;
421 ctx
-> c
= ctx
-> code
[i
];
422 ctx
-> string
= ident
;
423 ctx
-> integer
= atoi(ident
);
424 ctx
-> token
= INTEGER
;
428 oberon_skip_space(oberon_context_t
* ctx
)
430 while(isspace(ctx
-> c
))
432 oberon_get_char(ctx
);
437 oberon_read_symbol(oberon_context_t
* ctx
)
446 ctx
-> token
= SEMICOLON
;
447 oberon_get_char(ctx
);
450 ctx
-> token
= COLON
;
451 oberon_get_char(ctx
);
454 ctx
-> token
= ASSIGN
;
455 oberon_get_char(ctx
);
460 oberon_get_char(ctx
);
463 ctx
-> token
= LPAREN
;
464 oberon_get_char(ctx
);
467 ctx
-> token
= RPAREN
;
468 oberon_get_char(ctx
);
471 ctx
-> token
= EQUAL
;
472 oberon_get_char(ctx
);
476 oberon_get_char(ctx
);
480 oberon_get_char(ctx
);
484 oberon_get_char(ctx
);
488 ctx
-> token
= GREAT
;
489 oberon_get_char(ctx
);
493 oberon_get_char(ctx
);
498 oberon_get_char(ctx
);
501 ctx
-> token
= MINUS
;
502 oberon_get_char(ctx
);
506 oberon_get_char(ctx
);
509 ctx
-> token
= SLASH
;
510 oberon_get_char(ctx
);
514 oberon_get_char(ctx
);
518 oberon_get_char(ctx
);
521 ctx
-> token
= COMMA
;
522 oberon_get_char(ctx
);
525 ctx
-> token
= LBRACE
;
526 oberon_get_char(ctx
);
529 ctx
-> token
= RBRACE
;
530 oberon_get_char(ctx
);
533 oberon_error(ctx
, "invalid char");
539 oberon_read_token(oberon_context_t
* ctx
)
541 oberon_skip_space(ctx
);
546 oberon_read_ident(ctx
);
550 oberon_read_integer(ctx
);
554 oberon_read_symbol(ctx
);
558 // =======================================================================
560 // =======================================================================
562 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
563 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
564 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
565 static char * oberon_assert_ident(oberon_context_t
* ctx
);
566 static oberon_type_t
* oberon_type(oberon_context_t
* ctx
);
568 static oberon_expr_t
*
569 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
571 oberon_oper_t
* operator;
572 operator = malloc(sizeof *operator);
573 memset(operator, 0, sizeof *operator);
575 operator -> is_item
= 0;
576 operator -> result
= result
;
578 operator -> left
= left
;
579 operator -> right
= right
;
581 return (oberon_expr_t
*) operator;
584 static oberon_expr_t
*
585 oberon_new_item(int mode
, oberon_type_t
* result
)
587 oberon_item_t
* item
;
588 item
= malloc(sizeof *item
);
589 memset(item
, 0, sizeof *item
);
592 item
-> result
= result
;
595 return (oberon_expr_t
*)item
;
598 static oberon_expr_t
*
599 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
601 oberon_expr_t
* expr
;
602 oberon_type_t
* result
;
604 result
= a
-> result
;
608 if(result
-> class != OBERON_TYPE_INTEGER
)
610 oberon_error(ctx
, "incompatible operator type");
613 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
615 else if(token
== NOT
)
617 if(result
-> class != OBERON_TYPE_BOOLEAN
)
619 oberon_error(ctx
, "incompatible operator type");
622 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
626 oberon_error(ctx
, "oberon_make_unary_op: wat");
633 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
)
635 oberon_expr_t
* last
;
638 *first
= last
= oberon_expr(ctx
);
639 while(ctx
-> token
== COMMA
)
641 oberon_assert_token(ctx
, COMMA
);
642 oberon_expr_t
* current
;
643 current
= oberon_expr(ctx
);
644 last
-> next
= current
;
650 static oberon_expr_t
*
651 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
653 if(pref
-> class != expr
-> result
-> class)
655 oberon_error(ctx
, "incompatible types");
659 if(pref
-> class == OBERON_TYPE_INTEGER
)
661 if(expr
-> result
-> class > pref
-> class)
663 oberon_error(ctx
, "incompatible size");
666 else if(pref
-> class == OBERON_TYPE_RECORD
)
668 if(expr
-> result
!= pref
)
670 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
671 oberon_error(ctx
, "incompatible record types");
681 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
683 if(desig
-> is_item
== 0)
685 oberon_error(ctx
, "expected item");
688 if(desig
-> item
.mode
!= MODE_CALL
)
690 oberon_error(ctx
, "expected mode CALL");
693 if(desig
-> item
.var
-> class != OBERON_CLASS_PROC
)
695 oberon_error(ctx
, "only procedures can be called");
698 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
699 int num_args
= desig
-> item
.num_args
;
700 int num_decl
= fn
-> num_decl
;
702 if(num_args
< num_decl
)
704 oberon_error(ctx
, "too few arguments");
706 else if(num_args
> num_decl
)
708 oberon_error(ctx
, "too many arguments");
711 oberon_expr_t
* arg
= desig
-> item
.args
;
712 oberon_object_t
* param
= fn
-> decl
;
713 for(int i
= 0; i
< num_args
; i
++)
715 oberon_autocast_to(ctx
, arg
, param
-> type
);
717 param
= param
-> next
;
725 || ((x) == INTEGER) \
731 #define ISSELECTOR(x) \
735 static oberon_expr_t
*
736 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, int num_indexes
, oberon_expr_t
* indexes
)
738 assert(desig
-> is_item
== 1);
740 if(desig
-> item
.mode
!= MODE_VAR
)
742 oberon_error(ctx
, "not MODE_VAR");
745 int class = desig
-> item
.var
-> class;
748 case OBERON_CLASS_VAR
:
749 case OBERON_CLASS_VAR_PARAM
:
750 case OBERON_CLASS_PARAM
:
753 oberon_error(ctx
, "not variable");
757 oberon_type_t
* type
= desig
-> item
.var
-> type
;
758 if(type
-> class != OBERON_TYPE_ARRAY
)
760 oberon_error(ctx
, "not array");
763 int dim
= desig
-> item
.var
-> type
-> dim
;
764 if(num_indexes
!= dim
)
766 oberon_error(ctx
, "dimesions not matched");
769 oberon_type_t
* base
= desig
-> item
.var
-> type
-> base
;
771 oberon_expr_t
* selector
;
772 selector
= oberon_new_item(MODE_INDEX
, base
);
773 selector
-> item
.parent
= (oberon_item_t
*) desig
;
774 selector
-> item
.num_args
= num_indexes
;
775 selector
-> item
.args
= indexes
;
780 static oberon_expr_t
*
781 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
783 assert(expr
-> is_item
== 1);
785 int class = expr
-> result
-> class;
786 if(class != OBERON_TYPE_RECORD
)
788 oberon_error(ctx
, "not record");
791 oberon_type_t
* rec
= expr
-> result
;
793 oberon_object_t
* field
;
794 field
= oberon_find_field(ctx
, rec
, name
);
796 oberon_expr_t
* selector
;
797 selector
= oberon_new_item(MODE_FIELD
, field
-> type
);
798 selector
-> item
.var
= field
;
799 selector
-> item
.parent
= (oberon_item_t
*) expr
;
804 static oberon_expr_t
*
805 oberon_designator(oberon_context_t
* ctx
)
808 oberon_object_t
* var
;
809 oberon_expr_t
* expr
;
811 name
= oberon_assert_ident(ctx
);
812 var
= oberon_find_object(ctx
-> decl
, name
);
816 case OBERON_CLASS_CONST
:
818 expr
= (oberon_expr_t
*) var
-> value
;
820 case OBERON_CLASS_VAR
:
821 case OBERON_CLASS_VAR_PARAM
:
822 case OBERON_CLASS_PARAM
:
823 expr
= oberon_new_item(MODE_VAR
, var
-> type
);
825 case OBERON_CLASS_PROC
:
826 expr
= oberon_new_item(MODE_CALL
, var
-> type
);
829 oberon_error(ctx
, "invalid designator");
832 expr
-> item
.var
= var
;
834 while(ISSELECTOR(ctx
-> token
))
839 oberon_assert_token(ctx
, DOT
);
840 name
= oberon_assert_ident(ctx
);
841 expr
= oberon_make_record_selector(ctx
, expr
, name
);
844 oberon_assert_token(ctx
, LBRACE
);
846 oberon_expr_t
* indexes
= NULL
;
847 oberon_expr_list(ctx
, &num_indexes
, &indexes
);
848 oberon_assert_token(ctx
, RBRACE
);
849 expr
= oberon_make_array_selector(ctx
, expr
, num_indexes
, indexes
);
852 oberon_error(ctx
, "oberon_designator: wat");
859 static oberon_expr_t
*
860 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
862 assert(expr
-> is_item
== 1);
864 if(ctx
-> token
== LPAREN
)
866 if(expr
-> result
-> class != OBERON_TYPE_PROCEDURE
)
868 oberon_error(ctx
, "not a procedure");
871 oberon_assert_token(ctx
, LPAREN
);
874 oberon_expr_t
* arguments
= NULL
;
876 if(ISEXPR(ctx
-> token
))
878 oberon_expr_list(ctx
, &num_args
, &arguments
);
881 expr
-> result
= expr
-> item
.var
-> type
-> base
;
882 expr
-> item
.mode
= MODE_CALL
;
883 expr
-> item
.num_args
= num_args
;
884 expr
-> item
.args
= arguments
;
885 oberon_assert_token(ctx
, RPAREN
);
887 oberon_autocast_call(ctx
, expr
);
893 static oberon_expr_t
*
894 oberon_factor(oberon_context_t
* ctx
)
896 oberon_expr_t
* expr
;
901 expr
= oberon_designator(ctx
);
902 expr
= oberon_opt_proc_parens(ctx
, expr
);
905 expr
= oberon_new_item(MODE_INTEGER
, ctx
-> int_type
);
906 expr
-> item
.integer
= ctx
-> integer
;
907 oberon_assert_token(ctx
, INTEGER
);
910 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
911 expr
-> item
.boolean
= 1;
912 oberon_assert_token(ctx
, TRUE
);
915 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
);
916 expr
-> item
.boolean
= 0;
917 oberon_assert_token(ctx
, FALSE
);
920 oberon_assert_token(ctx
, LPAREN
);
921 expr
= oberon_expr(ctx
);
922 oberon_assert_token(ctx
, RPAREN
);
925 oberon_assert_token(ctx
, NOT
);
926 expr
= oberon_factor(ctx
);
927 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
930 oberon_error(ctx
, "invalid expression");
937 * oberon_autocast_binary_op автоматически переобразовывеат тип по след. правилам:
938 * 1. Классы обоих типов должны быть одинаковы
939 * 2. В качестве результата должен быть выбран больший тип.
940 * 3. Если размер результат не должен быть меньше чем базовый int
944 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
, oberon_type_t
** result
)
946 if((a
-> class) != (b
-> class))
948 oberon_error(ctx
, "incompatible types");
951 if((a
-> size
) > (b
-> size
))
960 if(((*result
) -> class) == OBERON_TYPE_INTEGER
)
962 if(((*result
) -> size
) < (ctx
-> int_type
-> size
))
964 *result
= ctx
-> int_type
;
968 /* TODO: cast types */
971 #define ITMAKESBOOLEAN(x) \
972 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
974 #define ITUSEONLYINTEGER(x) \
975 ((x) >= LESS && (x) <= GEQ)
977 #define ITUSEONLYBOOLEAN(x) \
978 (((x) == OR) || ((x) == AND))
980 static oberon_expr_t
*
981 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
983 oberon_expr_t
* expr
;
984 oberon_type_t
* result
;
986 if(ITMAKESBOOLEAN(token
))
988 if(ITUSEONLYINTEGER(token
))
990 if(a
-> result
-> class != OBERON_TYPE_INTEGER
991 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
993 oberon_error(ctx
, "used only with integer types");
996 else if(ITUSEONLYBOOLEAN(token
))
998 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
999 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1001 oberon_error(ctx
, "used only with boolean type");
1005 result
= ctx
-> bool_type
;
1009 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1011 else if(token
== NEQ
)
1013 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1015 else if(token
== LESS
)
1017 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1019 else if(token
== LEQ
)
1021 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1023 else if(token
== GREAT
)
1025 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1027 else if(token
== GEQ
)
1029 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1031 else if(token
== OR
)
1033 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1035 else if(token
== AND
)
1037 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1041 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1046 oberon_autocast_binary_op(ctx
, a
-> result
, b
-> result
, &result
);
1050 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1052 else if(token
== MINUS
)
1054 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1056 else if(token
== STAR
)
1058 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1060 else if(token
== SLASH
)
1062 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1064 else if(token
== DIV
)
1066 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1068 else if(token
== MOD
)
1070 expr
= oberon_new_operator(OP_MOD
, result
, a
, b
);
1074 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1081 #define ISMULOP(x) \
1082 ((x) >= STAR && (x) <= AND)
1084 static oberon_expr_t
*
1085 oberon_term_expr(oberon_context_t
* ctx
)
1087 oberon_expr_t
* expr
;
1089 expr
= oberon_factor(ctx
);
1090 while(ISMULOP(ctx
-> token
))
1092 int token
= ctx
-> token
;
1093 oberon_read_token(ctx
);
1095 oberon_expr_t
* inter
= oberon_factor(ctx
);
1096 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1102 #define ISADDOP(x) \
1103 ((x) >= PLUS && (x) <= OR)
1105 static oberon_expr_t
*
1106 oberon_simple_expr(oberon_context_t
* ctx
)
1108 oberon_expr_t
* expr
;
1111 if(ctx
-> token
== PLUS
)
1114 oberon_assert_token(ctx
, PLUS
);
1116 else if(ctx
-> token
== MINUS
)
1119 oberon_assert_token(ctx
, MINUS
);
1122 expr
= oberon_term_expr(ctx
);
1123 while(ISADDOP(ctx
-> token
))
1125 int token
= ctx
-> token
;
1126 oberon_read_token(ctx
);
1128 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1129 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1134 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1140 #define ISRELATION(x) \
1141 ((x) >= EQUAL && (x) <= GEQ)
1143 static oberon_expr_t
*
1144 oberon_expr(oberon_context_t
* ctx
)
1146 oberon_expr_t
* expr
;
1148 expr
= oberon_simple_expr(ctx
);
1149 while(ISRELATION(ctx
-> token
))
1151 int token
= ctx
-> token
;
1152 oberon_read_token(ctx
);
1154 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1155 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1161 static oberon_item_t
*
1162 oberon_const_expr(oberon_context_t
* ctx
)
1164 oberon_expr_t
* expr
;
1165 expr
= oberon_expr(ctx
);
1167 if(expr
-> is_item
== 0)
1169 oberon_error(ctx
, "const expression are required");
1172 return (oberon_item_t
*) expr
;
1175 // =======================================================================
1177 // =======================================================================
1179 static void oberon_statement_seq(oberon_context_t
* ctx
);
1182 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1184 if(ctx
-> token
!= token
)
1186 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1191 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1193 oberon_expect_token(ctx
, token
);
1194 oberon_read_token(ctx
);
1198 oberon_assert_ident(oberon_context_t
* ctx
)
1200 oberon_expect_token(ctx
, IDENT
);
1201 char * ident
= ctx
-> string
;
1202 oberon_read_token(ctx
);
1206 static oberon_type_t
*
1207 oberon_make_array_type(oberon_context_t
* ctx
, int dim
, oberon_item_t
* size
, oberon_type_t
* base
)
1210 oberon_type_t
* newtype
;
1212 if(size
-> mode
!= MODE_INTEGER
)
1214 oberon_error(ctx
, "requires integer constant");
1217 newtype
= oberon_new_type_ptr(OBERON_TYPE_ARRAY
);
1218 newtype
-> dim
= dim
;
1219 newtype
-> size
= size
-> integer
;
1220 newtype
-> base
= base
;
1221 oberon_generator_init_type(ctx
, newtype
);
1227 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
1229 if(ctx
-> token
== IDENT
)
1232 oberon_type_t
* type
;
1233 name
= oberon_assert_ident(ctx
);
1234 oberon_assert_token(ctx
, COLON
);
1235 type
= oberon_type(ctx
);
1236 oberon_define_field(ctx
, rec
, name
, type
);
1240 static oberon_type_t
*
1241 oberon_make_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
1243 if(type
-> class == OBERON_TYPE_POINTER
)
1248 if(type
-> class == OBERON_TYPE_INTEGER
1249 || type
-> class == OBERON_TYPE_BOOLEAN
1250 || type
-> class == OBERON_TYPE_PROCEDURE
1251 || type
-> class == OBERON_TYPE_VOID
)
1253 oberon_error(ctx
, "oberon not support pointers to non structure types");
1256 oberon_type_t
* newtype
;
1257 newtype
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
1258 newtype
-> base
= type
;
1260 oberon_generator_init_type(ctx
, newtype
);
1265 static oberon_type_t
* oberon_opt_formal_pars(oberon_context_t
* ctx
, int class);
1267 static oberon_type_t
*
1268 oberon_type(oberon_context_t
* ctx
)
1270 oberon_type_t
* type
;
1272 if(ctx
-> token
== IDENT
)
1274 char * name
= oberon_assert_ident(ctx
);
1275 type
= oberon_find_type(ctx
-> decl
, name
);
1277 else if(ctx
-> token
== ARRAY
)
1279 oberon_assert_token(ctx
, ARRAY
);
1280 oberon_item_t
* size
= oberon_const_expr(ctx
);
1281 oberon_assert_token(ctx
, OF
);
1282 oberon_type_t
* base
= oberon_type(ctx
);
1283 type
= oberon_make_array_type(ctx
, 1, size
, base
);
1285 else if(ctx
-> token
== RECORD
)
1287 type
= oberon_new_type_ptr(OBERON_TYPE_RECORD
);
1288 oberon_object_t
* list
= malloc(sizeof *list
);
1289 memset(list
, 0, sizeof *list
);
1290 type
-> num_decl
= 0;
1291 type
-> base
= NULL
;
1292 type
-> decl
= list
;
1294 oberon_assert_token(ctx
, RECORD
);
1295 oberon_field_list(ctx
, type
);
1296 while(ctx
-> token
== SEMICOLON
)
1298 oberon_assert_token(ctx
, SEMICOLON
);
1299 oberon_field_list(ctx
, type
);
1301 oberon_assert_token(ctx
, END
);
1303 type
-> decl
= type
-> decl
-> next
;
1304 oberon_generator_init_type(ctx
, type
);
1306 else if(ctx
-> token
== POINTER
)
1308 oberon_assert_token(ctx
, POINTER
);
1309 oberon_assert_token(ctx
, TO
);
1310 type
= oberon_type(ctx
);
1311 type
= oberon_make_pointer(ctx
, type
);
1313 else if(ctx
-> token
== PROCEDURE
)
1315 oberon_assert_token(ctx
, PROCEDURE
);
1316 type
= oberon_opt_formal_pars(ctx
, OBERON_TYPE_PROCEDURE
);
1320 oberon_error(ctx
, "invalid type declaration");
1327 oberon_var_decl(oberon_context_t
* ctx
)
1329 char * name
= oberon_assert_ident(ctx
);
1330 oberon_assert_token(ctx
, COLON
);
1331 oberon_type_t
* type
= oberon_type(ctx
);
1332 oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR
, name
, type
);
1335 static oberon_object_t
*
1336 oberon_make_param(oberon_context_t
* ctx
, int token
, char * name
, oberon_type_t
* type
)
1338 oberon_object_t
* param
;
1342 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_VAR_PARAM
, name
, type
);
1344 else if(token
== IDENT
)
1346 param
= oberon_define_var(ctx
-> decl
, OBERON_CLASS_PARAM
, name
, type
);
1350 oberon_error(ctx
, "oberon_make_param: wat");
1356 static oberon_object_t
*
1357 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1359 int modifer_token
= ctx
-> token
;
1360 if(ctx
-> token
== VAR
)
1362 oberon_read_token(ctx
);
1366 name
= oberon_assert_ident(ctx
);
1368 oberon_assert_token(ctx
, COLON
);
1370 oberon_type_t
* type
;
1371 type
= oberon_type(ctx
);
1373 oberon_object_t
* first
;
1374 first
= oberon_make_param(ctx
, modifer_token
, name
, type
);
1380 #define ISFPSECTION \
1381 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1383 static oberon_type_t
*
1384 oberon_formal_pars(oberon_context_t
* ctx
)
1387 tp
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
1389 tp
-> base
= ctx
-> void_type
;
1392 oberon_assert_token(ctx
, LPAREN
);
1396 tp
-> decl
= oberon_fp_section(ctx
, &tp
-> num_decl
);
1397 while(ctx
-> token
== SEMICOLON
)
1399 oberon_assert_token(ctx
, SEMICOLON
);
1400 oberon_fp_section(ctx
, &tp
-> num_decl
);
1404 oberon_assert_token(ctx
, RPAREN
);
1406 if(ctx
-> token
== COLON
)
1408 oberon_assert_token(ctx
, COLON
);
1409 tp
-> base
= oberon_type(ctx
);
1412 oberon_generator_init_type(ctx
, tp
);
1416 static oberon_type_t
*
1417 oberon_opt_formal_pars(oberon_context_t
* ctx
, int class)
1419 oberon_type_t
* signature
;
1421 if(ctx
-> token
== LPAREN
)
1423 signature
= oberon_formal_pars(ctx
);
1427 signature
= oberon_new_type_ptr(class);
1428 signature
-> num_decl
= 0;
1429 signature
-> base
= ctx
-> void_type
;
1430 signature
-> decl
= NULL
;
1431 oberon_generator_init_type(ctx
, signature
);
1438 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1440 if(ctx
-> result_type
-> class == OBERON_TYPE_VOID
)
1444 oberon_error(ctx
, "procedure has no result type");
1451 oberon_error(ctx
, "procedure requires expression on result");
1454 oberon_autocast_to(ctx
, expr
, ctx
-> result_type
);
1457 ctx
-> has_return
= 1;
1459 oberon_generate_return(ctx
, expr
);
1463 oberon_proc_decl(oberon_context_t
* ctx
)
1465 oberon_assert_token(ctx
, PROCEDURE
);
1468 name
= oberon_assert_ident(ctx
);
1470 oberon_scope_t
* this_proc_def_scope
= ctx
-> decl
;
1471 oberon_open_scope(ctx
);
1473 oberon_type_t
* signature
;
1474 signature
= oberon_opt_formal_pars(ctx
, OBERON_TYPE_PROCEDURE
);
1476 oberon_object_t
* proc
;
1477 proc
= oberon_define_proc(this_proc_def_scope
, name
, signature
);
1479 ctx
-> result_type
= signature
-> base
;
1480 ctx
-> has_return
= 0;
1482 oberon_assert_token(ctx
, SEMICOLON
);
1484 oberon_generate_begin_proc(ctx
, proc
);
1486 // TODO declarations
1488 if(ctx
-> token
== BEGIN
)
1490 oberon_assert_token(ctx
, BEGIN
);
1491 oberon_statement_seq(ctx
);
1494 oberon_assert_token(ctx
, END
);
1495 char * name2
= oberon_assert_ident(ctx
);
1496 if(strcmp(name2
, name
) != 0)
1498 oberon_error(ctx
, "procedure name not matched");
1501 if(signature
-> base
-> class == OBERON_TYPE_VOID
)
1503 oberon_make_return(ctx
, NULL
);
1506 if(ctx
-> has_return
== 0)
1508 oberon_error(ctx
, "procedure requires return");
1510 ctx
-> result_type
= NULL
;
1512 oberon_generate_end_proc(ctx
);
1513 oberon_close_scope(ctx
-> decl
);
1517 oberon_const_decl(oberon_context_t
* ctx
)
1520 oberon_item_t
* value
;
1521 oberon_object_t
* constant
;
1523 name
= oberon_assert_ident(ctx
);
1524 oberon_assert_token(ctx
, EQUAL
);
1525 value
= oberon_const_expr(ctx
);
1527 constant
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_CONST
);
1528 constant
-> value
= value
;
1532 oberon_type_decl(oberon_context_t
* ctx
)
1535 oberon_object_t
* newtype
;
1536 oberon_type_t
* type
;
1538 name
= oberon_assert_ident(ctx
);
1539 oberon_assert_token(ctx
, EQUAL
);
1540 type
= oberon_type(ctx
);
1542 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
);
1543 newtype
-> type
= type
;
1547 oberon_decl_seq(oberon_context_t
* ctx
)
1549 if(ctx
-> token
== CONST
)
1551 oberon_assert_token(ctx
, CONST
);
1552 while(ctx
-> token
== IDENT
)
1554 oberon_const_decl(ctx
);
1555 oberon_assert_token(ctx
, SEMICOLON
);
1559 if(ctx
-> token
== TYPE
)
1561 oberon_assert_token(ctx
, TYPE
);
1562 while(ctx
-> token
== IDENT
)
1564 oberon_type_decl(ctx
);
1565 oberon_assert_token(ctx
, SEMICOLON
);
1569 if(ctx
-> token
== VAR
)
1571 oberon_assert_token(ctx
, VAR
);
1572 while(ctx
-> token
== IDENT
)
1574 oberon_var_decl(ctx
);
1575 oberon_assert_token(ctx
, SEMICOLON
);
1579 while(ctx
-> token
== PROCEDURE
)
1581 oberon_proc_decl(ctx
);
1582 oberon_assert_token(ctx
, SEMICOLON
);
1587 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
1589 oberon_autocast_to(ctx
, src
, dst
-> result
);
1590 oberon_generate_assign(ctx
, src
, dst
);
1594 oberon_make_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
1596 oberon_autocast_call(ctx
, desig
);
1597 oberon_generate_call_proc(ctx
, desig
);
1601 oberon_statement(oberon_context_t
* ctx
)
1603 oberon_expr_t
* item1
;
1604 oberon_expr_t
* item2
;
1606 if(ctx
-> token
== IDENT
)
1608 item1
= oberon_designator(ctx
);
1609 if(ctx
-> token
== ASSIGN
)
1611 oberon_assert_token(ctx
, ASSIGN
);
1612 item2
= oberon_expr(ctx
);
1613 oberon_assign(ctx
, item2
, item1
);
1617 item1
= oberon_opt_proc_parens(ctx
, item1
);
1618 oberon_make_call(ctx
, item1
);
1621 else if(ctx
-> token
== RETURN
)
1623 oberon_assert_token(ctx
, RETURN
);
1624 if(ISEXPR(ctx
-> token
))
1626 oberon_expr_t
* expr
;
1627 expr
= oberon_expr(ctx
);
1628 oberon_make_return(ctx
, expr
);
1632 oberon_make_return(ctx
, NULL
);
1638 oberon_statement_seq(oberon_context_t
* ctx
)
1640 oberon_statement(ctx
);
1641 while(ctx
-> token
== SEMICOLON
)
1643 oberon_assert_token(ctx
, SEMICOLON
);
1644 oberon_statement(ctx
);
1649 oberon_parse_module(oberon_context_t
* ctx
)
1651 char *name1
, *name2
;
1652 oberon_read_token(ctx
);
1654 oberon_assert_token(ctx
, MODULE
);
1655 name1
= oberon_assert_ident(ctx
);
1656 oberon_assert_token(ctx
, SEMICOLON
);
1657 ctx
-> mod
-> name
= name1
;
1659 oberon_decl_seq(ctx
);
1661 if(ctx
-> token
== BEGIN
)
1663 oberon_assert_token(ctx
, BEGIN
);
1664 oberon_generate_begin_module(ctx
);
1665 oberon_statement_seq(ctx
);
1666 oberon_generate_end_module(ctx
);
1669 oberon_assert_token(ctx
, END
);
1670 name2
= oberon_assert_ident(ctx
);
1671 oberon_assert_token(ctx
, DOT
);
1673 if(strcmp(name1
, name2
) != 0)
1675 oberon_error(ctx
, "module name not matched");
1679 // =======================================================================
1681 // =======================================================================
1684 register_default_types(oberon_context_t
* ctx
)
1686 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1687 oberon_generator_init_type(ctx
, ctx
-> void_type
);
1689 ctx
-> int_type
= oberon_new_type_integer(sizeof(int));
1690 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
);
1692 ctx
-> bool_type
= oberon_new_type_boolean(sizeof(int));
1693 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
);
1697 oberon_create_context()
1699 oberon_context_t
* ctx
= malloc(sizeof *ctx
);
1700 memset(ctx
, 0, sizeof *ctx
);
1702 oberon_scope_t
* world_scope
;
1703 world_scope
= oberon_open_scope(ctx
);
1704 ctx
-> world_scope
= world_scope
;
1706 oberon_generator_init_context(ctx
);
1708 register_default_types(ctx
);
1714 oberon_destroy_context(oberon_context_t
* ctx
)
1716 oberon_generator_destroy_context(ctx
);
1721 oberon_compile_module(oberon_context_t
* ctx
, const char * code
)
1723 oberon_module_t
* mod
= malloc(sizeof *mod
);
1724 memset(mod
, 0, sizeof *mod
);
1727 oberon_scope_t
* module_scope
;
1728 module_scope
= oberon_open_scope(ctx
);
1729 mod
-> decl
= module_scope
;
1731 oberon_init_scaner(ctx
, code
);
1732 oberon_parse_module(ctx
);
1734 oberon_generate_code(ctx
);