9 #include "../include/oberon.h"
11 #include "oberon-internals.h"
12 #include "generator.h"
63 // =======================================================================
65 // =======================================================================
68 oberon_error(oberon_context_t
* ctx
, const char * fmt
, ...)
72 fprintf(stderr
, "error: ");
73 vfprintf(stderr
, fmt
, ptr
);
74 fprintf(stderr
, "\n");
75 fprintf(stderr
, " code_index = %i\n", ctx
-> code_index
);
76 fprintf(stderr
, " c = %c\n", ctx
-> c
);
77 fprintf(stderr
, " token = %i\n", ctx
-> token
);
82 static oberon_type_t
*
83 oberon_new_type_ptr(int class)
85 oberon_type_t
* x
= malloc(sizeof *x
);
86 memset(x
, 0, sizeof *x
);
91 static oberon_type_t
*
92 oberon_new_type_integer(int size
)
95 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
100 static oberon_type_t
*
101 oberon_new_type_boolean()
104 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
108 static oberon_type_t
*
109 oberon_new_type_real(int size
)
112 x
= oberon_new_type_ptr(OBERON_TYPE_REAL
);
117 // =======================================================================
119 // =======================================================================
121 static oberon_scope_t
*
122 oberon_open_scope(oberon_context_t
* ctx
)
124 oberon_scope_t
* scope
= calloc(1, sizeof *scope
);
125 oberon_object_t
* list
= calloc(1, sizeof *list
);
128 scope
-> list
= list
;
129 scope
-> up
= ctx
-> decl
;
133 scope
-> local
= scope
-> up
-> local
;
134 scope
-> parent
= scope
-> up
-> parent
;
135 scope
-> parent_type
= scope
-> up
-> parent_type
;
143 oberon_close_scope(oberon_scope_t
* scope
)
145 oberon_context_t
* ctx
= scope
-> ctx
;
146 ctx
-> decl
= scope
-> up
;
149 static oberon_object_t
*
150 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class, int export
, int read_only
)
152 oberon_object_t
* x
= scope
-> list
;
153 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
160 oberon_error(scope
-> ctx
, "already defined");
163 oberon_object_t
* newvar
= malloc(sizeof *newvar
);
164 memset(newvar
, 0, sizeof *newvar
);
165 newvar
-> name
= name
;
166 newvar
-> class = class;
167 newvar
-> export
= export
;
168 newvar
-> read_only
= read_only
;
169 newvar
-> local
= scope
-> local
;
170 newvar
-> parent
= scope
-> parent
;
171 newvar
-> parent_type
= scope
-> parent_type
;
172 newvar
-> module
= scope
-> ctx
-> mod
;
179 static oberon_object_t
*
180 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
182 oberon_object_t
* x
= list
;
183 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
190 static oberon_object_t
*
191 oberon_find_object(oberon_scope_t
* scope
, char * name
, int check_it
)
193 oberon_object_t
* result
= NULL
;
195 oberon_scope_t
* s
= scope
;
196 while(result
== NULL
&& s
!= NULL
)
198 result
= oberon_find_object_in_list(s
-> list
, name
);
202 if(check_it
&& result
== NULL
)
204 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
210 static oberon_object_t
*
211 oberon_find_field(oberon_context_t
* ctx
, oberon_type_t
* rec
, char * name
)
213 oberon_object_t
* x
= rec
-> decl
;
214 for(int i
= 0; i
< rec
-> num_decl
; i
++)
216 if(strcmp(x
-> name
, name
) == 0)
223 oberon_error(ctx
, "field not defined");
228 static oberon_object_t
*
229 oberon_define_type(oberon_scope_t
* scope
, char * name
, oberon_type_t
* type
, int export
)
231 oberon_object_t
* id
;
232 id
= oberon_define_object(scope
, name
, OBERON_CLASS_TYPE
, export
, 0);
234 oberon_generator_init_type(scope
-> ctx
, type
);
238 // =======================================================================
240 // =======================================================================
243 oberon_get_char(oberon_context_t
* ctx
)
245 if(ctx
-> code
[ctx
-> code_index
])
247 ctx
-> code_index
+= 1;
248 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
253 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
256 ctx
-> code_index
= 0;
257 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
261 oberon_read_ident(oberon_context_t
* ctx
)
264 int i
= ctx
-> code_index
;
266 int c
= ctx
-> code
[i
];
274 char * ident
= malloc(len
+ 1);
275 memcpy(ident
, &ctx
->code
[ctx
->code_index
], len
);
278 ctx
-> code_index
= i
;
279 ctx
-> c
= ctx
-> code
[i
];
280 ctx
-> string
= ident
;
281 ctx
-> token
= IDENT
;
283 if(strcmp(ident
, "MODULE") == 0)
285 ctx
-> token
= MODULE
;
287 else if(strcmp(ident
, "END") == 0)
291 else if(strcmp(ident
, "VAR") == 0)
295 else if(strcmp(ident
, "BEGIN") == 0)
297 ctx
-> token
= BEGIN
;
299 else if(strcmp(ident
, "TRUE") == 0)
303 else if(strcmp(ident
, "FALSE") == 0)
305 ctx
-> token
= FALSE
;
307 else if(strcmp(ident
, "OR") == 0)
311 else if(strcmp(ident
, "DIV") == 0)
315 else if(strcmp(ident
, "MOD") == 0)
319 else if(strcmp(ident
, "PROCEDURE") == 0)
321 ctx
-> token
= PROCEDURE
;
323 else if(strcmp(ident
, "RETURN") == 0)
325 ctx
-> token
= RETURN
;
327 else if(strcmp(ident
, "CONST") == 0)
329 ctx
-> token
= CONST
;
331 else if(strcmp(ident
, "TYPE") == 0)
335 else if(strcmp(ident
, "ARRAY") == 0)
337 ctx
-> token
= ARRAY
;
339 else if(strcmp(ident
, "OF") == 0)
343 else if(strcmp(ident
, "RECORD") == 0)
345 ctx
-> token
= RECORD
;
347 else if(strcmp(ident
, "POINTER") == 0)
349 ctx
-> token
= POINTER
;
351 else if(strcmp(ident
, "TO") == 0)
355 else if(strcmp(ident
, "NIL") == 0)
359 else if(strcmp(ident
, "IMPORT") == 0)
361 ctx
-> token
= IMPORT
;
366 oberon_read_number(oberon_context_t
* ctx
)
379 * mode = 3 == LONGREAL
382 start_i
= ctx
-> code_index
;
384 while(isdigit(ctx
-> c
))
386 oberon_get_char(ctx
);
389 end_i
= ctx
-> code_index
;
391 if(isxdigit(ctx
-> c
))
394 while(isxdigit(ctx
-> c
))
396 oberon_get_char(ctx
);
399 end_i
= ctx
-> code_index
;
403 oberon_error(ctx
, "invalid hex number");
405 oberon_get_char(ctx
);
407 else if(ctx
-> c
== '.')
410 oberon_get_char(ctx
);
412 while(isdigit(ctx
-> c
))
414 oberon_get_char(ctx
);
417 if(ctx
-> c
== 'E' || ctx
-> c
== 'D')
419 exp_i
= ctx
-> code_index
;
426 oberon_get_char(ctx
);
428 if(ctx
-> c
== '+' || ctx
-> c
== '-')
430 oberon_get_char(ctx
);
433 while(isdigit(ctx
-> c
))
435 oberon_get_char(ctx
);
440 end_i
= ctx
-> code_index
;
443 int len
= end_i
- start_i
;
444 ident
= malloc(len
+ 1);
445 memcpy(ident
, &ctx
-> code
[start_i
], len
);
448 ctx
-> longmode
= false;
451 int i
= exp_i
- start_i
;
453 ctx
-> longmode
= true;
459 integer
= atol(ident
);
461 ctx
-> token
= INTEGER
;
464 sscanf(ident
, "%lx", &integer
);
466 ctx
-> token
= INTEGER
;
470 sscanf(ident
, "%lf", &real
);
474 oberon_error(ctx
, "oberon_read_number: wat");
478 ctx
-> string
= ident
;
479 ctx
-> integer
= integer
;
484 oberon_skip_space(oberon_context_t
* ctx
)
486 while(isspace(ctx
-> c
))
488 oberon_get_char(ctx
);
493 oberon_read_comment(oberon_context_t
* ctx
)
500 oberon_get_char(ctx
);
503 oberon_get_char(ctx
);
507 else if(ctx
-> c
== '*')
509 oberon_get_char(ctx
);
512 oberon_get_char(ctx
);
516 else if(ctx
-> c
== 0)
518 oberon_error(ctx
, "unterminated comment");
522 oberon_get_char(ctx
);
527 static void oberon_read_token(oberon_context_t
* ctx
);
530 oberon_read_symbol(oberon_context_t
* ctx
)
539 ctx
-> token
= SEMICOLON
;
540 oberon_get_char(ctx
);
543 ctx
-> token
= COLON
;
544 oberon_get_char(ctx
);
547 ctx
-> token
= ASSIGN
;
548 oberon_get_char(ctx
);
553 oberon_get_char(ctx
);
556 ctx
-> token
= LPAREN
;
557 oberon_get_char(ctx
);
560 oberon_get_char(ctx
);
561 oberon_read_comment(ctx
);
562 oberon_read_token(ctx
);
566 ctx
-> token
= RPAREN
;
567 oberon_get_char(ctx
);
570 ctx
-> token
= EQUAL
;
571 oberon_get_char(ctx
);
575 oberon_get_char(ctx
);
579 oberon_get_char(ctx
);
583 oberon_get_char(ctx
);
587 ctx
-> token
= GREAT
;
588 oberon_get_char(ctx
);
592 oberon_get_char(ctx
);
597 oberon_get_char(ctx
);
600 ctx
-> token
= MINUS
;
601 oberon_get_char(ctx
);
605 oberon_get_char(ctx
);
608 oberon_get_char(ctx
);
609 oberon_error(ctx
, "unstarted comment");
613 ctx
-> token
= SLASH
;
614 oberon_get_char(ctx
);
618 oberon_get_char(ctx
);
622 oberon_get_char(ctx
);
625 ctx
-> token
= COMMA
;
626 oberon_get_char(ctx
);
629 ctx
-> token
= LBRACE
;
630 oberon_get_char(ctx
);
633 ctx
-> token
= RBRACE
;
634 oberon_get_char(ctx
);
637 ctx
-> token
= UPARROW
;
638 oberon_get_char(ctx
);
641 oberon_error(ctx
, "invalid char %c", ctx
-> c
);
647 oberon_read_token(oberon_context_t
* ctx
)
649 oberon_skip_space(ctx
);
654 oberon_read_ident(ctx
);
658 oberon_read_number(ctx
);
662 oberon_read_symbol(ctx
);
666 // =======================================================================
668 // =======================================================================
670 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
671 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
672 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
673 static char * oberon_assert_ident(oberon_context_t
* ctx
);
674 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
675 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
677 static oberon_expr_t
*
678 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
680 oberon_oper_t
* operator;
681 operator = malloc(sizeof *operator);
682 memset(operator, 0, sizeof *operator);
684 operator -> is_item
= 0;
685 operator -> result
= result
;
686 operator -> read_only
= 1;
688 operator -> left
= left
;
689 operator -> right
= right
;
691 return (oberon_expr_t
*) operator;
694 static oberon_expr_t
*
695 oberon_new_item(int mode
, oberon_type_t
* result
, int read_only
)
697 oberon_item_t
* item
;
698 item
= malloc(sizeof *item
);
699 memset(item
, 0, sizeof *item
);
702 item
-> result
= result
;
703 item
-> read_only
= read_only
;
706 return (oberon_expr_t
*)item
;
709 static oberon_expr_t
*
710 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
712 oberon_expr_t
* expr
;
713 oberon_type_t
* result
;
715 result
= a
-> result
;
719 if(result
-> class != OBERON_TYPE_INTEGER
)
721 oberon_error(ctx
, "incompatible operator type");
724 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
726 else if(token
== NOT
)
728 if(result
-> class != OBERON_TYPE_BOOLEAN
)
730 oberon_error(ctx
, "incompatible operator type");
733 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
737 oberon_error(ctx
, "oberon_make_unary_op: wat");
744 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
746 oberon_expr_t
* last
;
749 *first
= last
= oberon_expr(ctx
);
750 while(ctx
-> token
== COMMA
)
752 oberon_assert_token(ctx
, COMMA
);
753 oberon_expr_t
* current
;
757 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
761 current
= oberon_expr(ctx
);
764 last
-> next
= current
;
770 static oberon_expr_t
*
771 oberon_cast_expr(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
773 assert(expr
-> is_item
);
774 oberon_expr_t
* cast
;
775 cast
= oberon_new_item(MODE_CAST
, pref
, expr
-> read_only
);
776 cast
-> item
.parent
= (oberon_item_t
*) expr
;
777 cast
-> next
= expr
-> next
;
781 static oberon_type_t
*
782 oberon_get_equal_expr_type(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
784 oberon_type_t
* result
;
785 if(a
-> class == OBERON_TYPE_REAL
&& b
-> class == OBERON_TYPE_INTEGER
)
789 else if(b
-> class == OBERON_TYPE_REAL
&& a
-> class == OBERON_TYPE_INTEGER
)
793 else if(a
-> class != b
-> class)
795 oberon_error(ctx
, "oberon_get_equal_expr_type: incompatible types");
797 else if(a
-> size
> b
-> size
)
809 static oberon_expr_t
*
810 oberon_autocast_to(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
812 if(pref
-> class != expr
-> result
-> class)
814 if(pref
-> class == OBERON_TYPE_POINTER
)
816 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
822 oberon_error(ctx
, "incompatible types");
825 else if(pref
-> class == OBERON_TYPE_REAL
)
827 if(expr
-> result
-> class == OBERON_TYPE_INTEGER
)
833 oberon_error(ctx
, "incompatible types");
838 oberon_error(ctx
, "incompatible types");
842 if(pref
-> class == OBERON_TYPE_INTEGER
|| pref
-> class == OBERON_TYPE_REAL
)
844 if(expr
-> result
-> size
> pref
-> size
)
846 oberon_error(ctx
, "incompatible size");
850 expr
= oberon_cast_expr(ctx
, expr
, pref
);
853 else if(pref
-> class == OBERON_TYPE_RECORD
)
855 if(expr
-> result
!= pref
)
857 printf("oberon_autocast_to: rec %p != %p\n", expr
-> result
, pref
);
858 oberon_error(ctx
, "incompatible record types");
861 else if(pref
-> class == OBERON_TYPE_POINTER
)
863 if(expr
-> result
-> base
!= pref
-> base
)
865 if(expr
-> result
-> base
-> class != OBERON_TYPE_VOID
)
867 oberon_error(ctx
, "incompatible pointer types");
876 oberon_autocast_binary_op(oberon_context_t
* ctx
, oberon_expr_t
** ea
, oberon_expr_t
** eb
)
878 oberon_type_t
* a
= (*ea
) -> result
;
879 oberon_type_t
* b
= (*eb
) -> result
;
880 oberon_type_t
* preq
= oberon_get_equal_expr_type(ctx
, a
, b
);
881 *ea
= oberon_autocast_to(ctx
, *ea
, preq
);
882 *eb
= oberon_autocast_to(ctx
, *eb
, preq
);
886 oberon_autocast_call(oberon_context_t
* ctx
, oberon_expr_t
* desig
)
888 if(desig
-> is_item
== 0)
890 oberon_error(ctx
, "expected item");
893 if(desig
-> item
.mode
!= MODE_CALL
)
895 oberon_error(ctx
, "expected mode CALL");
898 if(desig
-> item
.var
-> type
-> class != OBERON_TYPE_PROCEDURE
)
900 oberon_error(ctx
, "only procedures can be called");
903 oberon_type_t
* fn
= desig
-> item
.var
-> type
;
904 int num_args
= desig
-> item
.num_args
;
905 int num_decl
= fn
-> num_decl
;
907 if(num_args
< num_decl
)
909 oberon_error(ctx
, "too few arguments");
911 else if(num_args
> num_decl
)
913 oberon_error(ctx
, "too many arguments");
916 /* Делаем проверку на запись и делаем автокаст */
917 oberon_expr_t
* casted
[num_args
];
918 oberon_expr_t
* arg
= desig
-> item
.args
;
919 oberon_object_t
* param
= fn
-> decl
;
920 for(int i
= 0; i
< num_args
; i
++)
922 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
926 oberon_error(ctx
, "assign to read-only var");
930 casted
[i
] = oberon_autocast_to(ctx
, arg
, param
-> type
);
932 param
= param
-> next
;
935 /* Создаём новый список выражений */
939 for(int i
= 0; i
< num_args
- 1; i
++)
941 casted
[i
] -> next
= casted
[i
+ 1];
943 desig
-> item
.args
= arg
;
947 static oberon_expr_t
*
948 oberon_make_call_func(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
950 switch(proc
-> class)
952 case OBERON_CLASS_PROC
:
953 if(proc
-> class != OBERON_CLASS_PROC
)
955 oberon_error(ctx
, "not a procedure");
958 case OBERON_CLASS_VAR
:
959 case OBERON_CLASS_VAR_PARAM
:
960 case OBERON_CLASS_PARAM
:
961 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
963 oberon_error(ctx
, "not a procedure");
967 oberon_error(ctx
, "not a procedure");
971 oberon_expr_t
* call
;
975 if(proc
-> genfunc
== NULL
)
977 oberon_error(ctx
, "not a function-procedure");
980 call
= proc
-> genfunc(ctx
, num_args
, list_args
);
984 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
)
986 oberon_error(ctx
, "attempt to call procedure in expression");
989 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
990 call
-> item
.var
= proc
;
991 call
-> item
.num_args
= num_args
;
992 call
-> item
.args
= list_args
;
993 oberon_autocast_call(ctx
, call
);
1000 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_object_t
* proc
, int num_args
, oberon_expr_t
* list_args
)
1002 switch(proc
-> class)
1004 case OBERON_CLASS_PROC
:
1005 if(proc
-> class != OBERON_CLASS_PROC
)
1007 oberon_error(ctx
, "not a procedure");
1010 case OBERON_CLASS_VAR
:
1011 case OBERON_CLASS_VAR_PARAM
:
1012 case OBERON_CLASS_PARAM
:
1013 if(proc
-> type
-> class != OBERON_TYPE_PROCEDURE
)
1015 oberon_error(ctx
, "not a procedure");
1019 oberon_error(ctx
, "not a procedure");
1025 if(proc
-> genproc
== NULL
)
1027 oberon_error(ctx
, "requres non-typed procedure");
1030 proc
-> genproc(ctx
, num_args
, list_args
);
1034 if(proc
-> type
-> base
-> class != OBERON_TYPE_VOID
)
1036 oberon_error(ctx
, "attempt to call function as non-typed procedure");
1039 oberon_expr_t
* call
;
1040 call
= oberon_new_item(MODE_CALL
, proc
-> type
-> base
, 1);
1041 call
-> item
.var
= proc
;
1042 call
-> item
.num_args
= num_args
;
1043 call
-> item
.args
= list_args
;
1044 oberon_autocast_call(ctx
, call
);
1045 oberon_generate_call_proc(ctx
, call
);
1053 || ((x) == INTEGER) \
1054 || ((x) == LPAREN) \
1059 static oberon_expr_t
*
1060 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1062 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
1064 oberon_error(ctx
, "not a pointer");
1067 assert(expr
-> is_item
);
1069 oberon_expr_t
* selector
;
1070 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
, expr
-> read_only
);
1071 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1076 static oberon_expr_t
*
1077 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
1079 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
1081 desig
= oberno_make_dereferencing(ctx
, desig
);
1084 assert(desig
-> is_item
);
1086 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
1088 oberon_error(ctx
, "not array");
1091 oberon_type_t
* base
;
1092 base
= desig
-> result
-> base
;
1094 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
1096 oberon_error(ctx
, "index must be integer");
1099 // Статическая проверка границ массива
1100 if(desig
-> result
-> size
!= 0)
1102 if(index
-> is_item
)
1104 if(index
-> item
.mode
== MODE_INTEGER
)
1106 int arr_size
= desig
-> result
-> size
;
1107 int index_int
= index
-> item
.integer
;
1108 if(index_int
< 0 || index_int
> arr_size
- 1)
1110 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
1116 oberon_expr_t
* selector
;
1117 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
1118 selector
-> item
.parent
= (oberon_item_t
*) desig
;
1119 selector
-> item
.num_args
= 1;
1120 selector
-> item
.args
= index
;
1125 static oberon_expr_t
*
1126 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
1128 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
1130 expr
= oberno_make_dereferencing(ctx
, expr
);
1133 assert(expr
-> is_item
== 1);
1135 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
1137 oberon_error(ctx
, "not record");
1140 oberon_type_t
* rec
= expr
-> result
;
1142 oberon_object_t
* field
;
1143 field
= oberon_find_field(ctx
, rec
, name
);
1145 if(field
-> export
== 0)
1147 if(field
-> module
!= ctx
-> mod
)
1149 oberon_error(ctx
, "field not exported");
1154 if(field
-> read_only
)
1156 if(field
-> module
!= ctx
-> mod
)
1162 oberon_expr_t
* selector
;
1163 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
1164 selector
-> item
.var
= field
;
1165 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1170 #define ISSELECTOR(x) \
1173 || ((x) == UPARROW))
1175 static oberon_object_t
*
1176 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
1179 oberon_object_t
* x
;
1181 name
= oberon_assert_ident(ctx
);
1182 x
= oberon_find_object(ctx
-> decl
, name
, check
);
1186 if(x
-> class == OBERON_CLASS_MODULE
)
1188 oberon_assert_token(ctx
, DOT
);
1189 name
= oberon_assert_ident(ctx
);
1190 /* Наличие объектов в левых модулях всегда проверяется */
1191 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1193 if(x
-> export
== 0)
1195 oberon_error(ctx
, "not exported");
1208 static oberon_expr_t
*
1209 oberon_designator(oberon_context_t
* ctx
)
1212 oberon_object_t
* var
;
1213 oberon_expr_t
* expr
;
1215 var
= oberon_qualident(ctx
, NULL
, 1);
1218 if(var
-> read_only
)
1220 if(var
-> module
!= ctx
-> mod
)
1226 switch(var
-> class)
1228 case OBERON_CLASS_CONST
:
1230 expr
= (oberon_expr_t
*) var
-> value
;
1232 case OBERON_CLASS_VAR
:
1233 case OBERON_CLASS_VAR_PARAM
:
1234 case OBERON_CLASS_PARAM
:
1235 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
1237 case OBERON_CLASS_PROC
:
1238 expr
= oberon_new_item(MODE_VAR
, var
-> type
, 1);
1241 oberon_error(ctx
, "invalid designator");
1244 expr
-> item
.var
= var
;
1246 while(ISSELECTOR(ctx
-> token
))
1248 switch(ctx
-> token
)
1251 oberon_assert_token(ctx
, DOT
);
1252 name
= oberon_assert_ident(ctx
);
1253 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1256 oberon_assert_token(ctx
, LBRACE
);
1257 int num_indexes
= 0;
1258 oberon_expr_t
* indexes
= NULL
;
1259 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1260 oberon_assert_token(ctx
, RBRACE
);
1262 for(int i
= 0; i
< num_indexes
; i
++)
1264 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1265 indexes
= indexes
-> next
;
1269 oberon_assert_token(ctx
, UPARROW
);
1270 expr
= oberno_make_dereferencing(ctx
, expr
);
1273 oberon_error(ctx
, "oberon_designator: wat");
1280 static oberon_expr_t
*
1281 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1283 assert(expr
-> is_item
== 1);
1285 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1286 if(ctx
-> token
== LPAREN
)
1288 oberon_assert_token(ctx
, LPAREN
);
1291 oberon_expr_t
* arguments
= NULL
;
1293 if(ISEXPR(ctx
-> token
))
1295 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1298 expr
= oberon_make_call_func(ctx
, expr
-> item
.var
, num_args
, arguments
);
1300 oberon_assert_token(ctx
, RPAREN
);
1307 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1309 assert(expr
-> is_item
== 1);
1312 oberon_expr_t
* arguments
= NULL
;
1314 if(ctx
-> token
== LPAREN
)
1316 oberon_assert_token(ctx
, LPAREN
);
1318 if(ISEXPR(ctx
-> token
))
1320 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1323 oberon_assert_token(ctx
, RPAREN
);
1326 /* Вызов происходит даже без скобок */
1327 oberon_make_call_proc(ctx
, expr
-> item
.var
, num_args
, arguments
);
1330 static oberon_type_t
*
1331 oberon_get_type_of_int_value(oberon_context_t
* ctx
, int64_t i
)
1333 if(i
>= -128 && i
<= 127)
1335 return ctx
-> byte_type
;
1337 else if(i
>= -32768 && i
<= 32767)
1339 return ctx
-> shortint_type
;
1341 else if(i
>= -2147483648 && i
<= 2147483647)
1343 return ctx
-> int_type
;
1347 return ctx
-> longint_type
;
1351 static oberon_expr_t
*
1352 oberon_factor(oberon_context_t
* ctx
)
1354 oberon_expr_t
* expr
;
1355 oberon_type_t
* result
;
1357 switch(ctx
-> token
)
1360 expr
= oberon_designator(ctx
);
1361 expr
= oberon_opt_func_parens(ctx
, expr
);
1364 result
= oberon_get_type_of_int_value(ctx
, ctx
-> integer
);
1365 expr
= oberon_new_item(MODE_INTEGER
, result
, 1);
1366 expr
-> item
.integer
= ctx
-> integer
;
1367 oberon_assert_token(ctx
, INTEGER
);
1370 result
= (ctx
-> longmode
) ? (ctx
-> longreal_type
) : (ctx
-> real_type
);
1371 expr
= oberon_new_item(MODE_REAL
, result
, 1);
1372 expr
-> item
.real
= ctx
-> real
;
1373 oberon_assert_token(ctx
, REAL
);
1376 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1377 expr
-> item
.boolean
= true;
1378 oberon_assert_token(ctx
, TRUE
);
1381 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, 1);
1382 expr
-> item
.boolean
= false;
1383 oberon_assert_token(ctx
, FALSE
);
1386 oberon_assert_token(ctx
, LPAREN
);
1387 expr
= oberon_expr(ctx
);
1388 oberon_assert_token(ctx
, RPAREN
);
1391 oberon_assert_token(ctx
, NOT
);
1392 expr
= oberon_factor(ctx
);
1393 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1396 oberon_assert_token(ctx
, NIL
);
1397 expr
= oberon_new_item(MODE_NIL
, ctx
-> void_ptr_type
, 1);
1400 oberon_error(ctx
, "invalid expression");
1406 #define ITMAKESBOOLEAN(x) \
1407 (((x) >= EQUAL && (x) <= GEQ) || ((x) == OR) || ((x) == AND))
1409 #define ITUSEONLYINTEGER(x) \
1410 ((x) >= LESS && (x) <= GEQ)
1412 #define ITUSEONLYBOOLEAN(x) \
1413 (((x) == OR) || ((x) == AND))
1415 static oberon_expr_t
*
1416 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1418 oberon_expr_t
* expr
;
1419 oberon_type_t
* result
;
1421 if(ITMAKESBOOLEAN(token
))
1423 if(ITUSEONLYINTEGER(token
))
1425 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1426 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1428 oberon_error(ctx
, "used only with integer types");
1431 else if(ITUSEONLYBOOLEAN(token
))
1433 if(a
-> result
-> class != OBERON_TYPE_BOOLEAN
1434 || b
-> result
-> class != OBERON_TYPE_BOOLEAN
)
1436 oberon_error(ctx
, "used only with boolean type");
1440 result
= ctx
-> bool_type
;
1444 expr
= oberon_new_operator(OP_EQ
, result
, a
, b
);
1446 else if(token
== NEQ
)
1448 expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
);
1450 else if(token
== LESS
)
1452 expr
= oberon_new_operator(OP_LSS
, result
, a
, b
);
1454 else if(token
== LEQ
)
1456 expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
);
1458 else if(token
== GREAT
)
1460 expr
= oberon_new_operator(OP_GRT
, result
, a
, b
);
1462 else if(token
== GEQ
)
1464 expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
);
1466 else if(token
== OR
)
1468 expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
);
1470 else if(token
== AND
)
1472 expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
);
1476 oberon_error(ctx
, "oberon_make_bin_op: bool wat");
1479 else if(token
== SLASH
)
1481 if(a
-> result
-> class != OBERON_TYPE_REAL
)
1483 if(a
-> result
-> class == OBERON_TYPE_INTEGER
)
1485 oberon_error(ctx
, "TODO cast int -> real");
1489 oberon_error(ctx
, "operator / requires numeric type");
1493 if(b
-> result
-> class != OBERON_TYPE_REAL
)
1495 if(b
-> result
-> class == OBERON_TYPE_INTEGER
)
1497 oberon_error(ctx
, "TODO cast int -> real");
1501 oberon_error(ctx
, "operator / requires numeric type");
1505 oberon_autocast_binary_op(ctx
, &a
, &b
);
1506 expr
= oberon_new_operator(OP_DIV
, a
-> result
, a
, b
);
1508 else if(token
== DIV
)
1510 if(a
-> result
-> class != OBERON_TYPE_INTEGER
1511 || b
-> result
-> class != OBERON_TYPE_INTEGER
)
1513 oberon_error(ctx
, "operator DIV requires integer type");
1516 oberon_autocast_binary_op(ctx
, &a
, &b
);
1517 expr
= oberon_new_operator(OP_DIV
, a
-> result
, a
, b
);
1521 oberon_autocast_binary_op(ctx
, &a
, &b
);
1525 expr
= oberon_new_operator(OP_ADD
, a
-> result
, a
, b
);
1527 else if(token
== MINUS
)
1529 expr
= oberon_new_operator(OP_SUB
, a
-> result
, a
, b
);
1531 else if(token
== STAR
)
1533 expr
= oberon_new_operator(OP_MUL
, a
-> result
, a
, b
);
1535 else if(token
== MOD
)
1537 expr
= oberon_new_operator(OP_MOD
, a
-> result
, a
, b
);
1541 oberon_error(ctx
, "oberon_make_bin_op: bin wat");
1548 #define ISMULOP(x) \
1549 ((x) >= STAR && (x) <= AND)
1551 static oberon_expr_t
*
1552 oberon_term_expr(oberon_context_t
* ctx
)
1554 oberon_expr_t
* expr
;
1556 expr
= oberon_factor(ctx
);
1557 while(ISMULOP(ctx
-> token
))
1559 int token
= ctx
-> token
;
1560 oberon_read_token(ctx
);
1562 oberon_expr_t
* inter
= oberon_factor(ctx
);
1563 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1569 #define ISADDOP(x) \
1570 ((x) >= PLUS && (x) <= OR)
1572 static oberon_expr_t
*
1573 oberon_simple_expr(oberon_context_t
* ctx
)
1575 oberon_expr_t
* expr
;
1578 if(ctx
-> token
== PLUS
)
1581 oberon_assert_token(ctx
, PLUS
);
1583 else if(ctx
-> token
== MINUS
)
1586 oberon_assert_token(ctx
, MINUS
);
1589 expr
= oberon_term_expr(ctx
);
1593 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1596 while(ISADDOP(ctx
-> token
))
1598 int token
= ctx
-> token
;
1599 oberon_read_token(ctx
);
1601 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1602 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1608 #define ISRELATION(x) \
1609 ((x) >= EQUAL && (x) <= GEQ)
1611 static oberon_expr_t
*
1612 oberon_expr(oberon_context_t
* ctx
)
1614 oberon_expr_t
* expr
;
1616 expr
= oberon_simple_expr(ctx
);
1617 while(ISRELATION(ctx
-> token
))
1619 int token
= ctx
-> token
;
1620 oberon_read_token(ctx
);
1622 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
1623 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1629 static oberon_item_t
*
1630 oberon_const_expr(oberon_context_t
* ctx
)
1632 oberon_expr_t
* expr
;
1633 expr
= oberon_expr(ctx
);
1635 if(expr
-> is_item
== 0)
1637 oberon_error(ctx
, "const expression are required");
1640 return (oberon_item_t
*) expr
;
1643 // =======================================================================
1645 // =======================================================================
1647 static void oberon_decl_seq(oberon_context_t
* ctx
);
1648 static void oberon_statement_seq(oberon_context_t
* ctx
);
1649 static void oberon_initialize_decl(oberon_context_t
* ctx
);
1652 oberon_expect_token(oberon_context_t
* ctx
, int token
)
1654 if(ctx
-> token
!= token
)
1656 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
1661 oberon_assert_token(oberon_context_t
* ctx
, int token
)
1663 oberon_expect_token(ctx
, token
);
1664 oberon_read_token(ctx
);
1668 oberon_assert_ident(oberon_context_t
* ctx
)
1670 oberon_expect_token(ctx
, IDENT
);
1671 char * ident
= ctx
-> string
;
1672 oberon_read_token(ctx
);
1677 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
1679 switch(ctx
-> token
)
1682 oberon_assert_token(ctx
, STAR
);
1687 oberon_assert_token(ctx
, MINUS
);
1698 static oberon_object_t
*
1699 oberon_ident_def(oberon_context_t
* ctx
, int class)
1704 oberon_object_t
* x
;
1706 name
= oberon_assert_ident(ctx
);
1707 oberon_def(ctx
, &export
, &read_only
);
1709 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
);
1714 oberon_ident_list(oberon_context_t
* ctx
, int class, int * num
, oberon_object_t
** list
)
1717 *list
= oberon_ident_def(ctx
, class);
1718 while(ctx
-> token
== COMMA
)
1720 oberon_assert_token(ctx
, COMMA
);
1721 oberon_ident_def(ctx
, class);
1727 oberon_var_decl(oberon_context_t
* ctx
)
1730 oberon_object_t
* list
;
1731 oberon_type_t
* type
;
1732 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1734 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, &num
, &list
);
1735 oberon_assert_token(ctx
, COLON
);
1736 oberon_type(ctx
, &type
);
1738 oberon_object_t
* var
= list
;
1739 for(int i
= 0; i
< num
; i
++)
1746 static oberon_object_t
*
1747 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
1749 int class = OBERON_CLASS_PARAM
;
1750 if(ctx
-> token
== VAR
)
1752 oberon_read_token(ctx
);
1753 class = OBERON_CLASS_VAR_PARAM
;
1757 oberon_object_t
* list
;
1758 oberon_ident_list(ctx
, class, &num
, &list
);
1760 oberon_assert_token(ctx
, COLON
);
1762 oberon_type_t
* type
;
1763 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1764 oberon_type(ctx
, &type
);
1766 oberon_object_t
* param
= list
;
1767 for(int i
= 0; i
< num
; i
++)
1769 param
-> type
= type
;
1770 param
= param
-> next
;
1777 #define ISFPSECTION \
1778 ((ctx -> token == VAR) || (ctx -> token == IDENT))
1781 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
1783 oberon_assert_token(ctx
, LPAREN
);
1787 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
1788 while(ctx
-> token
== SEMICOLON
)
1790 oberon_assert_token(ctx
, SEMICOLON
);
1791 oberon_fp_section(ctx
, &signature
-> num_decl
);
1795 oberon_assert_token(ctx
, RPAREN
);
1797 if(ctx
-> token
== COLON
)
1799 oberon_assert_token(ctx
, COLON
);
1801 oberon_object_t
* typeobj
;
1802 typeobj
= oberon_qualident(ctx
, NULL
, 1);
1803 if(typeobj
-> class != OBERON_CLASS_TYPE
)
1805 oberon_error(ctx
, "function result is not type");
1807 signature
-> base
= typeobj
-> type
;
1812 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
1814 oberon_type_t
* signature
;
1816 signature
-> class = OBERON_TYPE_PROCEDURE
;
1817 signature
-> num_decl
= 0;
1818 signature
-> base
= ctx
-> void_type
;
1819 signature
-> decl
= NULL
;
1821 if(ctx
-> token
== LPAREN
)
1823 oberon_formal_pars(ctx
, signature
);
1828 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
1830 if(a
-> num_decl
!= b
-> num_decl
)
1832 oberon_error(ctx
, "number parameters not matched");
1835 int num_param
= a
-> num_decl
;
1836 oberon_object_t
* param_a
= a
-> decl
;
1837 oberon_object_t
* param_b
= b
-> decl
;
1838 for(int i
= 0; i
< num_param
; i
++)
1840 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
1842 oberon_error(ctx
, "param %i name not matched", i
+ 1);
1845 if(param_a
-> type
!= param_b
-> type
)
1847 oberon_error(ctx
, "param %i type not matched", i
+ 1);
1850 param_a
= param_a
-> next
;
1851 param_b
= param_b
-> next
;
1856 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1858 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
1859 oberon_type_t
* result_type
= proc
-> type
-> base
;
1861 if(result_type
-> class == OBERON_TYPE_VOID
)
1865 oberon_error(ctx
, "procedure has no result type");
1872 oberon_error(ctx
, "procedure requires expression on result");
1875 expr
= oberon_autocast_to(ctx
, expr
, result_type
);
1878 proc
-> has_return
= 1;
1880 oberon_generate_return(ctx
, expr
);
1884 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
1886 oberon_assert_token(ctx
, SEMICOLON
);
1888 ctx
-> decl
= proc
-> scope
;
1890 oberon_decl_seq(ctx
);
1892 oberon_generate_begin_proc(ctx
, proc
);
1894 if(ctx
-> token
== BEGIN
)
1896 oberon_assert_token(ctx
, BEGIN
);
1897 oberon_statement_seq(ctx
);
1900 oberon_assert_token(ctx
, END
);
1901 char * name
= oberon_assert_ident(ctx
);
1902 if(strcmp(name
, proc
-> name
) != 0)
1904 oberon_error(ctx
, "procedure name not matched");
1907 if(proc
-> type
-> base
-> class == OBERON_TYPE_VOID
1908 && proc
-> has_return
== 0)
1910 oberon_make_return(ctx
, NULL
);
1913 if(proc
-> has_return
== 0)
1915 oberon_error(ctx
, "procedure requires return");
1918 oberon_generate_end_proc(ctx
);
1919 oberon_close_scope(ctx
-> decl
);
1923 oberon_proc_decl(oberon_context_t
* ctx
)
1925 oberon_assert_token(ctx
, PROCEDURE
);
1928 if(ctx
-> token
== UPARROW
)
1930 oberon_assert_token(ctx
, UPARROW
);
1937 name
= oberon_assert_ident(ctx
);
1938 oberon_def(ctx
, &export
, &read_only
);
1940 oberon_scope_t
* proc_scope
;
1941 proc_scope
= oberon_open_scope(ctx
);
1942 ctx
-> decl
-> local
= 1;
1944 oberon_type_t
* signature
;
1945 signature
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
1946 oberon_opt_formal_pars(ctx
, &signature
);
1948 oberon_initialize_decl(ctx
);
1949 oberon_generator_init_type(ctx
, signature
);
1950 oberon_close_scope(ctx
-> decl
);
1952 oberon_object_t
* proc
;
1953 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
1956 if(proc
-> class != OBERON_CLASS_PROC
)
1958 oberon_error(ctx
, "mult definition");
1965 oberon_error(ctx
, "mult procedure definition");
1969 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
1971 oberon_error(ctx
, "export type not matched");
1974 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
1978 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
);
1979 proc
-> type
= signature
;
1980 proc
-> scope
= proc_scope
;
1981 oberon_generator_init_proc(ctx
, proc
);
1984 proc
-> scope
-> parent
= proc
;
1989 oberon_proc_decl_body(ctx
, proc
);
1994 oberon_const_decl(oberon_context_t
* ctx
)
1996 oberon_item_t
* value
;
1997 oberon_object_t
* constant
;
1999 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
);
2000 oberon_assert_token(ctx
, EQUAL
);
2001 value
= oberon_const_expr(ctx
);
2002 constant
-> value
= value
;
2006 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
2008 if(size
-> is_item
== 0)
2010 oberon_error(ctx
, "requires constant");
2013 if(size
-> item
.mode
!= MODE_INTEGER
)
2015 oberon_error(ctx
, "requires integer constant");
2018 oberon_type_t
* arr
;
2020 arr
-> class = OBERON_TYPE_ARRAY
;
2021 arr
-> size
= size
-> item
.integer
;
2026 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
)
2028 if(ctx
-> token
== IDENT
)
2031 oberon_object_t
* list
;
2032 oberon_type_t
* type
;
2033 type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2035 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, &num
, &list
);
2036 oberon_assert_token(ctx
, COLON
);
2037 oberon_type(ctx
, &type
);
2039 oberon_object_t
* field
= list
;
2040 for(int i
= 0; i
< num
; i
++)
2042 field
-> type
= type
;
2043 field
= field
-> next
;
2046 rec
-> num_decl
+= num
;
2051 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2054 oberon_object_t
* to
;
2056 to
= oberon_qualident(ctx
, &name
, 0);
2058 //name = oberon_assert_ident(ctx);
2059 //to = oberon_find_object(ctx -> decl, name, 0);
2063 if(to
-> class != OBERON_CLASS_TYPE
)
2065 oberon_error(ctx
, "not a type");
2070 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, 0, 0);
2071 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2077 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
2080 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2084 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
2092 oberon_type_t
* dim
;
2093 dim
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2095 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
2097 oberon_make_array_type(ctx
, sizes
, dim
, type
);
2101 oberon_make_open_array(oberon_context_t
* ctx
, oberon_type_t
* base
, oberon_type_t
* type
)
2103 type
-> class = OBERON_TYPE_ARRAY
;
2105 type
-> base
= base
;
2109 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2111 if(ctx
-> token
== IDENT
)
2113 oberon_qualident_type(ctx
, type
);
2115 else if(ctx
-> token
== ARRAY
)
2117 oberon_assert_token(ctx
, ARRAY
);
2120 oberon_expr_t
* sizes
;
2122 if(ISEXPR(ctx
-> token
))
2124 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
2127 oberon_assert_token(ctx
, OF
);
2129 oberon_type_t
* base
;
2130 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2131 oberon_type(ctx
, &base
);
2135 oberon_make_open_array(ctx
, base
, *type
);
2139 oberon_make_multiarray(ctx
, sizes
, base
, type
);
2142 else if(ctx
-> token
== RECORD
)
2144 oberon_type_t
* rec
;
2146 rec
-> class = OBERON_TYPE_RECORD
;
2147 rec
-> module
= ctx
-> mod
;
2149 oberon_scope_t
* record_scope
;
2150 record_scope
= oberon_open_scope(ctx
);
2151 record_scope
-> local
= 1;
2152 record_scope
-> parent
= NULL
;
2153 record_scope
-> parent_type
= rec
;
2155 oberon_assert_token(ctx
, RECORD
);
2156 oberon_field_list(ctx
, rec
);
2157 while(ctx
-> token
== SEMICOLON
)
2159 oberon_assert_token(ctx
, SEMICOLON
);
2160 oberon_field_list(ctx
, rec
);
2162 oberon_assert_token(ctx
, END
);
2164 rec
-> decl
= record_scope
-> list
-> next
;
2165 oberon_close_scope(record_scope
);
2169 else if(ctx
-> token
== POINTER
)
2171 oberon_assert_token(ctx
, POINTER
);
2172 oberon_assert_token(ctx
, TO
);
2174 oberon_type_t
* base
;
2175 base
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2176 oberon_type(ctx
, &base
);
2178 oberon_type_t
* ptr
;
2180 ptr
-> class = OBERON_TYPE_POINTER
;
2183 else if(ctx
-> token
== PROCEDURE
)
2185 oberon_open_scope(ctx
);
2186 oberon_assert_token(ctx
, PROCEDURE
);
2187 oberon_opt_formal_pars(ctx
, type
);
2188 oberon_close_scope(ctx
-> decl
);
2192 oberon_error(ctx
, "invalid type declaration");
2197 oberon_type_decl(oberon_context_t
* ctx
)
2200 oberon_object_t
* newtype
;
2201 oberon_type_t
* type
;
2205 name
= oberon_assert_ident(ctx
);
2206 oberon_def(ctx
, &export
, &read_only
);
2208 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
2211 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
);
2212 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2213 assert(newtype
-> type
);
2217 if(newtype
-> class != OBERON_CLASS_TYPE
)
2219 oberon_error(ctx
, "mult definition");
2222 if(newtype
-> linked
)
2224 oberon_error(ctx
, "mult definition - already linked");
2227 newtype
-> export
= export
;
2228 newtype
-> read_only
= read_only
;
2231 oberon_assert_token(ctx
, EQUAL
);
2233 type
= newtype
-> type
;
2234 oberon_type(ctx
, &type
);
2236 if(type
-> class == OBERON_TYPE_VOID
)
2238 oberon_error(ctx
, "recursive alias declaration");
2241 newtype
-> type
= type
;
2242 newtype
-> linked
= 1;
2245 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2246 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2249 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
2251 if(type
-> class != OBERON_TYPE_POINTER
2252 && type
-> class != OBERON_TYPE_ARRAY
)
2257 if(type
-> recursive
)
2259 oberon_error(ctx
, "recursive pointer declaration");
2262 if(type
-> class == OBERON_TYPE_POINTER
2263 && type
-> base
-> class == OBERON_TYPE_POINTER
)
2265 oberon_error(ctx
, "attempt to make pointer to pointer");
2268 type
-> recursive
= 1;
2270 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
2272 type
-> recursive
= 0;
2276 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
2278 if(type
-> class != OBERON_TYPE_RECORD
)
2283 if(type
-> recursive
)
2285 oberon_error(ctx
, "recursive record declaration");
2288 type
-> recursive
= 1;
2290 int num_fields
= type
-> num_decl
;
2291 oberon_object_t
* field
= type
-> decl
;
2292 for(int i
= 0; i
< num_fields
; i
++)
2294 oberon_prevent_recursive_object(ctx
, field
);
2295 field
= field
-> next
;
2298 type
-> recursive
= 0;
2301 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2303 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2308 if(type
-> recursive
)
2310 oberon_error(ctx
, "recursive procedure declaration");
2313 type
-> recursive
= 1;
2315 int num_fields
= type
-> num_decl
;
2316 oberon_object_t
* field
= type
-> decl
;
2317 for(int i
= 0; i
< num_fields
; i
++)
2319 oberon_prevent_recursive_object(ctx
, field
);
2320 field
= field
-> next
;
2323 type
-> recursive
= 0;
2327 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2329 if(type
-> class != OBERON_TYPE_ARRAY
)
2334 if(type
-> recursive
)
2336 oberon_error(ctx
, "recursive array declaration");
2339 type
-> recursive
= 1;
2341 oberon_prevent_recursive_type(ctx
, type
-> base
);
2343 type
-> recursive
= 0;
2347 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2349 if(type
-> class == OBERON_TYPE_POINTER
)
2351 oberon_prevent_recursive_pointer(ctx
, type
);
2353 else if(type
-> class == OBERON_TYPE_RECORD
)
2355 oberon_prevent_recursive_record(ctx
, type
);
2357 else if(type
-> class == OBERON_TYPE_ARRAY
)
2359 oberon_prevent_recursive_array(ctx
, type
);
2361 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2363 oberon_prevent_recursive_procedure(ctx
, type
);
2368 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2372 case OBERON_CLASS_VAR
:
2373 case OBERON_CLASS_TYPE
:
2374 case OBERON_CLASS_PARAM
:
2375 case OBERON_CLASS_VAR_PARAM
:
2376 case OBERON_CLASS_FIELD
:
2377 oberon_prevent_recursive_type(ctx
, x
-> type
);
2379 case OBERON_CLASS_CONST
:
2380 case OBERON_CLASS_PROC
:
2381 case OBERON_CLASS_MODULE
:
2384 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2390 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2392 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2396 oberon_prevent_recursive_object(ctx
, x
);
2401 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2402 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2405 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2407 if(type
-> class != OBERON_TYPE_RECORD
)
2412 int num_fields
= type
-> num_decl
;
2413 oberon_object_t
* field
= type
-> decl
;
2414 for(int i
= 0; i
< num_fields
; i
++)
2416 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2418 oberon_initialize_type(ctx
, field
-> type
);
2421 oberon_initialize_object(ctx
, field
);
2422 field
= field
-> next
;
2425 oberon_generator_init_record(ctx
, type
);
2429 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2431 if(type
-> class == OBERON_TYPE_VOID
)
2433 oberon_error(ctx
, "undeclarated type");
2436 if(type
-> initialized
)
2441 type
-> initialized
= 1;
2443 if(type
-> class == OBERON_TYPE_POINTER
)
2445 oberon_initialize_type(ctx
, type
-> base
);
2446 oberon_generator_init_type(ctx
, type
);
2448 else if(type
-> class == OBERON_TYPE_ARRAY
)
2450 if(type
-> size
!= 0)
2452 if(type
-> base
-> class == OBERON_TYPE_ARRAY
)
2454 if(type
-> base
-> size
== 0)
2456 oberon_error(ctx
, "open array not allowed as array element");
2461 oberon_initialize_type(ctx
, type
-> base
);
2462 oberon_generator_init_type(ctx
, type
);
2464 else if(type
-> class == OBERON_TYPE_RECORD
)
2466 oberon_generator_init_type(ctx
, type
);
2467 oberon_initialize_record_fields(ctx
, type
);
2469 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2471 int num_fields
= type
-> num_decl
;
2472 oberon_object_t
* field
= type
-> decl
;
2473 for(int i
= 0; i
< num_fields
; i
++)
2475 oberon_initialize_object(ctx
, field
);
2476 field
= field
-> next
;
2479 oberon_generator_init_type(ctx
, type
);
2483 oberon_generator_init_type(ctx
, type
);
2488 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2490 if(x
-> initialized
)
2495 x
-> initialized
= 1;
2499 case OBERON_CLASS_TYPE
:
2500 oberon_initialize_type(ctx
, x
-> type
);
2502 case OBERON_CLASS_VAR
:
2503 case OBERON_CLASS_FIELD
:
2504 if(x
-> type
-> class == OBERON_TYPE_ARRAY
)
2506 if(x
-> type
-> size
== 0)
2508 oberon_error(ctx
, "open array not allowed as variable or field");
2511 oberon_initialize_type(ctx
, x
-> type
);
2512 oberon_generator_init_var(ctx
, x
);
2514 case OBERON_CLASS_PARAM
:
2515 case OBERON_CLASS_VAR_PARAM
:
2516 oberon_initialize_type(ctx
, x
-> type
);
2517 oberon_generator_init_var(ctx
, x
);
2519 case OBERON_CLASS_CONST
:
2520 case OBERON_CLASS_PROC
:
2521 case OBERON_CLASS_MODULE
:
2524 oberon_error(ctx
, "oberon_initialize_object: wat");
2530 oberon_initialize_decl(oberon_context_t
* ctx
)
2532 oberon_object_t
* x
= ctx
-> decl
-> list
;
2536 oberon_initialize_object(ctx
, x
-> next
);
2542 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
2544 oberon_object_t
* x
= ctx
-> decl
-> list
;
2548 if(x
-> next
-> class == OBERON_CLASS_PROC
)
2550 if(x
-> next
-> linked
== 0)
2552 oberon_error(ctx
, "unresolved forward declaration");
2560 oberon_decl_seq(oberon_context_t
* ctx
)
2562 if(ctx
-> token
== CONST
)
2564 oberon_assert_token(ctx
, CONST
);
2565 while(ctx
-> token
== IDENT
)
2567 oberon_const_decl(ctx
);
2568 oberon_assert_token(ctx
, SEMICOLON
);
2572 if(ctx
-> token
== TYPE
)
2574 oberon_assert_token(ctx
, TYPE
);
2575 while(ctx
-> token
== IDENT
)
2577 oberon_type_decl(ctx
);
2578 oberon_assert_token(ctx
, SEMICOLON
);
2582 if(ctx
-> token
== VAR
)
2584 oberon_assert_token(ctx
, VAR
);
2585 while(ctx
-> token
== IDENT
)
2587 oberon_var_decl(ctx
);
2588 oberon_assert_token(ctx
, SEMICOLON
);
2592 oberon_prevent_recursive_decl(ctx
);
2593 oberon_initialize_decl(ctx
);
2595 while(ctx
-> token
== PROCEDURE
)
2597 oberon_proc_decl(ctx
);
2598 oberon_assert_token(ctx
, SEMICOLON
);
2601 oberon_prevent_undeclarated_procedures(ctx
);
2605 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
2607 if(dst
-> read_only
)
2609 oberon_error(ctx
, "read-only destination");
2612 src
= oberon_autocast_to(ctx
, src
, dst
-> result
);
2613 oberon_generate_assign(ctx
, src
, dst
);
2617 oberon_statement(oberon_context_t
* ctx
)
2619 oberon_expr_t
* item1
;
2620 oberon_expr_t
* item2
;
2622 if(ctx
-> token
== IDENT
)
2624 item1
= oberon_designator(ctx
);
2625 if(ctx
-> token
== ASSIGN
)
2627 oberon_assert_token(ctx
, ASSIGN
);
2628 item2
= oberon_expr(ctx
);
2629 oberon_assign(ctx
, item2
, item1
);
2633 oberon_opt_proc_parens(ctx
, item1
);
2636 else if(ctx
-> token
== RETURN
)
2638 oberon_assert_token(ctx
, RETURN
);
2639 if(ISEXPR(ctx
-> token
))
2641 oberon_expr_t
* expr
;
2642 expr
= oberon_expr(ctx
);
2643 oberon_make_return(ctx
, expr
);
2647 oberon_make_return(ctx
, NULL
);
2653 oberon_statement_seq(oberon_context_t
* ctx
)
2655 oberon_statement(ctx
);
2656 while(ctx
-> token
== SEMICOLON
)
2658 oberon_assert_token(ctx
, SEMICOLON
);
2659 oberon_statement(ctx
);
2664 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
2666 oberon_module_t
* m
= ctx
-> module_list
;
2667 while(m
&& strcmp(m
-> name
, name
) != 0)
2675 code
= ctx
-> import_module(name
);
2678 oberon_error(ctx
, "no such module");
2681 m
= oberon_compile_module(ctx
, code
);
2687 oberon_error(ctx
, "cyclic module import");
2690 oberon_object_t
* ident
;
2691 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, 0, 0);
2692 ident
-> module
= m
;
2696 oberon_import_decl(oberon_context_t
* ctx
)
2701 alias
= name
= oberon_assert_ident(ctx
);
2702 if(ctx
-> token
== ASSIGN
)
2704 oberon_assert_token(ctx
, ASSIGN
);
2705 name
= oberon_assert_ident(ctx
);
2708 oberon_import_module(ctx
, alias
, name
);
2712 oberon_import_list(oberon_context_t
* ctx
)
2714 oberon_assert_token(ctx
, IMPORT
);
2716 oberon_import_decl(ctx
);
2717 while(ctx
-> token
== COMMA
)
2719 oberon_assert_token(ctx
, COMMA
);
2720 oberon_import_decl(ctx
);
2723 oberon_assert_token(ctx
, SEMICOLON
);
2727 oberon_parse_module(oberon_context_t
* ctx
)
2731 oberon_read_token(ctx
);
2733 oberon_assert_token(ctx
, MODULE
);
2734 name1
= oberon_assert_ident(ctx
);
2735 oberon_assert_token(ctx
, SEMICOLON
);
2736 ctx
-> mod
-> name
= name1
;
2738 oberon_generator_init_module(ctx
, ctx
-> mod
);
2740 if(ctx
-> token
== IMPORT
)
2742 oberon_import_list(ctx
);
2745 oberon_decl_seq(ctx
);
2747 oberon_generate_begin_module(ctx
);
2748 if(ctx
-> token
== BEGIN
)
2750 oberon_assert_token(ctx
, BEGIN
);
2751 oberon_statement_seq(ctx
);
2753 oberon_generate_end_module(ctx
);
2755 oberon_assert_token(ctx
, END
);
2756 name2
= oberon_assert_ident(ctx
);
2757 oberon_assert_token(ctx
, DOT
);
2759 if(strcmp(name1
, name2
) != 0)
2761 oberon_error(ctx
, "module name not matched");
2764 oberon_generator_fini_module(ctx
-> mod
);
2767 // =======================================================================
2769 // =======================================================================
2772 register_default_types(oberon_context_t
* ctx
)
2774 ctx
-> void_type
= oberon_new_type_ptr(OBERON_TYPE_VOID
);
2775 oberon_generator_init_type(ctx
, ctx
-> void_type
);
2777 ctx
-> void_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_POINTER
);
2778 ctx
-> void_ptr_type
-> base
= ctx
-> void_type
;
2779 oberon_generator_init_type(ctx
, ctx
-> void_ptr_type
);
2781 ctx
-> bool_type
= oberon_new_type_boolean();
2782 oberon_define_type(ctx
-> world_scope
, "BOOLEAN", ctx
-> bool_type
, 1);
2784 ctx
-> byte_type
= oberon_new_type_integer(1);
2785 oberon_define_type(ctx
-> world_scope
, "BYTE", ctx
-> byte_type
, 1);
2787 ctx
-> shortint_type
= oberon_new_type_integer(2);
2788 oberon_define_type(ctx
-> world_scope
, "SHORTINT", ctx
-> shortint_type
, 1);
2790 ctx
-> int_type
= oberon_new_type_integer(4);
2791 oberon_define_type(ctx
-> world_scope
, "INTEGER", ctx
-> int_type
, 1);
2793 ctx
-> longint_type
= oberon_new_type_integer(8);
2794 oberon_define_type(ctx
-> world_scope
, "LONGINT", ctx
-> longint_type
, 1);
2796 ctx
-> real_type
= oberon_new_type_real(4);
2797 oberon_define_type(ctx
-> world_scope
, "REAL", ctx
-> real_type
, 1);
2799 ctx
-> longreal_type
= oberon_new_type_real(8);
2800 oberon_define_type(ctx
-> world_scope
, "LONGREAL", ctx
-> longreal_type
, 1);
2804 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
2806 oberon_object_t
* proc
;
2807 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, 1, 0);
2808 proc
-> sysproc
= 1;
2809 proc
-> genfunc
= f
;
2810 proc
-> genproc
= p
;
2811 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
2814 static oberon_expr_t
*
2815 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2819 oberon_error(ctx
, "too few arguments");
2824 oberon_error(ctx
, "too mach arguments");
2827 oberon_expr_t
* arg
;
2830 oberon_type_t
* result_type
;
2831 result_type
= arg
-> result
;
2833 if(result_type
-> class != OBERON_TYPE_INTEGER
)
2835 oberon_error(ctx
, "ABS accepts only integers");
2839 oberon_expr_t
* expr
;
2840 expr
= oberon_new_operator(OP_ABS
, result_type
, arg
, NULL
);
2845 oberon_make_new_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
2849 oberon_error(ctx
, "too few arguments");
2852 oberon_expr_t
* dst
;
2855 oberon_type_t
* type
;
2856 type
= dst
-> result
;
2858 if(type
-> class != OBERON_TYPE_POINTER
)
2860 oberon_error(ctx
, "not a pointer");
2863 type
= type
-> base
;
2865 oberon_expr_t
* src
;
2866 src
= oberon_new_item(MODE_NEW
, dst
-> result
, 0);
2867 src
-> item
.num_args
= 0;
2868 src
-> item
.args
= NULL
;
2871 if(type
-> class == OBERON_TYPE_ARRAY
)
2873 if(type
-> size
== 0)
2875 oberon_type_t
* x
= type
;
2876 while(x
-> class == OBERON_TYPE_ARRAY
)
2886 if(num_args
< max_args
)
2888 oberon_error(ctx
, "too few arguments");
2891 if(num_args
> max_args
)
2893 oberon_error(ctx
, "too mach arguments");
2896 int num_sizes
= max_args
- 1;
2897 oberon_expr_t
* size_list
= list_args
-> next
;
2899 oberon_expr_t
* arg
= size_list
;
2900 for(int i
= 0; i
< max_args
- 1; i
++)
2902 if(arg
-> result
-> class != OBERON_TYPE_INTEGER
)
2904 oberon_error(ctx
, "size must be integer");
2909 src
-> item
.num_args
= num_sizes
;
2910 src
-> item
.args
= size_list
;
2912 else if(type
-> class != OBERON_TYPE_RECORD
)
2914 oberon_error(ctx
, "oberon_make_new_call: wat");
2917 if(num_args
> max_args
)
2919 oberon_error(ctx
, "too mach arguments");
2922 oberon_assign(ctx
, src
, dst
);
2926 oberon_create_context(ModuleImportCallback import_module
)
2928 oberon_context_t
* ctx
= calloc(1, sizeof *ctx
);
2930 oberon_scope_t
* world_scope
;
2931 world_scope
= oberon_open_scope(ctx
);
2932 ctx
-> world_scope
= world_scope
;
2934 ctx
-> import_module
= import_module
;
2936 oberon_generator_init_context(ctx
);
2938 register_default_types(ctx
);
2939 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
2940 oberon_new_intrinsic(ctx
, "NEW", NULL
, oberon_make_new_call
);
2946 oberon_destroy_context(oberon_context_t
* ctx
)
2948 oberon_generator_destroy_context(ctx
);
2953 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
2955 const char * code
= ctx
-> code
;
2956 int code_index
= ctx
-> code_index
;
2958 int token
= ctx
-> token
;
2959 char * string
= ctx
-> string
;
2960 int integer
= ctx
-> integer
;
2961 int real
= ctx
-> real
;
2962 bool longmode
= ctx
-> longmode
;
2963 oberon_scope_t
* decl
= ctx
-> decl
;
2964 oberon_module_t
* mod
= ctx
-> mod
;
2966 oberon_scope_t
* module_scope
;
2967 module_scope
= oberon_open_scope(ctx
);
2969 oberon_module_t
* module
;
2970 module
= calloc(1, sizeof *module
);
2971 module
-> decl
= module_scope
;
2972 module
-> next
= ctx
-> module_list
;
2974 ctx
-> mod
= module
;
2975 ctx
-> module_list
= module
;
2977 oberon_init_scaner(ctx
, newcode
);
2978 oberon_parse_module(ctx
);
2980 module
-> ready
= 1;
2983 ctx
-> code_index
= code_index
;
2985 ctx
-> token
= token
;
2986 ctx
-> string
= string
;
2987 ctx
-> integer
= integer
;
2989 ctx
-> longmode
= longmode
;