13 #include "../include/oberon.h"
15 #include "oberon-internals.h"
16 #include "oberon-type-compat.h"
17 #include "oberon-common.h"
18 #include "generator.h"
20 // =======================================================================
22 // =======================================================================
25 oberon_make_copy_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
);
27 static oberon_type_t
*
28 oberon_new_type_ptr(int class)
30 oberon_type_t
* x
= GC_MALLOC(sizeof *x
);
31 memset(x
, 0, sizeof *x
);
36 static oberon_type_t
*
37 oberon_new_type_integer(int size
)
40 x
= oberon_new_type_ptr(OBERON_TYPE_INTEGER
);
45 static oberon_type_t
*
46 oberon_new_type_boolean()
49 x
= oberon_new_type_ptr(OBERON_TYPE_BOOLEAN
);
53 static oberon_type_t
*
54 oberon_new_type_real(int size
)
57 x
= oberon_new_type_ptr(OBERON_TYPE_REAL
);
62 static oberon_type_t
*
63 oberon_new_type_char(int size
)
66 x
= oberon_new_type_ptr(OBERON_TYPE_CHAR
);
71 static oberon_type_t
*
72 oberon_new_type_string(int size
)
75 x
= oberon_new_type_ptr(OBERON_TYPE_STRING
);
80 static oberon_type_t
*
81 oberon_new_type_set(int size
)
84 x
= oberon_new_type_ptr(OBERON_TYPE_SET
);
89 static oberon_expr_t
*
90 oberon_new_operator(int op
, oberon_type_t
* result
, oberon_expr_t
* left
, oberon_expr_t
* right
)
92 oberon_oper_t
* operator;
93 operator = GC_MALLOC(sizeof *operator);
94 memset(operator, 0, sizeof *operator);
96 operator -> is_item
= 0;
97 operator -> result
= result
;
98 operator -> read_only
= 1;
100 operator -> left
= left
;
101 operator -> right
= right
;
103 return (oberon_expr_t
*) operator;
106 static oberon_expr_t
*
107 oberon_new_item(int mode
, oberon_type_t
* result
, int read_only
)
109 oberon_item_t
* item
;
110 item
= GC_MALLOC(sizeof *item
);
111 memset(item
, 0, sizeof *item
);
114 item
-> result
= result
;
115 item
-> read_only
= read_only
;
118 return (oberon_expr_t
*)item
;
121 static oberon_type_t
*
122 oberon_get_type_of_int_value(oberon_context_t
* ctx
, int64_t i
)
124 if(i
>= -128 && i
<= 127)
126 return ctx
-> byte_type
;
128 else if(i
>= -32768 && i
<= 32767)
130 return ctx
-> shortint_type
;
132 else if(i
>= -2147483648 && i
<= 2147483647)
134 return ctx
-> int_type
;
138 return ctx
-> longint_type
;
142 static oberon_expr_t
*
143 oberon_make_integer(oberon_context_t
* ctx
, int64_t i
)
145 oberon_expr_t
* expr
;
146 oberon_type_t
* result
;
147 result
= oberon_get_type_of_int_value(ctx
, i
);
148 expr
= oberon_new_item(MODE_INTEGER
, result
, true);
149 expr
-> item
.integer
= i
;
150 expr
-> item
.real
= i
;
154 static oberon_expr_t
*
155 oberon_make_system_byte(oberon_context_t
* ctx
, int64_t i
)
157 oberon_expr_t
* expr
;
158 expr
= oberon_new_item(MODE_SYSBYTE
, ctx
-> system_byte_type
, true);
159 expr
-> item
.integer
= i
;
160 expr
-> item
.real
= i
;
164 static oberon_expr_t
*
165 oberon_make_char(oberon_context_t
* ctx
, int64_t i
)
167 oberon_expr_t
* expr
;
168 expr
= oberon_new_item(MODE_CHAR
, ctx
-> char_type
, true);
169 expr
-> item
.integer
= i
;
170 expr
-> item
.real
= i
;
174 static oberon_expr_t
*
175 oberon_make_real_typed(oberon_context_t
* ctx
, double r
, oberon_type_t
* result
)
177 oberon_expr_t
* expr
;
178 expr
= oberon_new_item(MODE_REAL
, result
, true);
179 expr
-> item
.integer
= r
;
180 expr
-> item
.real
= r
;
184 static oberon_expr_t
*
185 oberon_make_real(oberon_context_t
* ctx
, double r
, bool longmode
)
187 oberon_type_t
* result
;
188 result
= (longmode
) ? (ctx
-> longreal_type
) : (ctx
-> real_type
);
189 return oberon_make_real_typed(ctx
, r
, result
);
192 static oberon_expr_t
*
193 oberon_make_boolean(oberon_context_t
* ctx
, bool cond
)
195 oberon_expr_t
* expr
;
196 expr
= oberon_new_item(MODE_BOOLEAN
, ctx
-> bool_type
, true);
197 expr
-> item
.integer
= cond
;
198 expr
-> item
.real
= cond
;
202 static oberon_expr_t
*
203 oberon_make_set(oberon_context_t
* ctx
, int64_t i
)
205 oberon_expr_t
* expr
;
206 expr
= oberon_new_item(MODE_SET
, ctx
-> set_type
, true);
207 expr
-> item
.integer
= i
;
208 expr
-> item
.real
= i
;
212 static oberon_expr_t
*
213 oberon_make_set_index(oberon_context_t
* ctx
, int64_t i
)
215 oberon_expr_t
* expr
;
216 expr
= oberon_new_item(MODE_SET
, ctx
-> set_type
, true);
217 expr
-> item
.integer
= 1 << i
;
218 expr
-> item
.real
= 1 << i
;
222 static oberon_expr_t
*
223 oberon_make_set_range(oberon_context_t
* ctx
, int64_t x
, int64_t y
)
225 oberon_expr_t
* expr
;
226 expr
= oberon_new_item(MODE_SET
, ctx
-> set_type
, true);
227 expr
-> item
.integer
= (x
<= y
) ? ((2 << y
) - (1 << x
)) : (0);
228 expr
-> item
.real
= expr
-> item
.integer
;
232 // =======================================================================
234 // =======================================================================
236 static oberon_scope_t
*
237 oberon_open_scope(oberon_context_t
* ctx
)
239 oberon_scope_t
* scope
= GC_MALLOC(sizeof *scope
);
240 memset(scope
, 0, sizeof *scope
);
242 oberon_object_t
* list
= GC_MALLOC(sizeof *list
);
243 memset(list
, 0, sizeof *list
);
246 scope
-> list
= list
;
247 scope
-> up
= ctx
-> decl
;
251 scope
-> local
= scope
-> up
-> local
;
252 scope
-> parent
= scope
-> up
-> parent
;
253 scope
-> parent_type
= scope
-> up
-> parent_type
;
254 scope
-> exit_label
= scope
-> up
-> exit_label
;
262 oberon_close_scope(oberon_scope_t
* scope
)
264 oberon_context_t
* ctx
= scope
-> ctx
;
265 ctx
-> decl
= scope
-> up
;
268 static oberon_object_t
*
269 oberon_find_object_in_list(oberon_object_t
* list
, char * name
)
271 oberon_object_t
* x
= list
;
272 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
279 static oberon_object_t
*
280 oberon_find_object(oberon_scope_t
* scope
, char * name
, bool check_it
)
282 oberon_object_t
* result
= NULL
;
284 oberon_scope_t
* s
= scope
;
285 while(result
== NULL
&& s
!= NULL
)
287 result
= oberon_find_object_in_list(s
-> list
, name
);
291 if(check_it
&& result
== NULL
)
293 oberon_error(scope
-> ctx
, "undefined ident %s", name
);
299 static oberon_object_t
*
300 oberon_create_object(oberon_scope_t
* scope
, char * name
, int class, bool export
, bool read_only
)
302 oberon_object_t
* newvar
= GC_MALLOC(sizeof *newvar
);
303 memset(newvar
, 0, sizeof *newvar
);
304 newvar
-> name
= name
;
305 newvar
-> class = class;
306 newvar
-> export
= export
;
307 newvar
-> read_only
= read_only
;
308 newvar
-> local
= scope
-> local
;
309 newvar
-> parent
= scope
-> parent
;
310 newvar
-> parent_type
= scope
-> parent_type
;
311 newvar
-> module
= scope
-> ctx
-> mod
;
315 static oberon_object_t
*
316 oberon_define_object(oberon_scope_t
* scope
, char * name
, int class, bool export
, bool read_only
, bool check_upscope
)
320 if(oberon_find_object(scope
-> up
, name
, false))
322 oberon_error(scope
-> ctx
, "already defined");
326 oberon_object_t
* x
= scope
-> list
;
327 while(x
-> next
&& strcmp(x
-> next
-> name
, name
) != 0)
334 oberon_error(scope
-> ctx
, "already defined");
337 oberon_object_t
* newvar
;
338 newvar
= oberon_create_object(scope
, name
, class, export
, read_only
);
344 // =======================================================================
346 // =======================================================================
349 oberon_get_char(oberon_context_t
* ctx
)
351 if(ctx
-> code
[ctx
-> code_index
])
353 ctx
-> code_index
+= 1;
354 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
359 oberon_init_scaner(oberon_context_t
* ctx
, const char * code
)
362 ctx
-> code_index
= 0;
363 ctx
-> c
= ctx
-> code
[ctx
-> code_index
];
367 oberon_read_ident(oberon_context_t
* ctx
)
369 int start
= ctx
-> code_index
;
371 oberon_get_char(ctx
);
372 while(isalnum(ctx
-> c
) || ctx
-> c
== '_')
374 oberon_get_char(ctx
);
377 int end
= ctx
-> code_index
;
379 char * ident
= GC_MALLOC(end
- start
+ 1);
380 memcpy(ident
, &ctx
-> code
[start
], end
- start
);
381 ident
[end
- start
] = 0;
383 ctx
-> string
= ident
;
384 ctx
-> token
= IDENT
;
386 if(strcmp(ident
, "MODULE") == 0)
388 ctx
-> token
= MODULE
;
390 else if(strcmp(ident
, "END") == 0)
394 else if(strcmp(ident
, "VAR") == 0)
398 else if(strcmp(ident
, "BEGIN") == 0)
400 ctx
-> token
= BEGIN
;
402 else if(strcmp(ident
, "OR") == 0)
406 else if(strcmp(ident
, "DIV") == 0)
410 else if(strcmp(ident
, "MOD") == 0)
414 else if(strcmp(ident
, "PROCEDURE") == 0)
416 ctx
-> token
= PROCEDURE
;
418 else if(strcmp(ident
, "RETURN") == 0)
420 ctx
-> token
= RETURN
;
422 else if(strcmp(ident
, "CONST") == 0)
424 ctx
-> token
= CONST
;
426 else if(strcmp(ident
, "TYPE") == 0)
430 else if(strcmp(ident
, "ARRAY") == 0)
432 ctx
-> token
= ARRAY
;
434 else if(strcmp(ident
, "OF") == 0)
438 else if(strcmp(ident
, "RECORD") == 0)
440 ctx
-> token
= RECORD
;
442 else if(strcmp(ident
, "POINTER") == 0)
444 ctx
-> token
= POINTER
;
446 else if(strcmp(ident
, "TO") == 0)
450 else if(strcmp(ident
, "NIL") == 0)
454 else if(strcmp(ident
, "IMPORT") == 0)
456 ctx
-> token
= IMPORT
;
458 else if(strcmp(ident
, "IN") == 0)
462 else if(strcmp(ident
, "IS") == 0)
466 else if(strcmp(ident
, "IF") == 0)
470 else if(strcmp(ident
, "THEN") == 0)
474 else if(strcmp(ident
, "ELSE") == 0)
478 else if(strcmp(ident
, "ELSIF") == 0)
480 ctx
-> token
= ELSIF
;
482 else if(strcmp(ident
, "WHILE") == 0)
484 ctx
-> token
= WHILE
;
486 else if(strcmp(ident
, "DO") == 0)
490 else if(strcmp(ident
, "REPEAT") == 0)
492 ctx
-> token
= REPEAT
;
494 else if(strcmp(ident
, "UNTIL") == 0)
496 ctx
-> token
= UNTIL
;
498 else if(strcmp(ident
, "FOR") == 0)
502 else if(strcmp(ident
, "BY") == 0)
506 else if(strcmp(ident
, "LOOP") == 0)
510 else if(strcmp(ident
, "EXIT") == 0)
514 else if(strcmp(ident
, "CASE") == 0)
518 else if(strcmp(ident
, "WITH") == 0)
524 #define ISHEXDIGIT(x) \
525 (((x) >= '0' && (x) <= '9') || ((x) >= 'A' && (x) <= 'F'))
528 oberon_read_number(oberon_context_t
* ctx
)
541 * mode = 3 == LONGREAL
545 start_i
= ctx
-> code_index
;
547 while(isdigit(ctx
-> c
))
549 oberon_get_char(ctx
);
552 end_i
= ctx
-> code_index
;
554 if(ISHEXDIGIT(ctx
-> c
))
557 while(ISHEXDIGIT(ctx
-> c
))
559 oberon_get_char(ctx
);
562 end_i
= ctx
-> code_index
;
567 oberon_get_char(ctx
);
569 else if(ctx
-> c
== 'X')
572 oberon_get_char(ctx
);
576 oberon_error(ctx
, "invalid hex number");
579 else if(ctx
-> c
== '.')
581 oberon_get_char(ctx
);
584 /* Чит: избегаем конфликта с DOTDOT */
585 ctx
-> code_index
-= 1;
591 while(isdigit(ctx
-> c
))
593 oberon_get_char(ctx
);
596 if(ctx
-> c
== 'E' || ctx
-> c
== 'D')
598 exp_i
= ctx
-> code_index
;
605 oberon_get_char(ctx
);
607 if(ctx
-> c
== '+' || ctx
-> c
== '-')
609 oberon_get_char(ctx
);
612 while(isdigit(ctx
-> c
))
614 oberon_get_char(ctx
);
618 end_i
= ctx
-> code_index
;
626 oberon_get_char(ctx
);
628 else if(ctx
-> c
== 'X')
631 oberon_get_char(ctx
);
635 int len
= end_i
- start_i
;
636 ident
= GC_MALLOC(len
+ 1);
637 memcpy(ident
, &ctx
-> code
[start_i
], len
);
640 ctx
-> longmode
= false;
643 int i
= exp_i
- start_i
;
645 ctx
-> longmode
= true;
651 integer
= atol(ident
);
653 ctx
-> token
= INTEGER
;
656 sscanf(ident
, "%lx", &integer
);
658 ctx
-> token
= INTEGER
;
662 sscanf(ident
, "%lf", &real
);
667 sscanf(ident
, "%lx", &integer
);
672 oberon_error(ctx
, "oberon_read_number: wat");
676 ctx
-> string
= ident
;
677 ctx
-> integer
= integer
;
682 oberon_skip_space(oberon_context_t
* ctx
)
684 while(isspace(ctx
-> c
))
686 oberon_get_char(ctx
);
691 oberon_read_comment(oberon_context_t
* ctx
)
698 oberon_get_char(ctx
);
701 oberon_get_char(ctx
);
705 else if(ctx
-> c
== '*')
707 oberon_get_char(ctx
);
710 oberon_get_char(ctx
);
714 else if(ctx
-> c
== 0)
716 oberon_error(ctx
, "unterminated comment");
720 oberon_get_char(ctx
);
725 static void oberon_read_string(oberon_context_t
* ctx
)
728 oberon_get_char(ctx
);
730 int start
= ctx
-> code_index
;
732 while(ctx
-> c
!= 0 && ctx
-> c
!= c
)
734 oberon_get_char(ctx
);
739 oberon_error(ctx
, "unterminated string");
742 int end
= ctx
-> code_index
;
744 oberon_get_char(ctx
);
746 char * string
= GC_MALLOC(end
- start
+ 1);
747 strncpy(string
, &ctx
-> code
[start
], end
- start
);
748 string
[end
- start
] = 0;
750 ctx
-> token
= STRING
;
751 ctx
-> string
= string
;
752 ctx
-> integer
= string
[0];
755 static void oberon_read_token(oberon_context_t
* ctx
);
758 oberon_read_symbol(oberon_context_t
* ctx
)
767 ctx
-> token
= SEMICOLON
;
768 oberon_get_char(ctx
);
771 ctx
-> token
= COLON
;
772 oberon_get_char(ctx
);
775 ctx
-> token
= ASSIGN
;
776 oberon_get_char(ctx
);
781 oberon_get_char(ctx
);
784 ctx
-> token
= DOTDOT
;
785 oberon_get_char(ctx
);
789 ctx
-> token
= LPAREN
;
790 oberon_get_char(ctx
);
793 oberon_get_char(ctx
);
794 oberon_read_comment(ctx
);
795 oberon_read_token(ctx
);
799 ctx
-> token
= RPAREN
;
800 oberon_get_char(ctx
);
803 ctx
-> token
= EQUAL
;
804 oberon_get_char(ctx
);
808 oberon_get_char(ctx
);
812 oberon_get_char(ctx
);
816 oberon_get_char(ctx
);
820 ctx
-> token
= GREAT
;
821 oberon_get_char(ctx
);
825 oberon_get_char(ctx
);
830 oberon_get_char(ctx
);
833 ctx
-> token
= MINUS
;
834 oberon_get_char(ctx
);
838 oberon_get_char(ctx
);
841 oberon_get_char(ctx
);
842 oberon_error(ctx
, "unstarted comment");
846 ctx
-> token
= SLASH
;
847 oberon_get_char(ctx
);
851 oberon_get_char(ctx
);
855 oberon_get_char(ctx
);
858 ctx
-> token
= COMMA
;
859 oberon_get_char(ctx
);
862 ctx
-> token
= LBRACK
;
863 oberon_get_char(ctx
);
866 ctx
-> token
= RBRACK
;
867 oberon_get_char(ctx
);
870 ctx
-> token
= UPARROW
;
871 oberon_get_char(ctx
);
874 oberon_read_string(ctx
);
877 oberon_read_string(ctx
);
880 ctx
-> token
= LBRACE
;
881 oberon_get_char(ctx
);
884 ctx
-> token
= RBRACE
;
885 oberon_get_char(ctx
);
889 oberon_get_char(ctx
);
892 oberon_error(ctx
, "invalid char %c", ctx
-> c
);
898 oberon_read_token(oberon_context_t
* ctx
)
900 oberon_skip_space(ctx
);
903 if(isalpha(c
) || c
== '_')
905 oberon_read_ident(ctx
);
909 oberon_read_number(ctx
);
913 oberon_read_symbol(ctx
);
917 // =======================================================================
919 // =======================================================================
921 static void oberon_expect_token(oberon_context_t
* ctx
, int token
);
922 static oberon_expr_t
* oberon_expr(oberon_context_t
* ctx
);
923 static void oberon_assert_token(oberon_context_t
* ctx
, int token
);
924 static char * oberon_assert_ident(oberon_context_t
* ctx
);
925 static void oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
);
926 static oberon_item_t
* oberon_const_expr(oberon_context_t
* ctx
);
927 static oberon_expr_t
* oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
);
928 static bool oberon_is_const(oberon_expr_t
* expr
);
930 static oberon_expr_t
*
931 oberon_make_unary_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
)
933 oberon_expr_t
* expr
;
934 oberon_type_t
* result
;
936 result
= a
-> result
;
940 if(result
-> class == OBERON_TYPE_SET
)
942 if(oberon_is_const(a
))
944 expr
= oberon_make_set(ctx
, ~(a
-> item
.integer
));
948 expr
= oberon_new_operator(OP_COMPLEMENTATION
, result
, a
, NULL
);
951 else if(result
-> class == OBERON_TYPE_INTEGER
)
953 if(oberon_is_const(a
))
955 expr
= oberon_make_integer(ctx
, -(a
-> item
.integer
));
959 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
962 else if(result
-> class == OBERON_TYPE_REAL
)
964 if(oberon_is_const(a
))
966 expr
= oberon_make_real_typed(ctx
, -(a
-> item
.real
), result
);
970 expr
= oberon_new_operator(OP_UNARY_MINUS
, result
, a
, NULL
);
975 oberon_error(ctx
, "incompatible operator type");
978 else if(token
== NOT
)
980 if(result
-> class != OBERON_TYPE_BOOLEAN
)
982 oberon_error(ctx
, "incompatible operator type");
985 if(oberon_is_const(a
))
987 expr
= oberon_make_boolean(ctx
, !(a
-> item
.integer
));
991 expr
= oberon_new_operator(OP_LOGIC_NOT
, result
, a
, NULL
);
996 oberon_error(ctx
, "oberon_make_unary_op: wat");
1003 oberon_expr_list(oberon_context_t
* ctx
, int * num_expr
, oberon_expr_t
** first
, int const_expr
)
1005 oberon_expr_t
* last
;
1010 *first
= last
= (oberon_expr_t
*) oberon_const_expr(ctx
);
1014 *first
= last
= oberon_expr(ctx
);
1016 while(ctx
-> token
== COMMA
)
1018 oberon_assert_token(ctx
, COMMA
);
1019 oberon_expr_t
* current
;
1023 current
= (oberon_expr_t
*) oberon_const_expr(ctx
);
1027 current
= oberon_expr(ctx
);
1030 last
-> next
= current
;
1036 static oberon_expr_t
*
1037 oberon_cast_expr(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
1039 oberon_expr_t
* cast
;
1041 if((oberon_is_char_type(pref
) && oberon_is_const_string(expr
) && strlen(expr
-> item
.string
) == 1))
1043 /* Автоматически преобразуем строку единичного размера в символ */
1044 cast
= oberon_new_item(MODE_CHAR
, ctx
-> char_type
, true);
1045 cast
-> item
.integer
= expr
-> item
.string
[0];
1047 else if(!oberon_is_some_types(expr
-> result
, pref
))
1049 cast
= oberon_new_operator(OP_CAST
, pref
, expr
, NULL
);
1059 static oberon_expr_t
*
1060 oberon_hard_cast_expr(oberon_context_t
* ctx
, oberon_expr_t
* expr
, oberon_type_t
* pref
)
1062 return oberon_new_operator(OP_HARDCAST
, pref
, expr
, NULL
);
1066 oberon_check_dst(oberon_context_t
* ctx
, oberon_expr_t
* dst
)
1068 if(dst
-> read_only
)
1070 oberon_error(ctx
, "read-only destination");
1073 if(dst
-> is_item
== false)
1075 oberon_error(ctx
, "not variable");
1078 switch(dst
-> item
.mode
)
1089 oberon_error(ctx
, "not variable");
1095 oberon_check_src(oberon_context_t
* ctx
, oberon_expr_t
* src
)
1099 if(src
-> item
.mode
== MODE_TYPE
)
1101 oberon_error(ctx
, "not variable");
1107 oberon_autocast_call(oberon_context_t
* ctx
, oberon_item_t
* desig
)
1109 if(desig
-> mode
!= MODE_CALL
)
1111 oberon_error(ctx
, "expected mode CALL");
1114 oberon_type_t
* fn
= desig
-> parent
-> result
;
1115 int num_args
= desig
-> num_args
;
1116 int num_decl
= fn
-> num_decl
;
1118 if(num_args
< num_decl
)
1120 oberon_error(ctx
, "too few arguments");
1122 else if(num_args
> num_decl
)
1124 oberon_error(ctx
, "too many arguments");
1127 /* Делаем проверку на запись и делаем автокаст */
1128 oberon_expr_t
* casted
[num_args
];
1129 oberon_expr_t
* arg
= desig
-> args
;
1130 oberon_object_t
* param
= fn
-> decl
;
1131 for(int i
= 0; i
< num_args
; i
++)
1133 if(param
-> class == OBERON_CLASS_VAR_PARAM
)
1135 oberon_check_dst(ctx
, arg
);
1136 if(!oberon_is_compatible_arrays(param
, arg
))
1138 oberon_check_compatible_var_param(ctx
, param
-> type
, arg
-> result
);
1141 //casted[i] = oberon_cast_expr(ctx, arg, param -> type);
1145 oberon_check_src(ctx
, arg
);
1146 if(!oberon_is_compatible_arrays(param
, arg
))
1148 oberon_check_assignment_compatible(ctx
, arg
, param
-> type
);
1150 casted
[i
] = oberon_cast_expr(ctx
, arg
, param
-> type
);
1154 param
= param
-> next
;
1157 /* Создаём новый список выражений */
1161 for(int i
= 0; i
< num_args
- 1; i
++)
1163 casted
[i
] -> next
= casted
[i
+ 1];
1165 desig
-> args
= arg
;
1169 static oberon_expr_t
*
1170 oberon_make_call_func(oberon_context_t
* ctx
, oberon_item_t
* item
, int num_args
, oberon_expr_t
* list_args
)
1172 oberon_type_t
* signature
= item
-> result
;
1173 if(signature
-> class != OBERON_TYPE_PROCEDURE
)
1175 oberon_error(ctx
, "not a procedure");
1178 oberon_expr_t
* call
;
1180 if(signature
-> sysproc
)
1182 if(signature
-> genfunc
== NULL
)
1184 oberon_error(ctx
, "not a function-procedure");
1187 call
= signature
-> genfunc(ctx
, num_args
, list_args
);
1191 if(signature
-> base
-> class == OBERON_TYPE_NOTYPE
)
1193 oberon_error(ctx
, "attempt to call procedure in expression");
1196 call
= oberon_new_item(MODE_CALL
, signature
-> base
, true);
1197 call
-> item
.parent
= item
;
1198 call
-> item
.num_args
= num_args
;
1199 call
-> item
.args
= list_args
;
1200 oberon_autocast_call(ctx
, (oberon_item_t
*) call
);
1207 oberon_make_call_proc(oberon_context_t
* ctx
, oberon_item_t
* item
, int num_args
, oberon_expr_t
* list_args
)
1209 oberon_type_t
* signature
= item
-> result
;
1210 if(signature
-> class != OBERON_TYPE_PROCEDURE
)
1212 oberon_error(ctx
, "not a procedure");
1215 oberon_expr_t
* call
;
1217 if(signature
-> sysproc
)
1219 if(signature
-> genproc
== NULL
)
1221 oberon_error(ctx
, "not a procedure");
1224 signature
-> genproc(ctx
, num_args
, list_args
);
1228 if(signature
-> base
-> class != OBERON_TYPE_NOTYPE
)
1230 oberon_error(ctx
, "attempt to call function as non-typed procedure");
1233 call
= oberon_new_item(MODE_CALL
, signature
-> base
, true);
1234 call
-> item
.parent
= item
;
1235 call
-> item
.num_args
= num_args
;
1236 call
-> item
.args
= list_args
;
1237 oberon_autocast_call(ctx
, (oberon_item_t
*) call
);
1238 oberon_generate_call_proc(ctx
, call
);
1246 || ((x) == INTEGER) \
1249 || ((x) == STRING) \
1251 || ((x) == LPAREN) \
1254 static oberon_expr_t
*
1255 oberno_make_dereferencing(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1257 if(expr
-> result
-> class != OBERON_TYPE_POINTER
)
1259 oberon_error(ctx
, "not a pointer");
1262 assert(expr
-> is_item
);
1264 oberon_expr_t
* selector
;
1265 selector
= oberon_new_item(MODE_DEREF
, expr
-> result
-> base
, false);
1266 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1271 static oberon_expr_t
*
1272 oberon_make_array_selector(oberon_context_t
* ctx
, oberon_expr_t
* desig
, oberon_expr_t
* index
)
1274 if(desig
-> result
-> class == OBERON_TYPE_POINTER
)
1276 desig
= oberno_make_dereferencing(ctx
, desig
);
1279 assert(desig
-> is_item
);
1281 if(desig
-> result
-> class != OBERON_TYPE_ARRAY
)
1283 oberon_error(ctx
, "not array");
1286 oberon_type_t
* base
;
1287 base
= desig
-> result
-> base
;
1289 if(index
-> result
-> class != OBERON_TYPE_INTEGER
)
1291 oberon_error(ctx
, "index must be integer");
1294 // Статическая проверка границ массива
1295 if(desig
-> result
-> size
!= 0)
1297 if(index
-> is_item
)
1299 if(index
-> item
.mode
== MODE_INTEGER
)
1301 int arr_size
= desig
-> result
-> size
;
1302 int index_int
= index
-> item
.integer
;
1303 if(index_int
< 0 || index_int
> arr_size
- 1)
1305 oberon_error(ctx
, "not in range (dimension size 0..%i)", arr_size
- 1);
1311 oberon_expr_t
* selector
;
1312 selector
= oberon_new_item(MODE_INDEX
, base
, desig
-> read_only
);
1313 selector
-> item
.parent
= (oberon_item_t
*) desig
;
1314 selector
-> item
.num_args
= 1;
1315 selector
-> item
.args
= index
;
1320 static oberon_expr_t
*
1321 oberon_make_record_selector(oberon_context_t
* ctx
, oberon_expr_t
* expr
, char * name
)
1323 if(expr
-> result
-> class == OBERON_TYPE_POINTER
)
1325 expr
= oberno_make_dereferencing(ctx
, expr
);
1328 assert(expr
-> is_item
);
1330 if(expr
-> result
-> class != OBERON_TYPE_RECORD
)
1332 oberon_error(ctx
, "not record");
1335 oberon_type_t
* rec
= expr
-> result
;
1337 oberon_object_t
* field
;
1338 field
= oberon_find_object(rec
-> scope
, name
, true);
1340 if(field
-> export
== 0)
1342 if(field
-> module
!= ctx
-> mod
)
1344 oberon_error(ctx
, "field not exported");
1348 int read_only
= expr
-> read_only
;
1349 if(field
-> read_only
)
1351 if(field
-> module
!= ctx
-> mod
)
1357 oberon_expr_t
* selector
;
1358 selector
= oberon_new_item(MODE_FIELD
, field
-> type
, read_only
);
1359 selector
-> item
.var
= field
;
1360 selector
-> item
.parent
= (oberon_item_t
*) expr
;
1365 #define ISSELECTOR(x) \
1368 || ((x) == UPARROW) \
1371 static oberon_object_t
*
1372 oberon_qualident(oberon_context_t
* ctx
, char ** xname
, int check
)
1375 oberon_object_t
* x
;
1377 name
= oberon_assert_ident(ctx
);
1378 x
= oberon_find_object(ctx
-> decl
, name
, check
);
1382 if(x
-> class == OBERON_CLASS_MODULE
)
1384 oberon_assert_token(ctx
, DOT
);
1385 name
= oberon_assert_ident(ctx
);
1386 /* Наличие объектов в левых модулях всегда проверяется */
1387 x
= oberon_find_object(x
-> module
-> decl
, name
, 1);
1389 if(x
-> export
== 0)
1391 oberon_error(ctx
, "not exported");
1404 static oberon_expr_t
*
1405 oberon_ident_item(oberon_context_t
* ctx
, char * name
)
1408 oberon_object_t
* x
;
1409 oberon_expr_t
* expr
;
1411 x
= oberon_find_object(ctx
-> decl
, name
, true);
1414 if(x
-> class == OBERON_CLASS_CONST
|| x
-> class == OBERON_CLASS_PROC
)
1419 expr
= oberon_new_item(MODE_VAR
, x
-> type
, read_only
);
1420 expr
-> item
.var
= x
;
1424 static oberon_expr_t
*
1425 oberon_qualident_expr(oberon_context_t
* ctx
)
1427 oberon_object_t
* var
;
1428 oberon_expr_t
* expr
;
1430 var
= oberon_qualident(ctx
, NULL
, 1);
1433 if(var
-> read_only
)
1435 if(var
-> module
!= ctx
-> mod
)
1441 switch(var
-> class)
1443 case OBERON_CLASS_CONST
:
1445 expr
= (oberon_expr_t
*) var
-> value
;
1447 case OBERON_CLASS_TYPE
:
1448 expr
= oberon_new_item(MODE_TYPE
, var
-> type
, read_only
);
1450 case OBERON_CLASS_VAR
:
1451 case OBERON_CLASS_VAR_PARAM
:
1452 case OBERON_CLASS_PARAM
:
1453 expr
= oberon_new_item(MODE_VAR
, var
-> type
, read_only
);
1455 case OBERON_CLASS_PROC
:
1456 expr
= oberon_new_item(MODE_VAR
, var
-> type
, true);
1459 oberon_error(ctx
, "invalid designator");
1463 expr
-> item
.var
= var
;
1468 static oberon_expr_t
*
1469 oberon_designator(oberon_context_t
* ctx
)
1472 oberon_expr_t
* expr
;
1473 oberon_object_t
* objtype
;
1475 expr
= oberon_qualident_expr(ctx
);
1477 while(expr
-> result
-> class != OBERON_TYPE_PROCEDURE
&& ISSELECTOR(ctx
-> token
))
1479 switch(ctx
-> token
)
1482 oberon_assert_token(ctx
, DOT
);
1483 name
= oberon_assert_ident(ctx
);
1484 expr
= oberon_make_record_selector(ctx
, expr
, name
);
1487 oberon_assert_token(ctx
, LBRACK
);
1488 int num_indexes
= 0;
1489 oberon_expr_t
* indexes
= NULL
;
1490 oberon_expr_list(ctx
, &num_indexes
, &indexes
, 0);
1491 oberon_assert_token(ctx
, RBRACK
);
1493 for(int i
= 0; i
< num_indexes
; i
++)
1495 expr
= oberon_make_array_selector(ctx
, expr
, indexes
);
1496 indexes
= indexes
-> next
;
1500 oberon_assert_token(ctx
, UPARROW
);
1501 expr
= oberno_make_dereferencing(ctx
, expr
);
1504 oberon_assert_token(ctx
, LPAREN
);
1505 objtype
= oberon_qualident(ctx
, NULL
, true);
1506 oberon_assert_token(ctx
, RPAREN
);
1507 oberon_check_extension_of(ctx
, expr
-> result
, objtype
-> type
);
1508 expr
= oberon_cast_expr(ctx
, expr
, objtype
-> type
);
1511 oberon_error(ctx
, "oberon_designator: wat");
1519 static oberon_expr_t
*
1520 oberon_opt_func_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1522 /* Если есть скобки - значит вызов. Если нет, то передаём указатель. */
1523 if(ctx
-> token
== LPAREN
)
1525 oberon_assert_token(ctx
, LPAREN
);
1528 oberon_expr_t
* arguments
= NULL
;
1530 if(ISEXPR(ctx
-> token
))
1532 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1535 assert(expr
-> is_item
== 1);
1536 expr
= oberon_make_call_func(ctx
, (oberon_item_t
*) expr
, num_args
, arguments
);
1538 oberon_assert_token(ctx
, RPAREN
);
1545 oberon_opt_proc_parens(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
1547 assert(expr
-> is_item
);
1550 oberon_expr_t
* arguments
= NULL
;
1552 if(ctx
-> token
== LPAREN
)
1554 oberon_assert_token(ctx
, LPAREN
);
1556 if(ISEXPR(ctx
-> token
))
1558 oberon_expr_list(ctx
, &num_args
, &arguments
, 0);
1561 oberon_assert_token(ctx
, RPAREN
);
1564 /* Вызов происходит даже без скобок */
1565 oberon_make_call_proc(ctx
, (oberon_item_t
*) expr
, num_args
, arguments
);
1568 static oberon_expr_t
*
1569 oberon_element(oberon_context_t
* ctx
)
1574 e1
= oberon_expr(ctx
);
1575 oberon_check_src(ctx
, e1
);
1576 if(e1
-> result
-> class != OBERON_TYPE_INTEGER
)
1578 oberon_error(ctx
, "expected integer");
1582 if(ctx
-> token
== DOTDOT
)
1584 oberon_assert_token(ctx
, DOTDOT
);
1585 e2
= oberon_expr(ctx
);
1586 oberon_check_src(ctx
, e2
);
1587 if(e2
-> result
-> class != OBERON_TYPE_INTEGER
)
1589 oberon_error(ctx
, "expected integer");
1593 oberon_expr_t
* set
;
1594 if(e2
== NULL
&& oberon_is_const(e1
))
1596 set
= oberon_make_set_index(ctx
, e1
-> item
.integer
);
1598 else if(e2
!= NULL
&& oberon_is_const(e1
) && oberon_is_const(e2
))
1600 set
= oberon_make_set_range(ctx
, e1
-> item
.integer
, e2
-> item
.integer
);
1604 set
= oberon_new_operator(OP_RANGE
, ctx
-> set_type
, e1
, e2
);
1609 static oberon_expr_t
*
1610 oberon_make_set_union(oberon_context_t
* ctx
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1612 if(oberon_is_const(a
) && oberon_is_const(b
))
1614 return oberon_make_set(ctx
, (a
-> item
.integer
| b
-> item
.integer
));
1618 return oberon_new_operator(OP_UNION
, ctx
-> set_type
, a
, b
);
1622 static oberon_expr_t
*
1623 oberon_set(oberon_context_t
* ctx
)
1625 oberon_expr_t
* set
;
1626 oberon_expr_t
* elements
;
1627 set
= oberon_make_set(ctx
, 0);
1629 oberon_assert_token(ctx
, LBRACE
);
1630 if(ISEXPR(ctx
-> token
))
1632 elements
= oberon_element(ctx
);
1633 set
= oberon_make_set_union(ctx
, set
, elements
);
1634 while(ctx
-> token
== COMMA
)
1636 oberon_assert_token(ctx
, COMMA
);
1637 elements
= oberon_element(ctx
);
1638 set
= oberon_make_set_union(ctx
, set
, elements
);
1641 oberon_assert_token(ctx
, RBRACE
);
1646 static oberon_expr_t
*
1647 oberon_factor(oberon_context_t
* ctx
)
1649 oberon_expr_t
* expr
;
1650 oberon_type_t
* result
;
1652 switch(ctx
-> token
)
1655 expr
= oberon_designator(ctx
);
1656 expr
= oberon_opt_func_parens(ctx
, expr
);
1659 expr
= oberon_make_integer(ctx
, ctx
-> integer
);
1660 oberon_assert_token(ctx
, INTEGER
);
1663 result
= ctx
-> char_type
;
1664 expr
= oberon_new_item(MODE_CHAR
, result
, true);
1665 expr
-> item
.integer
= ctx
-> integer
;
1666 oberon_assert_token(ctx
, CHAR
);
1669 result
= ctx
-> string_type
;
1670 expr
= oberon_new_item(MODE_STRING
, result
, true);
1671 expr
-> item
.string
= ctx
-> string
;
1672 oberon_assert_token(ctx
, STRING
);
1675 expr
= oberon_make_real(ctx
, ctx
-> real
, ctx
-> longmode
);
1676 oberon_assert_token(ctx
, REAL
);
1679 expr
= oberon_set(ctx
);
1682 oberon_assert_token(ctx
, LPAREN
);
1683 expr
= oberon_expr(ctx
);
1684 oberon_assert_token(ctx
, RPAREN
);
1687 oberon_assert_token(ctx
, NOT
);
1688 expr
= oberon_factor(ctx
);
1689 expr
= oberon_make_unary_op(ctx
, NOT
, expr
);
1692 oberon_assert_token(ctx
, NIL
);
1693 expr
= oberon_new_item(MODE_NIL
, ctx
-> nil_type
, true);
1696 oberon_error(ctx
, "invalid expression");
1702 static oberon_expr_t
*
1703 oberon_make_bin_op(oberon_context_t
* ctx
, int token
, oberon_expr_t
* a
, oberon_expr_t
* b
)
1705 oberon_expr_t
* expr
;
1706 oberon_type_t
* result
;
1708 oberon_check_compatible_bin_expr_types(ctx
, token
, a
-> result
, b
-> result
);
1709 oberon_check_src(ctx
, a
);
1712 oberon_check_src(ctx
, b
);
1717 if(oberon_is_const(a
) && oberon_is_const(b
))
1719 expr
= oberon_make_boolean(ctx
, (1 << a
-> item
.integer
) & b
-> item
.integer
);
1723 expr
= oberon_new_operator(OP_IN
, ctx
-> bool_type
, a
, b
);
1726 else if(token
== IS
)
1728 oberon_check_type_expr(ctx
, b
);
1729 expr
= oberon_new_operator(OP_IS
, ctx
-> bool_type
, a
, b
);
1731 else if((token
>= EQUAL
&& token
<= GEQ
) || token
== OR
|| token
== AND
)
1733 result
= oberon_get_longer_type(ctx
, a
-> result
, b
-> result
);
1735 if(oberon_is_const(a
) && oberon_is_const(b
)
1736 && (oberon_is_real_type(result
) || oberon_is_integer_type(result
)))
1738 if(oberon_is_real_type(result
))
1740 double x
= a
-> item
.real
;
1741 double y
= b
-> item
.real
;
1744 case EQUAL
: expr
= oberon_make_boolean(ctx
, x
== y
); break;
1745 case NEQ
: expr
= oberon_make_boolean(ctx
, x
!= y
); break;
1746 case LESS
: expr
= oberon_make_boolean(ctx
, x
< y
); break;
1747 case LEQ
: expr
= oberon_make_boolean(ctx
, x
<= y
); break;
1748 case GREAT
: expr
= oberon_make_boolean(ctx
, x
> y
); break;
1749 case GEQ
: expr
= oberon_make_boolean(ctx
, x
>= y
); break;
1750 case OR
: expr
= oberon_make_boolean(ctx
, x
|| y
); break;
1751 case AND
: expr
= oberon_make_boolean(ctx
, x
&& y
); break;
1752 default: assert(0); break;
1755 else if(oberon_is_integer_type(result
))
1757 int64_t x
= a
-> item
.integer
;
1758 int64_t y
= b
-> item
.integer
;
1761 case EQUAL
: expr
= oberon_make_boolean(ctx
, x
== y
); break;
1762 case NEQ
: expr
= oberon_make_boolean(ctx
, x
!= y
); break;
1763 case LESS
: expr
= oberon_make_boolean(ctx
, x
< y
); break;
1764 case LEQ
: expr
= oberon_make_boolean(ctx
, x
<= y
); break;
1765 case GREAT
: expr
= oberon_make_boolean(ctx
, x
> y
); break;
1766 case GEQ
: expr
= oberon_make_boolean(ctx
, x
>= y
); break;
1767 case OR
: expr
= oberon_make_boolean(ctx
, x
|| y
); break;
1768 case AND
: expr
= oberon_make_boolean(ctx
, x
&& y
); break;
1769 default: assert(0); break;
1779 a
= oberon_cast_expr(ctx
, a
, result
);
1780 b
= oberon_cast_expr(ctx
, b
, result
);
1781 result
= ctx
-> bool_type
;
1784 case EQUAL
: expr
= oberon_new_operator(OP_EQ
, result
, a
, b
); break;
1785 case NEQ
: expr
= oberon_new_operator(OP_NEQ
, result
, a
, b
); break;
1786 case LESS
: expr
= oberon_new_operator(OP_LSS
, result
, a
, b
); break;
1787 case LEQ
: expr
= oberon_new_operator(OP_LEQ
, result
, a
, b
); break;
1788 case GREAT
: expr
= oberon_new_operator(OP_GRT
, result
, a
, b
); break;
1789 case GEQ
: expr
= oberon_new_operator(OP_GEQ
, result
, a
, b
); break;
1790 case OR
: expr
= oberon_new_operator(OP_LOGIC_OR
, result
, a
, b
); break;
1791 case AND
: expr
= oberon_new_operator(OP_LOGIC_AND
, result
, a
, b
); break;
1792 default: assert(0); break;
1796 else if(token
== SLASH
)
1798 if(oberon_is_set_type(a
-> result
) && oberon_is_set_type(b
-> result
))
1800 if(oberon_is_const(a
) && oberon_is_const(b
))
1802 int64_t x
= a
-> item
.integer
;
1803 int64_t y
= b
-> item
.integer
;
1804 expr
= oberon_make_set(ctx
, x
^ y
);
1808 result
= oberon_get_longer_type(ctx
, a
-> result
, b
-> result
);
1809 a
= oberon_cast_expr(ctx
, a
, result
);
1810 b
= oberon_cast_expr(ctx
, b
, result
);
1811 expr
= oberon_new_operator(OP_SYM_DIFFERENCE
, result
, a
, b
);
1816 result
= oberon_get_longer_real_type(ctx
, a
-> result
, b
-> result
);
1817 if(oberon_is_const(a
) && oberon_is_const(b
))
1819 double x
= a
-> item
.real
;
1820 double y
= b
-> item
.real
;
1821 expr
= oberon_make_real_typed(ctx
, x
/ y
, result
);
1825 a
= oberon_cast_expr(ctx
, a
, result
);
1826 b
= oberon_cast_expr(ctx
, b
, result
);
1827 expr
= oberon_new_operator(OP_DIV
, result
, a
, b
);
1833 result
= oberon_get_longer_type(ctx
, a
-> result
, b
-> result
);
1835 if(oberon_is_const(a
) && oberon_is_const(b
))
1837 if(oberon_is_set_type(result
))
1839 int64_t x
= a
-> item
.integer
;
1840 int64_t y
= b
-> item
.integer
;
1843 case PLUS
: expr
= oberon_make_set(ctx
, x
| y
); break;
1844 case MINUS
: expr
= oberon_make_set(ctx
, x
& ~y
); break;
1845 case STAR
: expr
= oberon_make_set(ctx
, x
& y
); break;
1846 default: assert(0); break;
1849 if(oberon_is_real_type(result
))
1851 double x
= a
-> item
.real
;
1852 double y
= b
-> item
.real
;
1855 case PLUS
: expr
= oberon_make_real_typed(ctx
, x
+ y
, result
); break;
1856 case MINUS
: expr
= oberon_make_real_typed(ctx
, x
- y
, result
); break;
1857 case STAR
: expr
= oberon_make_real_typed(ctx
, x
* y
, result
); break;
1858 default: assert(0); break;
1861 else if(oberon_is_integer_type(result
))
1863 int64_t x
= a
-> item
.integer
;
1864 int64_t y
= b
-> item
.integer
;
1867 case PLUS
: expr
= oberon_make_integer(ctx
, x
+ y
); break;
1868 case MINUS
: expr
= oberon_make_integer(ctx
, x
- y
); break;
1869 case STAR
: expr
= oberon_make_integer(ctx
, x
* y
); break;
1870 case DIV
: expr
= oberon_make_integer(ctx
, x
/ y
); break;
1871 case MOD
: expr
= oberon_make_integer(ctx
, x
% y
); break;
1872 default: assert(0); break;
1882 a
= oberon_cast_expr(ctx
, a
, result
);
1883 b
= oberon_cast_expr(ctx
, b
, result
);
1886 if(oberon_is_set_type(result
))
1891 expr
= oberon_new_operator(OP_UNION
, result
, a
, b
);
1894 expr
= oberon_new_operator(OP_DIFFERENCE
, result
, a
, b
);
1897 expr
= oberon_new_operator(OP_INTERSECTION
, result
, a
, b
);
1904 else if(oberon_is_number_type(result
))
1909 expr
= oberon_new_operator(OP_ADD
, result
, a
, b
);
1912 expr
= oberon_new_operator(OP_SUB
, result
, a
, b
);
1915 expr
= oberon_new_operator(OP_MUL
, result
, a
, b
);
1932 #define ISMULOP(x) \
1933 ((x) >= STAR && (x) <= AND)
1935 static oberon_expr_t
*
1936 oberon_term_expr(oberon_context_t
* ctx
)
1938 oberon_expr_t
* expr
;
1940 expr
= oberon_factor(ctx
);
1941 while(ISMULOP(ctx
-> token
))
1943 int token
= ctx
-> token
;
1944 oberon_read_token(ctx
);
1946 oberon_expr_t
* inter
= oberon_factor(ctx
);
1947 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1953 #define ISADDOP(x) \
1954 ((x) >= PLUS && (x) <= OR)
1956 static oberon_expr_t
*
1957 oberon_simple_expr(oberon_context_t
* ctx
)
1959 oberon_expr_t
* expr
;
1962 if(ctx
-> token
== PLUS
)
1965 oberon_assert_token(ctx
, PLUS
);
1967 else if(ctx
-> token
== MINUS
)
1970 oberon_assert_token(ctx
, MINUS
);
1973 expr
= oberon_term_expr(ctx
);
1975 while(ISADDOP(ctx
-> token
))
1977 int token
= ctx
-> token
;
1978 oberon_read_token(ctx
);
1980 oberon_expr_t
* inter
= oberon_term_expr(ctx
);
1981 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
1986 expr
= oberon_make_unary_op(ctx
, MINUS
, expr
);
1992 #define ISRELATION(x) \
1993 ((x) >= EQUAL && (x) <= IS)
1995 static oberon_expr_t
*
1996 oberon_expr(oberon_context_t
* ctx
)
1998 oberon_expr_t
* expr
;
2000 expr
= oberon_simple_expr(ctx
);
2001 while(ISRELATION(ctx
-> token
))
2003 int token
= ctx
-> token
;
2004 oberon_read_token(ctx
);
2006 oberon_expr_t
* inter
= oberon_simple_expr(ctx
);
2007 expr
= oberon_make_bin_op(ctx
, token
, expr
, inter
);
2014 oberon_is_const(oberon_expr_t
* expr
)
2016 if(expr
-> is_item
== false)
2021 switch(expr
-> item
.mode
)
2043 oberon_check_const(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
2045 if(!oberon_is_const(expr
))
2047 oberon_error(ctx
, "const expression are required");
2051 static oberon_item_t
*
2052 oberon_const_expr(oberon_context_t
* ctx
)
2054 oberon_expr_t
* expr
;
2055 expr
= oberon_expr(ctx
);
2056 oberon_check_const(ctx
, expr
);
2057 return (oberon_item_t
*) expr
;
2060 // =======================================================================
2062 // =======================================================================
2064 static void oberon_decl_seq(oberon_context_t
* ctx
);
2065 static void oberon_statement_seq(oberon_context_t
* ctx
);
2066 static void oberon_initialize_decl(oberon_context_t
* ctx
);
2069 oberon_expect_token(oberon_context_t
* ctx
, int token
)
2071 if(ctx
-> token
!= token
)
2073 oberon_error(ctx
, "unexpected token %i (%i)", ctx
-> token
, token
);
2078 oberon_assert_token(oberon_context_t
* ctx
, int token
)
2080 oberon_expect_token(ctx
, token
);
2081 oberon_read_token(ctx
);
2085 oberon_assert_ident(oberon_context_t
* ctx
)
2087 oberon_expect_token(ctx
, IDENT
);
2088 char * ident
= ctx
-> string
;
2089 oberon_read_token(ctx
);
2094 oberon_def(oberon_context_t
* ctx
, int * export
, int * read_only
)
2096 switch(ctx
-> token
)
2099 oberon_assert_token(ctx
, STAR
);
2104 oberon_assert_token(ctx
, MINUS
);
2115 static oberon_object_t
*
2116 oberon_ident_def(oberon_context_t
* ctx
, int class, bool check_upscope
)
2121 oberon_object_t
* x
;
2123 name
= oberon_assert_ident(ctx
);
2124 oberon_def(ctx
, &export
, &read_only
);
2126 x
= oberon_define_object(ctx
-> decl
, name
, class, export
, read_only
, check_upscope
);
2131 oberon_ident_list(oberon_context_t
* ctx
, int class, bool check_upscope
, int * num
, oberon_object_t
** list
)
2134 *list
= oberon_ident_def(ctx
, class, check_upscope
);
2135 while(ctx
-> token
== COMMA
)
2137 oberon_assert_token(ctx
, COMMA
);
2138 oberon_ident_def(ctx
, class, check_upscope
);
2144 oberon_var_decl(oberon_context_t
* ctx
)
2147 oberon_object_t
* list
;
2148 oberon_type_t
* type
;
2149 type
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2151 oberon_ident_list(ctx
, OBERON_CLASS_VAR
, false, &num
, &list
);
2152 oberon_assert_token(ctx
, COLON
);
2153 oberon_type(ctx
, &type
);
2155 oberon_object_t
* var
= list
;
2156 for(int i
= 0; i
< num
; i
++)
2163 static oberon_object_t
*
2164 oberon_fp_section(oberon_context_t
* ctx
, int * num_decl
)
2166 int class = OBERON_CLASS_PARAM
;
2167 if(ctx
-> token
== VAR
)
2169 oberon_read_token(ctx
);
2170 class = OBERON_CLASS_VAR_PARAM
;
2174 oberon_object_t
* list
;
2175 oberon_ident_list(ctx
, class, false, &num
, &list
);
2177 oberon_assert_token(ctx
, COLON
);
2179 oberon_type_t
* type
;
2180 type
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2181 oberon_type(ctx
, &type
);
2183 oberon_object_t
* param
= list
;
2184 for(int i
= 0; i
< num
; i
++)
2186 param
-> type
= type
;
2187 param
= param
-> next
;
2194 #define ISFPSECTION \
2195 ((ctx -> token == VAR) || (ctx -> token == IDENT))
2198 oberon_formal_pars(oberon_context_t
* ctx
, oberon_type_t
* signature
)
2200 oberon_assert_token(ctx
, LPAREN
);
2204 signature
-> decl
= oberon_fp_section(ctx
, &signature
-> num_decl
);
2205 while(ctx
-> token
== SEMICOLON
)
2207 oberon_assert_token(ctx
, SEMICOLON
);
2208 oberon_fp_section(ctx
, &signature
-> num_decl
);
2212 oberon_assert_token(ctx
, RPAREN
);
2214 if(ctx
-> token
== COLON
)
2216 oberon_assert_token(ctx
, COLON
);
2218 oberon_object_t
* typeobj
;
2219 typeobj
= oberon_qualident(ctx
, NULL
, 1);
2220 if(typeobj
-> class != OBERON_CLASS_TYPE
)
2222 oberon_error(ctx
, "function result is not type");
2224 if(typeobj
-> type
-> class == OBERON_TYPE_RECORD
2225 || typeobj
-> type
-> class == OBERON_TYPE_ARRAY
)
2227 oberon_error(ctx
, "records or arrays could not be result of function");
2229 signature
-> base
= typeobj
-> type
;
2234 oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
)
2236 oberon_type_t
* signature
;
2238 signature
-> class = OBERON_TYPE_PROCEDURE
;
2239 signature
-> num_decl
= 0;
2240 signature
-> base
= ctx
-> notype_type
;
2241 signature
-> decl
= NULL
;
2243 if(ctx
-> token
== LPAREN
)
2245 oberon_formal_pars(ctx
, signature
);
2250 oberon_compare_signatures(oberon_context_t
* ctx
, oberon_type_t
* a
, oberon_type_t
* b
)
2252 if(a
-> num_decl
!= b
-> num_decl
)
2254 oberon_error(ctx
, "number parameters not matched");
2257 int num_param
= a
-> num_decl
;
2258 oberon_object_t
* param_a
= a
-> decl
;
2259 oberon_object_t
* param_b
= b
-> decl
;
2260 for(int i
= 0; i
< num_param
; i
++)
2262 if(strcmp(param_a
-> name
, param_b
-> name
) != 0)
2264 oberon_error(ctx
, "param %i name not matched", i
+ 1);
2267 if(param_a
-> type
!= param_b
-> type
)
2269 oberon_error(ctx
, "param %i type not matched", i
+ 1);
2272 param_a
= param_a
-> next
;
2273 param_b
= param_b
-> next
;
2278 oberon_make_return(oberon_context_t
* ctx
, oberon_expr_t
* expr
)
2280 oberon_object_t
* proc
= ctx
-> decl
-> parent
;
2281 oberon_type_t
* result_type
= proc
-> type
-> base
;
2283 if(result_type
-> class == OBERON_TYPE_NOTYPE
)
2287 oberon_error(ctx
, "procedure has no result type");
2294 oberon_error(ctx
, "procedure requires expression on result");
2297 oberon_check_src(ctx
, expr
);
2298 oberon_check_assignment_compatible(ctx
, expr
, result_type
);
2299 expr
= oberon_cast_expr(ctx
, expr
, result_type
);
2302 proc
-> has_return
= 1;
2304 oberon_generate_return(ctx
, expr
);
2308 oberon_proc_decl_body(oberon_context_t
* ctx
, oberon_object_t
* proc
)
2310 oberon_assert_token(ctx
, SEMICOLON
);
2312 ctx
-> decl
= proc
-> scope
;
2314 oberon_decl_seq(ctx
);
2316 oberon_generate_begin_proc(ctx
, proc
);
2318 if(ctx
-> token
== BEGIN
)
2320 oberon_assert_token(ctx
, BEGIN
);
2321 oberon_statement_seq(ctx
);
2324 oberon_assert_token(ctx
, END
);
2325 char * name
= oberon_assert_ident(ctx
);
2326 if(strcmp(name
, proc
-> name
) != 0)
2328 oberon_error(ctx
, "procedure name not matched");
2331 if(proc
-> type
-> base
-> class == OBERON_TYPE_NOTYPE
2332 && proc
-> has_return
== 0)
2334 oberon_make_return(ctx
, NULL
);
2337 if(proc
-> has_return
== 0)
2339 oberon_error(ctx
, "procedure requires return");
2342 oberon_generate_end_proc(ctx
);
2343 oberon_close_scope(ctx
-> decl
);
2347 oberon_proc_decl(oberon_context_t
* ctx
)
2349 oberon_assert_token(ctx
, PROCEDURE
);
2352 if(ctx
-> token
== UPARROW
)
2354 oberon_assert_token(ctx
, UPARROW
);
2361 name
= oberon_assert_ident(ctx
);
2362 oberon_def(ctx
, &export
, &read_only
);
2364 oberon_scope_t
* proc_scope
;
2365 proc_scope
= oberon_open_scope(ctx
);
2366 ctx
-> decl
-> local
= 1;
2368 oberon_type_t
* signature
;
2369 signature
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2370 oberon_opt_formal_pars(ctx
, &signature
);
2372 //oberon_initialize_decl(ctx);
2373 oberon_generator_init_type(ctx
, signature
);
2374 oberon_close_scope(ctx
-> decl
);
2376 oberon_object_t
* proc
;
2377 proc
= oberon_find_object(ctx
-> decl
, name
, 0);
2380 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, export
, read_only
, false);
2381 proc
-> type
= signature
;
2382 proc
-> scope
= proc_scope
;
2383 oberon_generator_init_proc(ctx
, proc
);
2387 if(proc
-> class != OBERON_CLASS_PROC
)
2389 oberon_error(ctx
, "mult definition");
2396 oberon_error(ctx
, "mult procedure definition");
2400 if(proc
-> export
!= export
|| proc
-> read_only
!= read_only
)
2402 oberon_error(ctx
, "export type not matched");
2405 oberon_compare_signatures(ctx
, proc
-> type
, signature
);
2408 proc_scope
-> parent
= proc
;
2409 oberon_object_t
* param
= proc_scope
-> list
-> next
;
2412 param
-> parent
= proc
;
2413 param
= param
-> next
;
2419 oberon_proc_decl_body(ctx
, proc
);
2424 oberon_const_decl(oberon_context_t
* ctx
)
2426 oberon_item_t
* value
;
2427 oberon_object_t
* constant
;
2429 constant
= oberon_ident_def(ctx
, OBERON_CLASS_CONST
, false);
2430 oberon_assert_token(ctx
, EQUAL
);
2431 value
= oberon_const_expr(ctx
);
2432 constant
-> value
= value
;
2436 oberon_make_array_type(oberon_context_t
* ctx
, oberon_expr_t
* size
, oberon_type_t
* base
, oberon_type_t
** type
)
2438 if(size
-> is_item
== 0)
2440 oberon_error(ctx
, "requires constant");
2443 if(size
-> item
.mode
!= MODE_INTEGER
)
2445 oberon_error(ctx
, "requires integer constant");
2448 oberon_type_t
* arr
;
2450 arr
-> class = OBERON_TYPE_ARRAY
;
2451 arr
-> size
= size
-> item
.integer
;
2456 oberon_qualident_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2459 oberon_object_t
* to
;
2461 to
= oberon_qualident(ctx
, &name
, 0);
2463 //name = oberon_assert_ident(ctx);
2464 //to = oberon_find_object(ctx -> decl, name, 0);
2468 if(to
-> class != OBERON_CLASS_TYPE
)
2470 oberon_error(ctx
, "not a type");
2475 to
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, false, false, false);
2476 to
-> type
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2482 static void oberon_opt_formal_pars(oberon_context_t
* ctx
, oberon_type_t
** type
);
2485 * Правило граматики "type". Указатель type должен указывать на существующий объект!
2489 oberon_make_multiarray(oberon_context_t
* ctx
, oberon_expr_t
* sizes
, oberon_type_t
* base
, oberon_type_t
** type
)
2497 oberon_type_t
* dim
;
2498 dim
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2500 oberon_make_multiarray(ctx
, sizes
-> next
, base
, &dim
);
2502 oberon_make_array_type(ctx
, sizes
, dim
, type
);
2506 oberon_make_open_array(oberon_context_t
* ctx
, oberon_type_t
* base
, oberon_type_t
* type
)
2508 type
-> class = OBERON_TYPE_ARRAY
;
2510 type
-> base
= base
;
2514 oberon_field_list(oberon_context_t
* ctx
, oberon_type_t
* rec
, oberon_scope_t
* modscope
)
2516 if(ctx
-> token
== IDENT
)
2519 oberon_object_t
* list
;
2520 oberon_type_t
* type
;
2521 type
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2523 oberon_ident_list(ctx
, OBERON_CLASS_FIELD
, true, &num
, &list
);
2524 oberon_assert_token(ctx
, COLON
);
2526 oberon_scope_t
* current
= ctx
-> decl
;
2527 ctx
-> decl
= modscope
;
2528 oberon_type(ctx
, &type
);
2529 ctx
-> decl
= current
;
2531 oberon_object_t
* field
= list
;
2532 for(int i
= 0; i
< num
; i
++)
2534 field
-> type
= type
;
2535 field
= field
-> next
;
2538 rec
-> num_decl
+= num
;
2543 oberon_type_record_body(oberon_context_t
* ctx
, oberon_type_t
* rec
)
2545 oberon_scope_t
* modscope
= ctx
-> mod
-> decl
;
2546 oberon_scope_t
* oldscope
= ctx
-> decl
;
2547 ctx
-> decl
= modscope
;
2549 if(ctx
-> token
== LPAREN
)
2551 oberon_assert_token(ctx
, LPAREN
);
2553 oberon_object_t
* typeobj
;
2554 typeobj
= oberon_qualident(ctx
, NULL
, true);
2556 if(typeobj
-> class != OBERON_CLASS_TYPE
)
2558 oberon_error(ctx
, "base must be type");
2561 oberon_type_t
* base
= typeobj
-> type
;
2562 if(base
-> class == OBERON_TYPE_POINTER
)
2564 base
= base
-> base
;
2567 if(base
-> class != OBERON_TYPE_RECORD
)
2569 oberon_error(ctx
, "base must be record type");
2573 ctx
-> decl
= base
-> scope
;
2575 oberon_assert_token(ctx
, RPAREN
);
2582 oberon_scope_t
* this_scope
;
2583 this_scope
= oberon_open_scope(ctx
);
2584 this_scope
-> local
= true;
2585 this_scope
-> parent
= NULL
;
2586 this_scope
-> parent_type
= rec
;
2588 oberon_field_list(ctx
, rec
, modscope
);
2589 while(ctx
-> token
== SEMICOLON
)
2591 oberon_assert_token(ctx
, SEMICOLON
);
2592 oberon_field_list(ctx
, rec
, modscope
);
2595 rec
-> scope
= this_scope
;
2596 rec
-> decl
= this_scope
-> list
-> next
;
2597 ctx
-> decl
= oldscope
;
2601 oberon_type(oberon_context_t
* ctx
, oberon_type_t
** type
)
2603 if(ctx
-> token
== IDENT
)
2605 oberon_qualident_type(ctx
, type
);
2607 else if(ctx
-> token
== ARRAY
)
2609 oberon_assert_token(ctx
, ARRAY
);
2612 oberon_expr_t
* sizes
;
2614 if(ISEXPR(ctx
-> token
))
2616 oberon_expr_list(ctx
, &num_sizes
, &sizes
, 1);
2619 oberon_assert_token(ctx
, OF
);
2621 oberon_type_t
* base
;
2622 base
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2623 oberon_type(ctx
, &base
);
2627 oberon_make_open_array(ctx
, base
, *type
);
2631 oberon_make_multiarray(ctx
, sizes
, base
, type
);
2634 else if(ctx
-> token
== RECORD
)
2636 oberon_type_t
* rec
;
2638 rec
-> class = OBERON_TYPE_RECORD
;
2639 rec
-> module
= ctx
-> mod
;
2641 oberon_assert_token(ctx
, RECORD
);
2642 oberon_type_record_body(ctx
, rec
);
2643 oberon_assert_token(ctx
, END
);
2647 else if(ctx
-> token
== POINTER
)
2649 oberon_assert_token(ctx
, POINTER
);
2650 oberon_assert_token(ctx
, TO
);
2652 oberon_type_t
* base
;
2653 base
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2654 oberon_type(ctx
, &base
);
2656 oberon_type_t
* ptr
;
2658 ptr
-> class = OBERON_TYPE_POINTER
;
2661 else if(ctx
-> token
== PROCEDURE
)
2663 oberon_open_scope(ctx
);
2664 oberon_assert_token(ctx
, PROCEDURE
);
2665 oberon_opt_formal_pars(ctx
, type
);
2666 oberon_close_scope(ctx
-> decl
);
2670 oberon_error(ctx
, "invalid type declaration");
2675 oberon_type_decl(oberon_context_t
* ctx
)
2678 oberon_object_t
* newtype
;
2679 oberon_type_t
* type
;
2683 name
= oberon_assert_ident(ctx
);
2684 oberon_def(ctx
, &export
, &read_only
);
2686 newtype
= oberon_find_object(ctx
-> decl
, name
, 0);
2689 newtype
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, export
, read_only
, false);
2690 newtype
-> type
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
2691 assert(newtype
-> type
);
2695 if(newtype
-> class != OBERON_CLASS_TYPE
)
2697 oberon_error(ctx
, "mult definition");
2700 if(newtype
-> linked
)
2702 oberon_error(ctx
, "mult definition - already linked");
2705 newtype
-> export
= export
;
2706 newtype
-> read_only
= read_only
;
2709 oberon_assert_token(ctx
, EQUAL
);
2711 type
= newtype
-> type
;
2712 oberon_type(ctx
, &type
);
2714 if(type
-> class == OBERON_TYPE_NOTYPE
)
2716 oberon_error(ctx
, "recursive alias declaration");
2719 newtype
-> type
= type
;
2720 newtype
-> linked
= 1;
2723 static void oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2724 static void oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2727 oberon_prevent_recursive_pointer(oberon_context_t
* ctx
, oberon_type_t
* type
)
2729 if(type
-> class != OBERON_TYPE_POINTER
2730 && type
-> class != OBERON_TYPE_ARRAY
)
2735 if(type
-> recursive
)
2737 oberon_error(ctx
, "recursive pointer declaration");
2740 if(type
-> class == OBERON_TYPE_POINTER
2741 && type
-> base
-> class == OBERON_TYPE_POINTER
)
2743 oberon_error(ctx
, "attempt to make pointer to pointer");
2746 type
-> recursive
= 1;
2748 oberon_prevent_recursive_pointer(ctx
, type
-> base
);
2750 type
-> recursive
= 0;
2754 oberon_prevent_recursive_record(oberon_context_t
* ctx
, oberon_type_t
* type
)
2756 if(type
-> class != OBERON_TYPE_RECORD
)
2761 if(type
-> recursive
)
2763 oberon_error(ctx
, "recursive record declaration");
2766 type
-> recursive
= 1;
2770 oberon_prevent_recursive_record(ctx
, type
-> base
);
2773 int num_fields
= type
-> num_decl
;
2774 oberon_object_t
* field
= type
-> decl
;
2775 for(int i
= 0; i
< num_fields
; i
++)
2777 oberon_prevent_recursive_object(ctx
, field
);
2778 field
= field
-> next
;
2781 type
-> recursive
= 0;
2784 oberon_prevent_recursive_procedure(oberon_context_t
* ctx
, oberon_type_t
* type
)
2786 if(type
-> class != OBERON_TYPE_PROCEDURE
)
2791 if(type
-> recursive
)
2793 oberon_error(ctx
, "recursive procedure declaration");
2796 type
-> recursive
= 1;
2798 int num_fields
= type
-> num_decl
;
2799 oberon_object_t
* field
= type
-> decl
;
2800 for(int i
= 0; i
< num_fields
; i
++)
2802 oberon_prevent_recursive_object(ctx
, field
);
2803 field
= field
-> next
;
2806 type
-> recursive
= 0;
2810 oberon_prevent_recursive_array(oberon_context_t
* ctx
, oberon_type_t
* type
)
2812 if(type
-> class != OBERON_TYPE_ARRAY
)
2817 if(type
-> recursive
)
2819 oberon_error(ctx
, "recursive array declaration");
2822 type
-> recursive
= 1;
2824 oberon_prevent_recursive_type(ctx
, type
-> base
);
2826 type
-> recursive
= 0;
2830 oberon_prevent_recursive_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2832 if(type
-> class == OBERON_TYPE_POINTER
)
2834 oberon_prevent_recursive_pointer(ctx
, type
);
2836 else if(type
-> class == OBERON_TYPE_RECORD
)
2838 oberon_prevent_recursive_record(ctx
, type
);
2840 else if(type
-> class == OBERON_TYPE_ARRAY
)
2842 oberon_prevent_recursive_array(ctx
, type
);
2844 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2846 oberon_prevent_recursive_procedure(ctx
, type
);
2851 oberon_prevent_recursive_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2855 case OBERON_CLASS_VAR
:
2856 case OBERON_CLASS_TYPE
:
2857 case OBERON_CLASS_PARAM
:
2858 case OBERON_CLASS_VAR_PARAM
:
2859 case OBERON_CLASS_FIELD
:
2860 oberon_prevent_recursive_type(ctx
, x
-> type
);
2862 case OBERON_CLASS_CONST
:
2863 case OBERON_CLASS_PROC
:
2864 case OBERON_CLASS_MODULE
:
2867 oberon_error(ctx
, "oberon_prevent_recursive_object: wat");
2873 oberon_prevent_recursive_decl(oberon_context_t
* ctx
)
2875 oberon_object_t
* x
= ctx
-> decl
-> list
-> next
;
2879 oberon_prevent_recursive_object(ctx
, x
);
2884 static void oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
);
2885 static void oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
);
2888 oberon_initialize_record_fields(oberon_context_t
* ctx
, oberon_type_t
* type
)
2890 if(type
-> class != OBERON_TYPE_RECORD
)
2895 int num_fields
= type
-> num_decl
;
2896 oberon_object_t
* field
= type
-> decl
;
2897 for(int i
= 0; i
< num_fields
; i
++)
2899 if(field
-> type
-> class == OBERON_TYPE_POINTER
)
2901 oberon_initialize_type(ctx
, field
-> type
);
2904 oberon_initialize_object(ctx
, field
);
2905 field
= field
-> next
;
2908 oberon_generator_init_record(ctx
, type
);
2912 oberon_initialize_type(oberon_context_t
* ctx
, oberon_type_t
* type
)
2914 if(type
-> class == OBERON_TYPE_NOTYPE
)
2916 oberon_error(ctx
, "undeclarated type");
2919 if(type
-> initialized
)
2924 type
-> initialized
= 1;
2926 if(type
-> class == OBERON_TYPE_POINTER
)
2928 oberon_initialize_type(ctx
, type
-> base
);
2929 oberon_generator_init_type(ctx
, type
);
2931 else if(type
-> class == OBERON_TYPE_ARRAY
)
2933 if(type
-> size
!= 0)
2935 if(type
-> base
-> class == OBERON_TYPE_ARRAY
)
2937 if(type
-> base
-> size
== 0)
2939 oberon_error(ctx
, "open array not allowed as array element");
2944 oberon_initialize_type(ctx
, type
-> base
);
2945 oberon_generator_init_type(ctx
, type
);
2947 else if(type
-> class == OBERON_TYPE_RECORD
)
2949 oberon_generator_init_type(ctx
, type
);
2950 oberon_initialize_record_fields(ctx
, type
);
2952 else if(type
-> class == OBERON_TYPE_PROCEDURE
)
2954 int num_fields
= type
-> num_decl
;
2955 oberon_object_t
* field
= type
-> decl
;
2956 for(int i
= 0; i
< num_fields
; i
++)
2958 //oberon_initialize_object(ctx, field);
2959 oberon_initialize_type(ctx
, field
-> type
);
2960 field
= field
-> next
;
2963 oberon_generator_init_type(ctx
, type
);
2967 oberon_generator_init_type(ctx
, type
);
2972 oberon_initialize_object(oberon_context_t
* ctx
, oberon_object_t
* x
)
2974 if(x
-> initialized
)
2979 x
-> initialized
= 1;
2983 case OBERON_CLASS_TYPE
:
2984 oberon_initialize_type(ctx
, x
-> type
);
2986 case OBERON_CLASS_VAR
:
2987 case OBERON_CLASS_FIELD
:
2988 if(x
-> type
-> class == OBERON_TYPE_ARRAY
)
2990 if(x
-> type
-> size
== 0)
2992 oberon_error(ctx
, "open array not allowed as variable or field");
2995 oberon_initialize_type(ctx
, x
-> type
);
2996 oberon_generator_init_var(ctx
, x
);
2998 case OBERON_CLASS_PARAM
:
2999 case OBERON_CLASS_VAR_PARAM
:
3000 oberon_initialize_type(ctx
, x
-> type
);
3001 oberon_generator_init_var(ctx
, x
);
3003 case OBERON_CLASS_CONST
:
3004 case OBERON_CLASS_PROC
:
3005 case OBERON_CLASS_MODULE
:
3008 oberon_error(ctx
, "oberon_initialize_object: wat");
3014 oberon_initialize_decl(oberon_context_t
* ctx
)
3016 oberon_object_t
* x
= ctx
-> decl
-> list
;
3020 oberon_initialize_object(ctx
, x
-> next
);
3026 oberon_prevent_undeclarated_procedures(oberon_context_t
* ctx
)
3028 oberon_object_t
* x
= ctx
-> decl
-> list
;
3032 if(x
-> next
-> class == OBERON_CLASS_PROC
)
3034 if(x
-> next
-> linked
== 0)
3036 oberon_error(ctx
, "unresolved forward declaration");
3044 oberon_decl_seq(oberon_context_t
* ctx
)
3046 if(ctx
-> token
== CONST
)
3048 oberon_assert_token(ctx
, CONST
);
3049 while(ctx
-> token
== IDENT
)
3051 oberon_const_decl(ctx
);
3052 oberon_assert_token(ctx
, SEMICOLON
);
3056 if(ctx
-> token
== TYPE
)
3058 oberon_assert_token(ctx
, TYPE
);
3059 while(ctx
-> token
== IDENT
)
3061 oberon_type_decl(ctx
);
3062 oberon_assert_token(ctx
, SEMICOLON
);
3066 if(ctx
-> token
== VAR
)
3068 oberon_assert_token(ctx
, VAR
);
3069 while(ctx
-> token
== IDENT
)
3071 oberon_var_decl(ctx
);
3072 oberon_assert_token(ctx
, SEMICOLON
);
3076 oberon_prevent_recursive_decl(ctx
);
3077 oberon_initialize_decl(ctx
);
3079 while(ctx
-> token
== PROCEDURE
)
3081 oberon_proc_decl(ctx
);
3082 oberon_assert_token(ctx
, SEMICOLON
);
3085 oberon_prevent_undeclarated_procedures(ctx
);
3088 static oberon_expr_t
*
3089 oberon_make_temp_var_item(oberon_context_t
* ctx
, oberon_type_t
* type
)
3091 oberon_object_t
* x
;
3092 oberon_expr_t
* expr
;
3094 x
= oberon_create_object(ctx
-> decl
, "TEMP", OBERON_CLASS_VAR
, false, false);
3097 oberon_generator_init_temp_var(ctx
, x
);
3099 expr
= oberon_new_item(MODE_VAR
, type
, false);
3100 expr
-> item
.var
= x
;
3105 oberon_statement_seq(oberon_context_t
* ctx
);
3108 oberon_assign(oberon_context_t
* ctx
, oberon_expr_t
* src
, oberon_expr_t
* dst
)
3110 oberon_check_dst(ctx
, dst
);
3111 oberon_check_assignment_compatible(ctx
, src
, dst
-> result
);
3113 if(oberon_is_array_of_char_type(dst
-> result
)
3114 && oberon_is_string_type(src
-> result
))
3117 oberon_make_copy_call(ctx
, 2, src
);
3121 src
= oberon_cast_expr(ctx
, src
, dst
-> result
);
3122 oberon_generate_assign(ctx
, src
, dst
);
3126 static oberon_expr_t
*
3127 oberon_case_labels(oberon_context_t
* ctx
, oberon_expr_t
* val
)
3131 oberon_expr_t
* cond
;
3132 oberon_expr_t
* cond2
;
3134 e1
= (oberon_expr_t
*) oberon_const_expr(ctx
);
3137 if(ctx
-> token
== DOTDOT
)
3139 oberon_assert_token(ctx
, DOTDOT
);
3140 e2
= (oberon_expr_t
*) oberon_const_expr(ctx
);
3146 cond
= oberon_make_bin_op(ctx
, EQUAL
, val
, e1
);
3150 /* val >= e1 && val <= e2 */
3151 cond
= oberon_make_bin_op(ctx
, GEQ
, val
, e1
);
3152 cond2
= oberon_make_bin_op(ctx
, LEQ
, val
, e2
);
3153 cond
= oberon_make_bin_op(ctx
, AND
, cond
, cond2
);
3160 oberon_case(oberon_context_t
* ctx
, oberon_expr_t
* val
, gen_label_t
* end
)
3162 oberon_expr_t
* cond
;
3163 oberon_expr_t
* cond2
;
3164 gen_label_t
* this_end
;
3166 if(ISEXPR(ctx
-> token
))
3168 this_end
= oberon_generator_reserve_label(ctx
);
3170 cond
= oberon_case_labels(ctx
, val
);
3171 while(ctx
-> token
== COMMA
)
3173 oberon_assert_token(ctx
, COMMA
);
3175 cond2
= oberon_case_labels(ctx
, val
);
3176 cond
= oberon_make_bin_op(ctx
, OR
, cond
, cond2
);
3178 oberon_assert_token(ctx
, COLON
);
3180 oberon_generate_branch(ctx
, cond
, false, this_end
);
3181 oberon_statement_seq(ctx
);
3182 oberon_generate_goto(ctx
, end
);
3184 oberon_generate_label(ctx
, this_end
);
3189 oberon_case_statement(oberon_context_t
* ctx
)
3191 oberon_expr_t
* val
;
3192 oberon_expr_t
* expr
;
3195 end
= oberon_generator_reserve_label(ctx
);
3197 oberon_assert_token(ctx
, CASE
);
3198 expr
= oberon_expr(ctx
);
3199 val
= oberon_make_temp_var_item(ctx
, expr
-> result
);
3200 oberon_assign(ctx
, expr
, val
);
3201 oberon_assert_token(ctx
, OF
);
3202 oberon_case(ctx
, val
, end
);
3203 while(ctx
-> token
== BAR
)
3205 oberon_assert_token(ctx
, BAR
);
3206 oberon_case(ctx
, val
, end
);
3209 if(ctx
-> token
== ELSE
)
3211 oberon_assert_token(ctx
, ELSE
);
3212 oberon_statement_seq(ctx
);
3216 oberon_generate_trap(ctx
, -1);
3219 oberon_generate_label(ctx
, end
);
3220 oberon_assert_token(ctx
, END
);
3224 oberon_with_guard_do(oberon_context_t
* ctx
, gen_label_t
* end
)
3226 oberon_expr_t
* val
;
3227 oberon_expr_t
* var
;
3228 oberon_expr_t
* type
;
3229 oberon_expr_t
* cond
;
3230 oberon_expr_t
* cast
;
3231 oberon_type_t
* old_type
;
3232 gen_var_t
* old_var
;
3233 gen_label_t
* this_end
;
3235 this_end
= oberon_generator_reserve_label(ctx
);
3237 var
= oberon_qualident_expr(ctx
);
3238 oberon_assert_token(ctx
, COLON
);
3239 type
= oberon_qualident_expr(ctx
);
3240 cond
= oberon_make_bin_op(ctx
, IS
, var
, type
);
3242 oberon_assert_token(ctx
, DO
);
3243 oberon_generate_branch(ctx
, cond
, false, this_end
);
3245 /* Сохраняем ссылку во временной переменной */
3246 val
= oberon_make_temp_var_item(ctx
, type
-> result
);
3247 //cast = oberno_make_record_cast(ctx, var, type -> result);
3248 cast
= oberon_cast_expr(ctx
, var
, type
-> result
);
3249 oberon_assign(ctx
, cast
, val
);
3250 /* Подменяем тип у оригинальной переменной */
3251 old_type
= var
-> item
.var
-> type
;
3252 var
-> item
.var
-> type
= type
-> result
;
3253 /* Подменяем ссылку на переменную */
3254 old_var
= var
-> item
.var
-> gen_var
;
3255 var
-> item
.var
-> gen_var
= val
-> item
.var
-> gen_var
;
3257 oberon_statement_seq(ctx
);
3258 oberon_generate_goto(ctx
, end
);
3259 oberon_generate_label(ctx
, this_end
);
3261 /* Возвращаем исходное состояние */
3262 var
-> item
.var
-> gen_var
= old_var
;
3263 var
-> item
.var
-> type
= old_type
;
3267 oberon_with_statement(oberon_context_t
* ctx
)
3270 end
= oberon_generator_reserve_label(ctx
);
3272 oberon_assert_token(ctx
, WITH
);
3273 oberon_with_guard_do(ctx
, end
);
3274 while(ctx
-> token
== BAR
)
3276 oberon_assert_token(ctx
, BAR
);
3277 oberon_with_guard_do(ctx
, end
);
3280 if(ctx
-> token
== ELSE
)
3282 oberon_assert_token(ctx
, ELSE
);
3283 oberon_statement_seq(ctx
);
3287 oberon_generate_trap(ctx
, -2);
3290 oberon_generate_label(ctx
, end
);
3291 oberon_assert_token(ctx
, END
);
3295 oberon_statement(oberon_context_t
* ctx
)
3297 oberon_expr_t
* item1
;
3298 oberon_expr_t
* item2
;
3300 if(ctx
-> token
== IDENT
)
3302 item1
= oberon_designator(ctx
);
3303 if(ctx
-> token
== ASSIGN
)
3305 oberon_assert_token(ctx
, ASSIGN
);
3306 item2
= oberon_expr(ctx
);
3307 oberon_assign(ctx
, item2
, item1
);
3311 oberon_opt_proc_parens(ctx
, item1
);
3314 else if(ctx
-> token
== IF
)
3318 oberon_expr_t
* cond
;
3320 els
= oberon_generator_reserve_label(ctx
);
3321 end
= oberon_generator_reserve_label(ctx
);
3323 oberon_assert_token(ctx
, IF
);
3324 cond
= oberon_expr(ctx
);
3325 if(cond
-> result
-> class != OBERON_TYPE_BOOLEAN
)
3327 oberon_error(ctx
, "condition must be boolean");
3329 oberon_assert_token(ctx
, THEN
);
3330 oberon_generate_branch(ctx
, cond
, false, els
);
3331 oberon_statement_seq(ctx
);
3332 oberon_generate_goto(ctx
, end
);
3333 oberon_generate_label(ctx
, els
);
3335 while(ctx
-> token
== ELSIF
)
3337 els
= oberon_generator_reserve_label(ctx
);
3339 oberon_assert_token(ctx
, ELSIF
);
3340 cond
= oberon_expr(ctx
);
3341 if(cond
-> result
-> class != OBERON_TYPE_BOOLEAN
)
3343 oberon_error(ctx
, "condition must be boolean");
3345 oberon_assert_token(ctx
, THEN
);
3346 oberon_generate_branch(ctx
, cond
, false, els
);
3347 oberon_statement_seq(ctx
);
3348 oberon_generate_goto(ctx
, end
);
3349 oberon_generate_label(ctx
, els
);
3352 if(ctx
-> token
== ELSE
)
3354 oberon_assert_token(ctx
, ELSE
);
3355 oberon_statement_seq(ctx
);
3358 oberon_generate_label(ctx
, end
);
3359 oberon_assert_token(ctx
, END
);
3361 else if(ctx
-> token
== WHILE
)
3363 gen_label_t
* begin
;
3365 oberon_expr_t
* cond
;
3367 begin
= oberon_generator_reserve_label(ctx
);
3368 end
= oberon_generator_reserve_label(ctx
);
3370 oberon_assert_token(ctx
, WHILE
);
3371 oberon_generate_label(ctx
, begin
);
3372 cond
= oberon_expr(ctx
);
3373 if(cond
-> result
-> class != OBERON_TYPE_BOOLEAN
)
3375 oberon_error(ctx
, "condition must be boolean");
3377 oberon_generate_branch(ctx
, cond
, false, end
);
3379 oberon_assert_token(ctx
, DO
);
3380 oberon_statement_seq(ctx
);
3381 oberon_generate_goto(ctx
, begin
);
3383 oberon_assert_token(ctx
, END
);
3384 oberon_generate_label(ctx
, end
);
3386 else if(ctx
-> token
== REPEAT
)
3388 gen_label_t
* begin
;
3389 oberon_expr_t
* cond
;
3391 begin
= oberon_generator_reserve_label(ctx
);
3392 oberon_generate_label(ctx
, begin
);
3393 oberon_assert_token(ctx
, REPEAT
);
3395 oberon_statement_seq(ctx
);
3397 oberon_assert_token(ctx
, UNTIL
);
3399 cond
= oberon_expr(ctx
);
3400 if(cond
-> result
-> class != OBERON_TYPE_BOOLEAN
)
3402 oberon_error(ctx
, "condition must be boolean");
3405 oberon_generate_branch(ctx
, cond
, true, begin
);
3407 else if(ctx
-> token
== FOR
)
3409 oberon_expr_t
* from
;
3410 oberon_expr_t
* index
;
3412 oberon_expr_t
* bound
;
3414 oberon_expr_t
* cond
;
3415 oberon_expr_t
* count
;
3416 gen_label_t
* begin
;
3421 begin
= oberon_generator_reserve_label(ctx
);
3422 end
= oberon_generator_reserve_label(ctx
);
3424 oberon_assert_token(ctx
, FOR
);
3425 iname
= oberon_assert_ident(ctx
);
3426 index
= oberon_ident_item(ctx
, iname
);
3427 oberon_assert_token(ctx
, ASSIGN
);
3428 from
= oberon_expr(ctx
);
3429 oberon_assert_token(ctx
, TO
);
3430 bound
= oberon_make_temp_var_item(ctx
, index
-> result
);
3431 to
= oberon_expr(ctx
);
3432 oberon_assign(ctx
, to
, bound
); // сначала temp
3433 oberon_assign(ctx
, from
, index
); // потом i
3434 if(ctx
-> token
== BY
)
3436 oberon_assert_token(ctx
, BY
);
3437 by
= (oberon_expr_t
*) oberon_const_expr(ctx
);
3441 by
= oberon_make_integer(ctx
, 1);
3444 if(by
-> result
-> class != OBERON_TYPE_INTEGER
)
3446 oberon_error(ctx
, "must be integer");
3449 if(by
-> item
.integer
> 0)
3453 else if(by
-> item
.integer
< 0)
3459 oberon_error(ctx
, "zero step not allowed");
3462 oberon_assert_token(ctx
, DO
);
3463 oberon_generate_label(ctx
, begin
);
3464 cond
= oberon_make_bin_op(ctx
, op
, index
, bound
);
3465 oberon_generate_branch(ctx
, cond
, false, end
);
3466 oberon_statement_seq(ctx
);
3467 count
= oberon_make_bin_op(ctx
, PLUS
, index
, by
);
3468 oberon_assign(ctx
, count
, index
);
3469 oberon_generate_goto(ctx
, begin
);
3470 oberon_generate_label(ctx
, end
);
3471 oberon_assert_token(ctx
, END
);
3473 else if(ctx
-> token
== LOOP
)
3475 gen_label_t
* begin
;
3478 begin
= oberon_generator_reserve_label(ctx
);
3479 end
= oberon_generator_reserve_label(ctx
);
3481 oberon_open_scope(ctx
);
3482 oberon_assert_token(ctx
, LOOP
);
3483 oberon_generate_label(ctx
, begin
);
3484 ctx
-> decl
-> exit_label
= end
;
3485 oberon_statement_seq(ctx
);
3486 oberon_generate_goto(ctx
, begin
);
3487 oberon_generate_label(ctx
, end
);
3488 oberon_assert_token(ctx
, END
);
3489 oberon_close_scope(ctx
-> decl
);
3491 else if(ctx
-> token
== EXIT
)
3493 oberon_assert_token(ctx
, EXIT
);
3494 if(ctx
-> decl
-> exit_label
== NULL
)
3496 oberon_error(ctx
, "not in LOOP-END");
3498 oberon_generate_goto(ctx
, ctx
-> decl
-> exit_label
);
3500 else if(ctx
-> token
== CASE
)
3502 oberon_case_statement(ctx
);
3504 else if(ctx
-> token
== WITH
)
3506 oberon_with_statement(ctx
);
3508 else if(ctx
-> token
== RETURN
)
3510 oberon_assert_token(ctx
, RETURN
);
3511 if(ISEXPR(ctx
-> token
))
3513 oberon_expr_t
* expr
;
3514 expr
= oberon_expr(ctx
);
3515 oberon_make_return(ctx
, expr
);
3519 oberon_make_return(ctx
, NULL
);
3525 oberon_statement_seq(oberon_context_t
* ctx
)
3527 oberon_statement(ctx
);
3528 while(ctx
-> token
== SEMICOLON
)
3530 oberon_assert_token(ctx
, SEMICOLON
);
3531 oberon_statement(ctx
);
3536 oberon_import_module(oberon_context_t
* ctx
, char * alias
, char * name
)
3538 oberon_module_t
* m
= ctx
-> module_list
;
3539 while(m
&& strcmp(m
-> name
, name
) != 0)
3547 code
= ctx
-> import_module(name
);
3550 oberon_error(ctx
, "no such module");
3553 m
= oberon_compile_module(ctx
, code
);
3559 oberon_error(ctx
, "cyclic module import");
3562 oberon_object_t
* ident
;
3563 ident
= oberon_define_object(ctx
-> decl
, alias
, OBERON_CLASS_MODULE
, false, false, false);
3564 ident
-> module
= m
;
3568 oberon_import_decl(oberon_context_t
* ctx
)
3573 alias
= name
= oberon_assert_ident(ctx
);
3574 if(ctx
-> token
== ASSIGN
)
3576 oberon_assert_token(ctx
, ASSIGN
);
3577 name
= oberon_assert_ident(ctx
);
3580 oberon_import_module(ctx
, alias
, name
);
3584 oberon_import_list(oberon_context_t
* ctx
)
3586 oberon_assert_token(ctx
, IMPORT
);
3588 oberon_import_decl(ctx
);
3589 while(ctx
-> token
== COMMA
)
3591 oberon_assert_token(ctx
, COMMA
);
3592 oberon_import_decl(ctx
);
3595 oberon_assert_token(ctx
, SEMICOLON
);
3599 oberon_parse_module(oberon_context_t
* ctx
)
3603 oberon_read_token(ctx
);
3605 oberon_assert_token(ctx
, MODULE
);
3606 name1
= oberon_assert_ident(ctx
);
3607 oberon_assert_token(ctx
, SEMICOLON
);
3608 ctx
-> mod
-> name
= name1
;
3610 oberon_generator_init_module(ctx
, ctx
-> mod
);
3612 if(ctx
-> token
== IMPORT
)
3614 oberon_import_list(ctx
);
3617 oberon_decl_seq(ctx
);
3619 oberon_generate_begin_module(ctx
);
3620 if(ctx
-> token
== BEGIN
)
3622 oberon_assert_token(ctx
, BEGIN
);
3623 oberon_statement_seq(ctx
);
3625 oberon_generate_end_module(ctx
);
3627 oberon_assert_token(ctx
, END
);
3628 name2
= oberon_assert_ident(ctx
);
3629 oberon_expect_token(ctx
, DOT
);
3631 if(strcmp(name1
, name2
) != 0)
3633 oberon_error(ctx
, "module name not matched");
3636 oberon_generator_fini_module(ctx
-> mod
);
3639 // =======================================================================
3641 // =======================================================================
3643 static oberon_expr_t
*
3644 oberon_make_min_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3648 oberon_error(ctx
, "too few arguments");
3653 oberon_error(ctx
, "too mach arguments");
3656 oberon_expr_t
* arg
;
3659 if(!oberon_is_type_expr(arg
))
3661 oberon_error(ctx
, "MIN accept only type");
3664 oberon_expr_t
* expr
;
3665 int bits
= arg
-> result
-> size
* 8;
3666 switch(arg
-> result
-> class)
3668 case OBERON_TYPE_INTEGER
:
3669 expr
= oberon_make_integer(ctx
, -powl(2, bits
- 1));
3671 case OBERON_TYPE_BOOLEAN
:
3672 expr
= oberon_make_boolean(ctx
, false);
3674 case OBERON_TYPE_CHAR
:
3675 expr
= oberon_make_char(ctx
, 0);
3677 case OBERON_TYPE_REAL
:
3678 expr
= oberon_make_real_typed(ctx
, (bits
<= 32) ? (-FLT_MAX
) : (-DBL_MAX
), arg
-> result
);
3680 case OBERON_TYPE_SET
:
3681 expr
= oberon_make_integer(ctx
, 0);
3684 oberon_error(ctx
, "allowed only basic types");
3691 static oberon_expr_t
*
3692 oberon_make_max_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3696 oberon_error(ctx
, "too few arguments");
3701 oberon_error(ctx
, "too mach arguments");
3704 oberon_expr_t
* arg
;
3707 if(!oberon_is_type_expr(arg
))
3709 oberon_error(ctx
, "MAX accept only type");
3712 oberon_expr_t
* expr
;
3713 int bits
= arg
-> result
-> size
* 8;
3714 switch(arg
-> result
-> class)
3716 case OBERON_TYPE_INTEGER
:
3717 expr
= oberon_make_integer(ctx
, powl(2, bits
- 1) - 1);
3719 case OBERON_TYPE_BOOLEAN
:
3720 expr
= oberon_make_boolean(ctx
, true);
3722 case OBERON_TYPE_CHAR
:
3723 expr
= oberon_make_char(ctx
, powl(2, bits
) - 1);
3725 case OBERON_TYPE_REAL
:
3726 expr
= oberon_make_real_typed(ctx
, (bits
<= 32) ? (FLT_MAX
) : (DBL_MAX
), arg
-> result
);
3728 case OBERON_TYPE_SET
:
3729 expr
= oberon_make_integer(ctx
, bits
);
3732 oberon_error(ctx
, "allowed only basic types");
3739 static oberon_expr_t
*
3740 oberon_make_size_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3744 oberon_error(ctx
, "too few arguments");
3749 oberon_error(ctx
, "too mach arguments");
3752 oberon_expr_t
* arg
;
3754 if(!oberon_is_type_expr(arg
))
3756 oberon_error(ctx
, "SIZE accept only type");
3760 oberon_expr_t
* expr
;
3761 oberon_type_t
* type
= arg
-> result
;
3762 switch(type
-> class)
3764 case OBERON_TYPE_INTEGER
:
3765 case OBERON_TYPE_BOOLEAN
:
3766 case OBERON_TYPE_REAL
:
3767 case OBERON_TYPE_CHAR
:
3768 case OBERON_TYPE_SET
:
3769 size
= type
-> size
;
3772 oberon_error(ctx
, "TODO SIZE");
3776 expr
= oberon_make_integer(ctx
, size
);
3780 static oberon_expr_t
*
3781 oberon_make_abs_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3785 oberon_error(ctx
, "too few arguments");
3790 oberon_error(ctx
, "too mach arguments");
3793 oberon_expr_t
* arg
;
3795 oberon_check_src(ctx
, arg
);
3797 if(oberon_is_number_type(arg
-> result
))
3799 oberon_error(ctx
, "ABS accepts only numbers");
3802 oberon_expr_t
* expr
;
3803 if(oberon_is_const(arg
))
3805 if(oberon_is_real_type(arg
-> result
))
3807 double x
= arg
-> item
.real
;
3808 expr
= oberon_make_real(ctx
, fabsl(x
), arg
-> result
);
3812 int64_t x
= arg
-> item
.integer
;
3813 expr
= oberon_make_integer(ctx
, llabs(x
));
3818 expr
= oberon_new_operator(OP_ABS
, arg
-> result
, arg
, NULL
);
3824 oberon_make_inc_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3828 oberon_error(ctx
, "too few arguments");
3833 oberon_error(ctx
, "too mach arguments");
3836 oberon_expr_t
* dst
;
3838 oberon_check_dst(ctx
, dst
);
3840 if(!oberon_is_integer_type(dst
-> result
))
3842 oberon_error(ctx
, "expect integer");
3845 oberon_expr_t
* expr
;
3846 expr
= oberon_make_bin_op(ctx
, PLUS
, dst
, oberon_make_integer(ctx
, 1));
3847 oberon_assign(ctx
, expr
, dst
);
3851 oberon_make_incl_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3855 oberon_error(ctx
, "too few arguments");
3860 oberon_error(ctx
, "too mach arguments");
3863 oberon_expr_t
* dst
;
3865 oberon_check_dst(ctx
, dst
);
3867 if(!oberon_is_set_type(dst
-> result
))
3869 oberon_error(ctx
, "expect integer");
3873 x
= list_args
-> next
;
3874 oberon_check_src(ctx
, x
);
3876 if(!oberon_is_integer_type(x
-> result
))
3878 oberon_error(ctx
, "expect integer");
3881 oberon_expr_t
* expr
;
3882 expr
= oberon_make_bin_op(ctx
, PLUS
, dst
, oberon_new_operator(OP_RANGE
, dst
-> result
, x
, NULL
));
3883 oberon_assign(ctx
, expr
, dst
);
3887 oberon_make_excl_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3891 oberon_error(ctx
, "too few arguments");
3896 oberon_error(ctx
, "too mach arguments");
3899 oberon_expr_t
* dst
;
3901 oberon_check_dst(ctx
, dst
);
3903 if(!oberon_is_set_type(dst
-> result
))
3905 oberon_error(ctx
, "expect integer");
3909 x
= list_args
-> next
;
3910 oberon_check_src(ctx
, x
);
3912 if(!oberon_is_integer_type(x
-> result
))
3914 oberon_error(ctx
, "expect integer");
3917 oberon_expr_t
* expr
;
3918 expr
= oberon_make_bin_op(ctx
, MINUS
, dst
, oberon_new_operator(OP_RANGE
, dst
-> result
, x
, NULL
));
3919 oberon_assign(ctx
, expr
, dst
);
3923 oberon_make_dec_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3927 oberon_error(ctx
, "too few arguments");
3932 oberon_error(ctx
, "too mach arguments");
3935 oberon_expr_t
* dst
;
3937 oberon_check_dst(ctx
, dst
);
3939 if(!oberon_is_integer_type(dst
-> result
))
3941 oberon_error(ctx
, "expect integer");
3944 oberon_expr_t
* expr
;
3945 expr
= oberon_make_bin_op(ctx
, MINUS
, dst
, oberon_make_integer(ctx
, 1));
3946 oberon_assign(ctx
, expr
, dst
);
3950 oberon_make_new_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
3954 oberon_error(ctx
, "too few arguments");
3957 oberon_expr_t
* dst
;
3959 oberon_check_dst(ctx
, dst
);
3961 oberon_type_t
* type
;
3962 type
= dst
-> result
;
3964 if(type
-> class != OBERON_TYPE_POINTER
)
3966 oberon_error(ctx
, "not a pointer");
3969 type
= type
-> base
;
3971 oberon_expr_t
* src
;
3972 src
= oberon_new_item(MODE_NEW
, dst
-> result
, 0);
3973 src
-> item
.num_args
= 0;
3974 src
-> item
.args
= NULL
;
3977 if(type
-> class == OBERON_TYPE_ARRAY
)
3979 if(type
-> size
== 0)
3981 oberon_type_t
* x
= type
;
3982 while(x
-> class == OBERON_TYPE_ARRAY
)
3992 if(num_args
< max_args
)
3994 oberon_error(ctx
, "too few arguments");
3997 if(num_args
> max_args
)
3999 oberon_error(ctx
, "too mach arguments");
4002 int num_sizes
= max_args
- 1;
4003 oberon_expr_t
* size_list
= list_args
-> next
;
4005 oberon_expr_t
* arg
= size_list
;
4006 for(int i
= 0; i
< max_args
- 1; i
++)
4008 oberon_check_src(ctx
, arg
);
4009 if(arg
-> result
-> class != OBERON_TYPE_INTEGER
)
4011 oberon_error(ctx
, "size must be integer");
4016 src
-> item
.num_args
= num_sizes
;
4017 src
-> item
.args
= size_list
;
4019 else if(type
-> class != OBERON_TYPE_RECORD
)
4021 oberon_error(ctx
, "oberon_make_new_call: wat");
4024 if(num_args
> max_args
)
4026 oberon_error(ctx
, "too mach arguments");
4029 oberon_assign(ctx
, src
, dst
);
4033 oberon_make_copy_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4037 oberon_error(ctx
, "too few arguments");
4042 oberon_error(ctx
, "too mach arguments");
4045 oberon_expr_t
* src
;
4047 oberon_check_src(ctx
, src
);
4049 oberon_expr_t
* dst
;
4050 dst
= list_args
-> next
;
4051 oberon_check_dst(ctx
, dst
);
4053 if(!oberon_is_string_type(src
-> result
) && !oberon_is_array_of_char_type(src
-> result
))
4055 oberon_error(ctx
, "source must be string or array of char");
4058 if(!oberon_is_array_of_char_type(dst
-> result
))
4060 oberon_error(ctx
, "dst must be array of char");
4063 oberon_generate_copy(ctx
, src
, dst
);
4067 oberon_make_assert_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4071 oberon_error(ctx
, "too few arguments");
4076 oberon_error(ctx
, "too mach arguments");
4079 oberon_expr_t
* cond
;
4081 oberon_check_src(ctx
, cond
);
4083 if(!oberon_is_boolean_type(cond
-> result
))
4085 oberon_error(ctx
, "expected boolean");
4090 oberon_generate_assert(ctx
, cond
);
4094 oberon_expr_t
* num
;
4095 num
= list_args
-> next
;
4096 oberon_check_src(ctx
, num
);
4098 if(!oberon_is_integer_type(num
-> result
))
4100 oberon_error(ctx
, "expected integer");
4103 oberon_check_const(ctx
, num
);
4105 oberon_generate_assert_n(ctx
, cond
, num
-> item
.integer
);
4110 oberon_make_halt_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4114 oberon_error(ctx
, "too few arguments");
4119 oberon_error(ctx
, "too mach arguments");
4122 oberon_expr_t
* num
;
4124 oberon_check_src(ctx
, num
);
4126 if(num
-> result
-> class != OBERON_TYPE_INTEGER
)
4128 oberon_error(ctx
, "expected integer");
4131 oberon_check_const(ctx
, num
);
4133 oberon_generate_halt(ctx
, num
-> item
.integer
);
4136 static oberon_expr_t
*
4137 oberon_make_ash_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4141 oberon_error(ctx
, "too few arguments");
4146 oberon_error(ctx
, "too mach arguments");
4149 oberon_expr_t
* arg1
;
4151 oberon_check_src(ctx
, arg1
);
4152 if(arg1
-> result
-> class != OBERON_TYPE_INTEGER
)
4154 oberon_error(ctx
, "expected integer");
4157 oberon_expr_t
* arg2
;
4158 arg2
= list_args
-> next
;
4159 oberon_check_src(ctx
, arg2
);
4160 if(arg2
-> result
-> class != OBERON_TYPE_INTEGER
)
4162 oberon_error(ctx
, "expected integer");
4165 oberon_expr_t
* expr
;
4166 if(oberon_is_const(arg1
) && oberon_is_const(arg2
))
4168 int64_t x
= arg1
-> item
.integer
;
4169 int64_t y
= arg2
-> item
.integer
;
4170 int64_t v
= (y
> 0) ? (x
<< y
) : (x
>> labs(y
));
4171 expr
= oberon_make_integer(ctx
, v
);
4175 expr
= oberon_new_operator(OP_ASH
, arg1
-> result
, arg1
, arg2
);
4181 static oberon_expr_t
*
4182 oberon_make_lsh_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4186 oberon_error(ctx
, "too few arguments");
4191 oberon_error(ctx
, "too mach arguments");
4194 oberon_expr_t
* arg1
;
4196 oberon_check_src(ctx
, arg1
);
4198 oberon_type_t
* t
= arg1
-> result
;
4199 if(!oberon_is_integer_type(t
)
4200 && !oberon_is_char_type(t
)
4201 && !oberon_is_system_byte_type(t
))
4203 oberon_error(ctx
, "expected integer, char, or SYSTEM.BYTE");
4206 oberon_expr_t
* arg2
;
4207 arg2
= list_args
-> next
;
4208 oberon_check_src(ctx
, arg2
);
4209 if(arg2
-> result
-> class != OBERON_TYPE_INTEGER
)
4211 oberon_error(ctx
, "expected integer");
4214 oberon_expr_t
* expr
;
4215 if(oberon_is_const(arg1
) && oberon_is_const(arg2
))
4217 uint64_t x
= arg1
-> item
.integer
;
4218 int64_t y
= arg2
-> item
.integer
;
4219 uint64_t v
= (y
> 0) ? (x
<< y
) : (x
>> labs(y
));
4221 if(oberon_is_integer_type(t
))
4223 expr
= oberon_make_integer(ctx
, v
);
4225 else if(oberon_is_char_type(t
))
4227 expr
= oberon_make_char(ctx
, v
);
4231 expr
= oberon_make_system_byte(ctx
, v
);
4236 expr
= oberon_new_operator(OP_LSH
, arg1
-> result
, arg1
, arg2
);
4237 expr
= oberon_cast_expr(ctx
, expr
, t
);
4243 static oberon_expr_t
*
4244 oberon_make_rot_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4248 oberon_error(ctx
, "too few arguments");
4253 oberon_error(ctx
, "too mach arguments");
4256 oberon_expr_t
* arg1
;
4258 oberon_check_src(ctx
, arg1
);
4260 oberon_type_t
* t
= arg1
-> result
;
4261 if(!oberon_is_integer_type(t
)
4262 && !oberon_is_char_type(t
)
4263 && !oberon_is_system_byte_type(t
))
4265 oberon_error(ctx
, "expected integer, char, or SYSTEM.BYTE");
4268 oberon_expr_t
* arg2
;
4269 arg2
= list_args
-> next
;
4270 oberon_check_src(ctx
, arg2
);
4271 if(arg2
-> result
-> class != OBERON_TYPE_INTEGER
)
4273 oberon_error(ctx
, "expected integer");
4276 oberon_expr_t
* expr
;
4277 if(oberon_is_const(arg1
) && oberon_is_const(arg2
))
4279 uint64_t x
= arg1
-> item
.integer
;
4280 int64_t y
= arg2
-> item
.integer
;
4285 v
= (x
<< y
) | (x
>> (64 - y
));
4290 v
= (x
>> y
) | (x
<< (64 - y
));
4293 if(oberon_is_integer_type(t
))
4295 expr
= oberon_make_integer(ctx
, v
);
4297 else if(oberon_is_char_type(t
))
4299 expr
= oberon_make_char(ctx
, v
);
4303 expr
= oberon_make_system_byte(ctx
, v
);
4308 expr
= oberon_new_operator(OP_ROT
, arg1
-> result
, arg1
, arg2
);
4309 expr
= oberon_cast_expr(ctx
, expr
, t
);
4315 static oberon_expr_t
*
4316 oberon_make_cap_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4320 oberon_error(ctx
, "too few arguments");
4325 oberon_error(ctx
, "too mach arguments");
4328 oberon_expr_t
* arg
;
4330 oberon_check_src(ctx
, arg
);
4332 if(!oberon_is_char_type(arg
-> result
))
4334 oberon_error(ctx
, "expected char");
4337 oberon_expr_t
* expr
;
4338 if(oberon_is_const(arg
))
4340 expr
= oberon_make_char(ctx
, toupper(arg
-> item
.integer
));
4344 expr
= oberon_new_operator(OP_CAP
, arg
-> result
, arg
, NULL
);
4350 static oberon_expr_t
*
4351 oberon_make_chr_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4355 oberon_error(ctx
, "too few arguments");
4360 oberon_error(ctx
, "too mach arguments");
4363 oberon_expr_t
* arg
;
4365 oberon_check_src(ctx
, arg
);
4367 if(!oberon_is_integer_type(arg
-> result
))
4369 oberon_error(ctx
, "expected integer");
4372 oberon_expr_t
* expr
;
4373 if(oberon_is_const(arg
))
4375 expr
= oberon_make_char(ctx
, arg
-> item
.integer
);
4379 expr
= oberon_cast_expr(ctx
, arg
, ctx
-> char_type
);
4384 static oberon_expr_t
*
4385 oberon_make_ord_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4389 oberon_error(ctx
, "too few arguments");
4394 oberon_error(ctx
, "too mach arguments");
4397 oberon_expr_t
* arg
;
4399 oberon_check_src(ctx
, arg
);
4401 if(!oberon_is_char_type(arg
-> result
))
4403 oberon_error(ctx
, "expected char");
4406 oberon_expr_t
* expr
;
4407 if(oberon_is_const(arg
))
4409 expr
= oberon_make_integer(ctx
, arg
-> item
.integer
);
4413 expr
= oberon_cast_expr(ctx
, arg
, ctx
-> int_type
);
4418 static oberon_expr_t
*
4419 oberon_make_entier_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4423 oberon_error(ctx
, "too few arguments");
4428 oberon_error(ctx
, "too mach arguments");
4431 oberon_expr_t
* arg
;
4433 oberon_check_src(ctx
, arg
);
4435 if(!oberon_is_real_type(arg
-> result
))
4437 oberon_error(ctx
, "expected real");
4440 oberon_expr_t
* expr
;
4441 if(oberon_is_const(arg
))
4443 expr
= oberon_make_integer(ctx
, floor(arg
-> item
.real
));
4447 expr
= oberon_new_operator(OP_ENTIER
, ctx
-> int_type
, arg
, NULL
);
4452 static oberon_expr_t
*
4453 oberon_make_odd_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4457 oberon_error(ctx
, "too few arguments");
4462 oberon_error(ctx
, "too mach arguments");
4465 oberon_expr_t
* arg
;
4467 oberon_check_src(ctx
, arg
);
4469 if(!oberon_is_integer_type(arg
-> result
))
4471 oberon_error(ctx
, "expected integer");
4474 oberon_expr_t
* expr
;
4475 expr
= oberon_make_bin_op(ctx
, MOD
, arg
, oberon_make_integer(ctx
, 2));
4476 expr
= oberon_make_bin_op(ctx
, EQUAL
, expr
, oberon_make_integer(ctx
, 1));
4480 static oberon_expr_t
*
4481 oberon_make_cc_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4485 oberon_error(ctx
, "too few arguments");
4490 oberon_error(ctx
, "too mach arguments");
4493 oberon_expr_t
* arg
;
4495 oberon_check_src(ctx
, arg
);
4496 oberon_check_const(ctx
, arg
);
4498 if(!oberon_is_integer_type(arg
-> result
))
4500 oberon_error(ctx
, "expected integer");
4503 /* n >= 0 && n <= 15 */
4505 oberon_expr_t
* cond1
;
4506 oberon_expr_t
* cond2
;
4507 cond1
= oberon_make_bin_op(ctx
, GEQ
, arg
, oberon_make_integer(ctx
, 0));
4508 cond2
= oberon_make_bin_op(ctx
, LEQ
, arg
, oberon_make_integer(ctx
, 15));
4509 return oberon_make_bin_op(ctx
, AND
, cond1
, cond2
);
4512 static oberon_expr_t
*
4513 oberon_make_short_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4517 oberon_error(ctx
, "too few arguments");
4522 oberon_error(ctx
, "too mach arguments");
4525 oberon_expr_t
* arg
;
4527 oberon_check_src(ctx
, arg
);
4529 if(arg
-> result
-> shorter
== NULL
)
4531 oberon_error(ctx
, "already shorter");
4534 oberon_expr_t
* expr
;
4535 expr
= oberon_cast_expr(ctx
, arg
, arg
-> result
-> shorter
);
4539 static oberon_expr_t
*
4540 oberon_make_long_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4544 oberon_error(ctx
, "too few arguments");
4549 oberon_error(ctx
, "too mach arguments");
4552 oberon_expr_t
* arg
;
4554 oberon_check_src(ctx
, arg
);
4556 if(arg
-> result
-> longer
== NULL
)
4558 oberon_error(ctx
, "already longer");
4561 oberon_expr_t
* expr
;
4562 expr
= oberon_cast_expr(ctx
, arg
, arg
-> result
-> longer
);
4566 static oberon_expr_t
*
4567 oberon_make_val_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4571 oberon_error(ctx
, "too few arguments");
4576 oberon_error(ctx
, "too mach arguments");
4579 oberon_expr_t
* typ
;
4581 if(!oberon_is_type_expr(typ
))
4583 oberon_error(ctx
, "requires type");
4586 oberon_expr_t
* arg
;
4587 arg
= list_args
-> next
;
4588 oberon_check_src(ctx
, arg
);
4590 oberon_expr_t
* expr
;
4591 expr
= oberon_hard_cast_expr(ctx
, arg
, typ
-> result
);
4595 static oberon_expr_t
*
4596 oberon_make_len_call(oberon_context_t
* ctx
, int num_args
, oberon_expr_t
* list_args
)
4600 oberon_error(ctx
, "too few arguments");
4605 oberon_error(ctx
, "too mach arguments");
4610 oberon_check_src(ctx
, v
);
4612 if(!oberon_is_array_type(v
-> result
))
4614 oberon_error(ctx
, "expected array");
4620 oberon_expr_t
* num
;
4621 num
= list_args
-> next
;
4622 oberon_check_src(ctx
, num
);
4624 if(!oberon_is_integer_type(num
-> result
))
4626 oberon_error(ctx
, "expected integer");
4628 oberon_check_const(ctx
, num
);
4630 n
= num
-> item
.integer
;
4634 oberon_type_t
* arr
= v
-> result
;
4635 while(arr
-> class == OBERON_TYPE_ARRAY
)
4641 if(n
< 0 || n
> dim
)
4643 oberon_error(ctx
, "not in range 0..%i", dim
- 1);
4646 assert(v
-> is_item
);
4648 oberon_expr_t
* expr
;
4649 expr
= oberon_new_item(MODE_LEN
, ctx
-> int_type
, true);
4650 expr
-> item
.parent
= (oberon_item_t
*) v
;
4651 expr
-> item
.integer
= n
;
4656 oberon_new_const(oberon_context_t
* ctx
, char * name
, oberon_expr_t
* expr
)
4658 oberon_object_t
* constant
;
4659 constant
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_CONST
, true, false, false);
4660 oberon_check_const(ctx
, expr
);
4661 constant
-> value
= (oberon_item_t
*) expr
;
4665 register_default_types(oberon_context_t
* ctx
)
4667 ctx
-> notype_type
= oberon_new_type_ptr(OBERON_TYPE_NOTYPE
);
4668 oberon_generator_init_type(ctx
, ctx
-> notype_type
);
4670 ctx
-> nil_type
= oberon_new_type_ptr(OBERON_TYPE_NIL
);
4671 oberon_generator_init_type(ctx
, ctx
-> nil_type
);
4673 ctx
-> string_type
= oberon_new_type_string(1);
4674 oberon_generator_init_type(ctx
, ctx
-> string_type
);
4676 ctx
-> bool_type
= oberon_new_type_boolean();
4677 oberon_generator_init_type(ctx
, ctx
-> bool_type
);
4679 ctx
-> char_type
= oberon_new_type_char(1);
4680 oberon_generator_init_type(ctx
, ctx
-> char_type
);
4682 ctx
-> byte_type
= oberon_new_type_integer(1);
4683 oberon_generator_init_type(ctx
, ctx
-> byte_type
);
4685 ctx
-> shortint_type
= oberon_new_type_integer(2);
4686 oberon_generator_init_type(ctx
, ctx
-> shortint_type
);
4688 ctx
-> int_type
= oberon_new_type_integer(4);
4689 oberon_generator_init_type(ctx
, ctx
-> int_type
);
4691 ctx
-> longint_type
= oberon_new_type_integer(8);
4692 oberon_generator_init_type(ctx
, ctx
-> longint_type
);
4694 ctx
-> real_type
= oberon_new_type_real(4);
4695 oberon_generator_init_type(ctx
, ctx
-> real_type
);
4697 ctx
-> longreal_type
= oberon_new_type_real(8);
4698 oberon_generator_init_type(ctx
, ctx
-> longreal_type
);
4700 ctx
-> set_type
= oberon_new_type_set(4);
4701 oberon_generator_init_type(ctx
, ctx
-> set_type
);
4703 ctx
-> system_byte_type
= oberon_new_type_ptr(OBERON_TYPE_SYSTEM_BYTE
);
4704 oberon_generator_init_type(ctx
, ctx
-> system_byte_type
);
4706 ctx
-> system_ptr_type
= oberon_new_type_ptr(OBERON_TYPE_SYSTEM_PTR
);
4707 oberon_generator_init_type(ctx
, ctx
-> system_ptr_type
);
4709 /* LONG / SHORT support */
4710 ctx
-> byte_type
-> shorter
= NULL
;
4711 ctx
-> byte_type
-> longer
= ctx
-> shortint_type
;
4713 ctx
-> shortint_type
-> shorter
= ctx
-> byte_type
;
4714 ctx
-> shortint_type
-> longer
= ctx
-> int_type
;
4716 ctx
-> int_type
-> shorter
= ctx
-> shortint_type
;
4717 ctx
-> int_type
-> longer
= ctx
-> longint_type
;
4719 ctx
-> longint_type
-> shorter
= ctx
-> int_type
;
4720 ctx
-> longint_type
-> longer
= NULL
;
4722 ctx
-> real_type
-> shorter
= NULL
;
4723 ctx
-> real_type
-> longer
= ctx
-> longreal_type
;
4725 ctx
-> longreal_type
-> shorter
= ctx
-> real_type
;
4726 ctx
-> longreal_type
-> longer
= NULL
;
4730 oberon_new_intrinsic(oberon_context_t
* ctx
, char * name
, GenerateFuncCallback f
, GenerateProcCallback p
)
4732 oberon_object_t
* proc
;
4733 proc
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_PROC
, true, false, false);
4734 proc
-> type
= oberon_new_type_ptr(OBERON_TYPE_PROCEDURE
);
4735 proc
-> type
-> sysproc
= true;
4736 proc
-> type
-> genfunc
= f
;
4737 proc
-> type
-> genproc
= p
;
4740 static void oberon_new_intrinsic_type(oberon_context_t
* ctx
, char * name
, oberon_type_t
* type
)
4742 oberon_object_t
* id
;
4743 id
= oberon_define_object(ctx
-> decl
, name
, OBERON_CLASS_TYPE
, true, false, false);
4748 oberon_begin_intrinsic_module(oberon_context_t
* ctx
, char * name
, oberon_module_t
** m
)
4750 oberon_scope_t
* module_scope
;
4751 module_scope
= oberon_open_scope(ctx
);
4753 oberon_module_t
* module
;
4754 module
= GC_MALLOC(sizeof *module
);
4755 memset(module
, 0, sizeof *module
);
4756 module
-> name
= name
;
4757 module
-> intrinsic
= true;
4758 module
-> decl
= module_scope
;
4759 module
-> next
= ctx
-> module_list
;
4761 ctx
-> mod
= module
;
4762 ctx
-> module_list
= module
;
4768 oberon_end_intrinsic_module(oberon_context_t
* ctx
, oberon_module_t
* m
)
4770 oberon_close_scope(m
-> decl
);
4776 oberon_create_context(ModuleImportCallback import_module
)
4778 oberon_context_t
* ctx
= GC_MALLOC(sizeof *ctx
);
4779 memset(ctx
, 0, sizeof *ctx
);
4781 oberon_scope_t
* world_scope
;
4782 world_scope
= oberon_open_scope(ctx
);
4783 ctx
-> world_scope
= world_scope
;
4785 ctx
-> import_module
= import_module
;
4787 oberon_generator_init_context(ctx
);
4790 register_default_types(ctx
);
4793 oberon_new_const(ctx
, "TRUE", oberon_make_boolean(ctx
, true));
4794 oberon_new_const(ctx
, "FALSE", oberon_make_boolean(ctx
, false));
4797 oberon_new_intrinsic_type(ctx
, "BOOLEAN", ctx
-> bool_type
);
4798 oberon_new_intrinsic_type(ctx
, "CHAR", ctx
-> char_type
);
4799 oberon_new_intrinsic_type(ctx
, "SHORTINT", ctx
-> byte_type
);
4800 oberon_new_intrinsic_type(ctx
, "INTEGER", ctx
-> shortint_type
);
4801 oberon_new_intrinsic_type(ctx
, "LONGINT", ctx
-> int_type
);
4802 oberon_new_intrinsic_type(ctx
, "HUGEINT", ctx
-> longint_type
);
4803 oberon_new_intrinsic_type(ctx
, "REAL", ctx
-> real_type
);
4804 oberon_new_intrinsic_type(ctx
, "LONGREAL", ctx
-> longreal_type
);
4805 oberon_new_intrinsic_type(ctx
, "SET", ctx
-> set_type
);
4808 oberon_new_intrinsic(ctx
, "ABS", oberon_make_abs_call
, NULL
);
4809 oberon_new_intrinsic(ctx
, "ASH", oberon_make_ash_call
, NULL
);
4810 oberon_new_intrinsic(ctx
, "CAP", oberon_make_cap_call
, NULL
);
4811 oberon_new_intrinsic(ctx
, "CHR", oberon_make_chr_call
, NULL
);
4812 oberon_new_intrinsic(ctx
, "ENTIER", oberon_make_entier_call
, NULL
);
4813 oberon_new_intrinsic(ctx
, "LEN", oberon_make_len_call
, NULL
);
4814 oberon_new_intrinsic(ctx
, "LONG", oberon_make_long_call
, NULL
);
4815 oberon_new_intrinsic(ctx
, "MAX", oberon_make_max_call
, NULL
);
4816 oberon_new_intrinsic(ctx
, "MIN", oberon_make_min_call
, NULL
);
4817 oberon_new_intrinsic(ctx
, "ODD", oberon_make_odd_call
, NULL
);
4818 oberon_new_intrinsic(ctx
, "ORD", oberon_make_ord_call
, NULL
);
4819 oberon_new_intrinsic(ctx
, "SHORT", oberon_make_short_call
, NULL
);
4820 oberon_new_intrinsic(ctx
, "SIZE", oberon_make_size_call
, NULL
);
4823 oberon_new_intrinsic(ctx
, "ASSERT", NULL
, oberon_make_assert_call
);
4824 oberon_new_intrinsic(ctx
, "COPY", NULL
, oberon_make_copy_call
);
4825 oberon_new_intrinsic(ctx
, "DEC", NULL
, oberon_make_dec_call
);
4826 oberon_new_intrinsic(ctx
, "EXCL", NULL
, oberon_make_excl_call
);
4827 oberon_new_intrinsic(ctx
, "HALT", NULL
, oberon_make_halt_call
);
4828 oberon_new_intrinsic(ctx
, "INC", NULL
, oberon_make_inc_call
);
4829 oberon_new_intrinsic(ctx
, "INCL", NULL
, oberon_make_incl_call
);
4830 oberon_new_intrinsic(ctx
, "NEW", NULL
, oberon_make_new_call
);
4833 oberon_begin_intrinsic_module(ctx
, "SYSTEM", &ctx
-> system_module
);
4836 oberon_new_intrinsic_type(ctx
, "BYTE", ctx
-> system_byte_type
);
4837 oberon_new_intrinsic_type(ctx
, "PTR", ctx
-> system_ptr_type
);
4840 oberon_new_intrinsic(ctx
, "CC", oberon_make_cc_call
, NULL
);
4841 oberon_new_intrinsic(ctx
, "LSH", oberon_make_lsh_call
, NULL
);
4842 oberon_new_intrinsic(ctx
, "ROT", oberon_make_rot_call
, NULL
);
4843 oberon_new_intrinsic(ctx
, "VAL", oberon_make_val_call
, NULL
);
4845 oberon_end_intrinsic_module(ctx
, ctx
-> system_module
);
4851 oberon_destroy_context(oberon_context_t
* ctx
)
4853 oberon_generator_destroy_context(ctx
);
4857 oberon_compile_module(oberon_context_t
* ctx
, const char * newcode
)
4859 const char * code
= ctx
-> code
;
4860 int code_index
= ctx
-> code_index
;
4862 int token
= ctx
-> token
;
4863 char * string
= ctx
-> string
;
4864 int integer
= ctx
-> integer
;
4865 int real
= ctx
-> real
;
4866 bool longmode
= ctx
-> longmode
;
4867 oberon_scope_t
* decl
= ctx
-> decl
;
4868 oberon_module_t
* mod
= ctx
-> mod
;
4870 oberon_scope_t
* module_scope
;
4871 module_scope
= oberon_open_scope(ctx
);
4873 oberon_module_t
* module
;
4874 module
= GC_MALLOC(sizeof *module
);
4875 memset(module
, 0, sizeof *module
);
4876 module
-> decl
= module_scope
;
4877 module
-> next
= ctx
-> module_list
;
4879 ctx
-> mod
= module
;
4880 ctx
-> module_list
= module
;
4882 oberon_init_scaner(ctx
, newcode
);
4883 oberon_parse_module(ctx
);
4885 module
-> ready
= 1;
4888 ctx
-> code_index
= code_index
;
4890 ctx
-> token
= token
;
4891 ctx
-> string
= string
;
4892 ctx
-> integer
= integer
;
4894 ctx
-> longmode
= longmode
;