]>
Commit | Line | Data |
---|---|---|
3c79b2da | 1 | /* Build expressions with type checking for CHILL compiler. |
fed3cef0 RK |
2 | Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000 |
3 | Free Software Foundation, Inc. | |
3c79b2da PB |
4 | |
5 | This file is part of GNU CC. | |
6 | ||
7 | GNU CC is free software; you can redistribute it and/or modify | |
8 | it under the terms of the GNU General Public License as published by | |
9 | the Free Software Foundation; either version 2, or (at your option) | |
10 | any later version. | |
11 | ||
12 | GNU CC is distributed in the hope that it will be useful, | |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | GNU General Public License for more details. | |
16 | ||
17 | You should have received a copy of the GNU General Public License | |
18 | along with GNU CC; see the file COPYING. If not, write to | |
6f48294d JL |
19 | the Free Software Foundation, 59 Temple Place - Suite 330, |
20 | Boston, MA 02111-1307, USA. */ | |
3c79b2da PB |
21 | |
22 | ||
23 | /* This file is part of the CHILL front end. | |
24 | It contains routines to build C expressions given their operands, | |
25 | including computing the modes of the result, C-specific error checks, | |
26 | and some optimization. | |
27 | ||
28 | There are also routines to build RETURN_STMT nodes and CASE_STMT nodes, | |
29 | and to process initializations in declarations (since they work | |
30 | like a strange sort of assignment). */ | |
31 | ||
32 | #include "config.h" | |
75111422 | 33 | #include "system.h" |
3c79b2da PB |
34 | #include "tree.h" |
35 | #include "ch-tree.h" | |
36 | #include "flags.h" | |
37 | #include "rtl.h" | |
38 | #include "expr.h" | |
39 | #include "lex.h" | |
75111422 | 40 | #include "toplev.h" |
64b6368a | 41 | #include "output.h" |
3c79b2da | 42 | |
3c79b2da | 43 | /* forward declarations */ |
3b0d91ff KG |
44 | static int chill_l_equivalent PARAMS ((tree, tree, struct mode_chain*)); |
45 | static tree extract_constant_from_buffer PARAMS ((tree, const unsigned char *, int)); | |
46 | static int expand_constant_to_buffer PARAMS ((tree, unsigned char *, int)); | |
47 | static tree build_empty_string PARAMS ((tree)); | |
48 | static tree make_chill_pointer_type PARAMS ((tree, enum tree_code)); | |
665f2503 | 49 | static unsigned int min_precision PARAMS ((tree, int)); |
3b0d91ff KG |
50 | static tree make_chill_range_type PARAMS ((tree, tree, tree)); |
51 | static void apply_chill_array_layout PARAMS ((tree)); | |
52 | static int field_decl_cmp PARAMS ((tree *, tree*)); | |
53 | static tree make_chill_struct_type PARAMS ((tree)); | |
54 | static int apply_chill_field_layout PARAMS ((tree, int *)); | |
3c79b2da PB |
55 | \f |
56 | /* | |
57 | * This function checks an array access. | |
58 | * It calls error (ERROR_MESSAGE) if the condition (index <= domain max value | |
59 | * index >= domain min value) | |
60 | * is not met at compile time, | |
61 | * If a runtime test is required and permitted, | |
62 | * check_expression is used to do so. | |
63 | * the global RANGE_CHECKING flags controls the | |
64 | * generation of runtime checking code. | |
65 | */ | |
66 | tree | |
67 | valid_array_index_p (array, idx, error_message, is_varying_lhs) | |
68 | tree array, idx; | |
31029ad7 | 69 | const char *error_message; |
3c79b2da PB |
70 | int is_varying_lhs; |
71 | { | |
72 | tree cond, low_limit, high_cond, atype, domain; | |
73 | tree orig_index = idx; | |
74 | enum chill_tree_code condition; | |
75 | ||
76 | if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK | |
77 | || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK) | |
78 | return error_mark_node; | |
79 | ||
80 | if (TREE_CODE (idx) == TYPE_DECL | |
81 | || TREE_CODE_CLASS (TREE_CODE (idx)) == 't') | |
82 | { | |
83 | error ("array or string index is a mode (instead of a value)"); | |
84 | return error_mark_node; | |
85 | } | |
86 | ||
87 | atype = TREE_TYPE (array); | |
88 | ||
89 | if (chill_varying_type_p (atype)) | |
90 | { | |
91 | domain = TYPE_DOMAIN (CH_VARYING_ARRAY_TYPE (atype)); | |
92 | high_cond = build_component_ref (array, var_length_id); | |
93 | if (chill_varying_string_type_p (atype)) | |
94 | { | |
95 | if (is_varying_lhs) | |
96 | condition = GT_EXPR; | |
97 | else | |
98 | condition = GE_EXPR; | |
99 | } | |
100 | else | |
101 | condition = GT_EXPR; | |
102 | } | |
103 | else | |
104 | { | |
105 | domain = TYPE_DOMAIN (atype); | |
106 | high_cond = TYPE_MAX_VALUE (domain); | |
107 | condition = GT_EXPR; | |
108 | } | |
109 | ||
110 | if (CH_STRING_TYPE_P (atype)) | |
111 | { | |
112 | if (! CH_SIMILAR (TREE_TYPE (orig_index), integer_type_node)) | |
113 | { | |
114 | error ("index is not an integer expression"); | |
115 | return error_mark_node; | |
116 | } | |
117 | } | |
118 | else | |
119 | { | |
120 | if (! CH_COMPATIBLE (orig_index, domain)) | |
121 | { | |
122 | error ("index not compatible with index mode"); | |
123 | return error_mark_node; | |
124 | } | |
125 | } | |
126 | ||
127 | /* Convert BOOLS(1) to BOOL and CHARS(1) to CHAR. */ | |
128 | if (flag_old_strings) | |
129 | { | |
130 | idx = convert_to_discrete (idx); | |
131 | if (idx == NULL) /* should never happen */ | |
132 | error ("index is not discrete"); | |
133 | } | |
134 | ||
135 | /* we know we'll refer to this value twice */ | |
136 | if (range_checking) | |
137 | idx = save_expr (idx); | |
138 | ||
139 | low_limit = TYPE_MIN_VALUE (domain); | |
140 | high_cond = build_compare_discrete_expr (condition, idx, high_cond); | |
141 | ||
142 | /* an invalid index expression meets this condition */ | |
143 | cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, | |
144 | build_compare_discrete_expr (LT_EXPR, idx, low_limit), | |
145 | high_cond)); | |
146 | ||
147 | /* strip a redundant NOP_EXPR */ | |
148 | if (TREE_CODE (cond) == NOP_EXPR | |
149 | && TREE_TYPE (cond) == boolean_type_node | |
150 | && TREE_CODE (TREE_OPERAND (cond, 0)) == INTEGER_CST) | |
151 | cond = TREE_OPERAND (cond, 0); | |
152 | ||
153 | idx = convert (CH_STRING_TYPE_P (atype) ? integer_type_node : domain, | |
154 | idx); | |
155 | ||
156 | if (TREE_CODE (cond) == INTEGER_CST) | |
157 | { | |
158 | if (tree_int_cst_equal (cond, boolean_false_node)) | |
159 | return idx; /* condition met at compile time */ | |
a3dd1d43 | 160 | error ("%s", error_message); /* condition failed at compile time */ |
3c79b2da PB |
161 | return error_mark_node; |
162 | } | |
163 | else if (range_checking) | |
164 | { | |
165 | /* FIXME: often, several of these conditions will | |
166 | be generated for the same source file and line number. | |
167 | A great optimization would be to share the | |
168 | cause_exception function call among them rather | |
169 | than generating a cause_exception call for each. */ | |
170 | return check_expression (idx, cond, | |
171 | ridpointers[(int) RID_RANGEFAIL]); | |
172 | } | |
173 | else | |
174 | return idx; /* don't know at compile time */ | |
175 | } | |
176 | \f | |
177 | /* | |
178 | * Extract a slice from an array, which could look like a | |
179 | * SET_TYPE if it's a bitstring. The array could also be VARYING | |
180 | * if the element type is CHAR. The min_value and length values | |
181 | * must have already been checked with valid_array_index_p. No | |
182 | * checking is done here. | |
183 | */ | |
184 | tree | |
185 | build_chill_slice (array, min_value, length) | |
186 | tree array, min_value, length; | |
187 | { | |
188 | tree result; | |
189 | tree array_type = TREE_TYPE (array); | |
190 | ||
191 | if (!CH_REFERABLE (array) && TREE_CODE (array) != SAVE_EXPR | |
192 | && (TREE_CODE (array) != COMPONENT_REF | |
193 | || TREE_CODE (TREE_OPERAND (array, 0)) != SAVE_EXPR)) | |
194 | { | |
195 | if (!TREE_CONSTANT (array)) | |
196 | warning ("possible internal error - slice argument is neither referable nor constant"); | |
197 | else | |
198 | { | |
199 | /* Force to storage. | |
200 | NOTE: This could mean multiple identical copies of | |
201 | the same constant. FIXME. */ | |
202 | tree mydecl = decl_temp1 (get_unique_identifier("SLICEE"), | |
203 | array_type, 1, array, 0, 0); | |
204 | TREE_READONLY (mydecl) = 1; | |
205 | /* mark_addressable (mydecl); FIXME: necessary? */ | |
206 | array = mydecl; | |
207 | } | |
208 | } | |
209 | ||
210 | /* | |
211 | The code-generation which uses a slice tree needs not only to | |
212 | know the dynamic upper and lower limits of that slice, but the | |
213 | original static allocation, to use to build temps where one or both | |
214 | of the dynamic limits must be calculated at runtime.. We pass the | |
215 | dynamic size by building a new array_type whose limits are the | |
216 | min_value and min_value + length values passed to us. | |
217 | ||
218 | The static allocation info is passed by using the parent array's | |
219 | limits to compute a temp_size, which is passed in the lang_specific | |
fed3cef0 | 220 | field of the slice_type. */ |
3c79b2da PB |
221 | |
222 | if (TREE_CODE (array_type) == ARRAY_TYPE) | |
223 | { | |
224 | tree domain_type = TYPE_DOMAIN (array_type); | |
20aa9a35 | 225 | tree domain_min = TYPE_MIN_VALUE (domain_type); |
fed3cef0 RK |
226 | tree domain_max |
227 | = fold (build (PLUS_EXPR, domain_type, | |
228 | domain_min, | |
229 | fold (build (MINUS_EXPR, integer_type_node, | |
230 | length, integer_one_node)))); | |
20aa9a35 | 231 | tree index_type = build_chill_range_type (TYPE_DOMAIN (array_type), |
3c79b2da PB |
232 | domain_min, |
233 | domain_max); | |
234 | ||
235 | tree element_type = TREE_TYPE (array_type); | |
236 | tree slice_type = build_simple_array_type (element_type, index_type, NULL_TREE); | |
237 | tree slice_pointer_type; | |
3c79b2da PB |
238 | tree max_size; |
239 | ||
240 | if (CH_CHARS_TYPE_P (array_type)) | |
241 | MARK_AS_STRING_TYPE (slice_type); | |
242 | else | |
243 | TYPE_PACKED (slice_type) = TYPE_PACKED (array_type); | |
244 | ||
245 | SET_CH_NOVELTY (slice_type, CH_NOVELTY (array_type)); | |
246 | ||
665f2503 RK |
247 | if (TREE_CONSTANT (array) && host_integerp (min_value, 0) |
248 | && host_integerp (length, 0)) | |
3c79b2da | 249 | { |
665f2503 RK |
250 | unsigned HOST_WIDE_INT type_size = int_size_in_bytes (array_type); |
251 | unsigned char *buffer = (unsigned char *) alloca (type_size); | |
252 | int delta = (int_size_in_bytes (element_type) | |
253 | * (tree_low_cst (min_value, 0) | |
254 | - tree_low_cst (domain_min, 0))); | |
255 | ||
3c79b2da PB |
256 | bzero (buffer, type_size); |
257 | if (expand_constant_to_buffer (array, buffer, type_size)) | |
258 | { | |
259 | result = extract_constant_from_buffer (slice_type, | |
260 | buffer + delta, | |
261 | type_size - delta); | |
262 | if (result) | |
263 | return result; | |
264 | } | |
265 | } | |
266 | ||
267 | /* Kludge used by case CONCAT_EXPR in chill_expand_expr. | |
268 | Set TYPE_ARRAY_MAX_SIZE to a constant upper bound on the | |
269 | bytes needed. */ | |
270 | max_size = size_in_bytes (slice_type); | |
271 | if (TREE_CODE (max_size) != INTEGER_CST) | |
272 | { | |
273 | max_size = TYPE_ARRAY_MAX_SIZE (array_type); | |
274 | if (max_size == NULL_TREE) | |
275 | max_size = size_in_bytes (array_type); | |
276 | } | |
277 | TYPE_ARRAY_MAX_SIZE (slice_type) = max_size; | |
278 | ||
279 | mark_addressable (array); | |
280 | /* Contruct a SLICE_EXPR to represent a slice of a packed array of bits. */ | |
281 | if (TYPE_PACKED (array_type)) | |
282 | { | |
283 | if (pass == 2 && TREE_CODE (length) != INTEGER_CST) | |
284 | { | |
285 | sorry ("bit array slice with non-constant length"); | |
286 | return error_mark_node; | |
287 | } | |
288 | if (domain_min && ! integer_zerop (domain_min)) | |
289 | min_value = size_binop (MINUS_EXPR, min_value, | |
290 | convert (sizetype, domain_min)); | |
291 | result = build (SLICE_EXPR, slice_type, array, min_value, length); | |
292 | TREE_READONLY (result) | |
293 | = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type)); | |
294 | return result; | |
295 | } | |
296 | ||
297 | slice_pointer_type = build_chill_pointer_type (slice_type); | |
298 | if (TREE_CODE (min_value) == INTEGER_CST | |
299 | && domain_min && TREE_CODE (domain_min) == INTEGER_CST | |
300 | && compare_int_csts (EQ_EXPR, min_value, domain_min)) | |
301 | result = fold (build1 (ADDR_EXPR, slice_pointer_type, array)); | |
302 | else | |
303 | { | |
304 | min_value = convert (sizetype, min_value); | |
305 | if (domain_min && ! integer_zerop (domain_min)) | |
306 | min_value = size_binop (MINUS_EXPR, min_value, | |
307 | convert (sizetype, domain_min)); | |
308 | min_value = size_binop (MULT_EXPR, min_value, | |
309 | size_in_bytes (element_type)); | |
310 | result = fold (build (PLUS_EXPR, slice_pointer_type, | |
311 | build1 (ADDR_EXPR, slice_pointer_type, | |
312 | array), | |
313 | convert (slice_pointer_type, min_value))); | |
314 | } | |
315 | /* Return the final array value. */ | |
316 | result = fold (build1 (INDIRECT_REF, slice_type, result)); | |
317 | TREE_READONLY (result) | |
318 | = TREE_READONLY (array) | TYPE_READONLY (element_type); | |
319 | return result; | |
320 | } | |
321 | else if (TREE_CODE (array_type) == SET_TYPE) /* actually a bitstring */ | |
322 | { | |
323 | if (pass == 2 && TREE_CODE (length) != INTEGER_CST) | |
324 | { | |
325 | sorry ("bitstring slice with non-constant length"); | |
326 | return error_mark_node; | |
327 | } | |
328 | result = build (SLICE_EXPR, build_bitstring_type (length), | |
329 | array, min_value, length); | |
330 | TREE_READONLY (result) | |
331 | = TREE_READONLY (array) | TYPE_READONLY (TREE_TYPE (array_type)); | |
332 | return result; | |
333 | } | |
334 | else if (chill_varying_type_p (array_type)) | |
335 | return build_chill_slice (varying_to_slice (array), min_value, length); | |
336 | else | |
337 | { | |
338 | error ("slice operation on non-array, non-bitstring value not supported"); | |
339 | return error_mark_node; | |
340 | } | |
341 | } | |
342 | \f | |
343 | static tree | |
344 | build_empty_string (type) | |
345 | tree type; | |
346 | { | |
347 | int orig_pass = pass; | |
348 | tree range, result; | |
349 | ||
350 | range = build_chill_range_type (type, integer_zero_node, | |
351 | integer_minus_one_node); | |
352 | result = build_chill_array_type (type, | |
353 | tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE); | |
354 | pass = 2; | |
355 | range = build_chill_range_type (type, integer_zero_node, | |
356 | integer_minus_one_node); | |
357 | result = build_chill_array_type (type, | |
358 | tree_cons (NULL_TREE, range, NULL_TREE), 0, NULL_TREE); | |
359 | pass = orig_pass; | |
360 | ||
361 | return decl_temp1 (get_unique_identifier ("EMPTY_STRING"), | |
362 | result, 0, NULL_TREE, 0, 0); | |
363 | } | |
364 | \f | |
365 | /* We build the runtime range-checking as a separate list | |
366 | * rather than making a compound_expr with min_value | |
367 | * (for example), to control when that comparison gets | |
368 | * generated. We cannot allow it in a TYPE_MAX_VALUE or | |
369 | * TYPE_MIN_VALUE expression, for instance, because that code | |
370 | * will get generated when the slice is laid out, which would | |
371 | * put it outside the scope of an exception handler for the | |
372 | * statement we're generating. I.e. we would be generating | |
373 | * cause_exception calls which might execute before the | |
374 | * necessary ch_link_handler call. | |
375 | */ | |
376 | tree | |
377 | build_chill_slice_with_range (array, min_value, max_value) | |
378 | tree array, min_value, max_value; | |
379 | { | |
380 | if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK | |
381 | || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK | |
382 | || max_value == NULL_TREE || TREE_CODE(max_value) == ERROR_MARK) | |
383 | return error_mark_node; | |
384 | ||
385 | if (TREE_TYPE (array) == NULL_TREE | |
386 | || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE | |
387 | && TREE_CODE (TREE_TYPE (array)) != SET_TYPE | |
388 | && !chill_varying_type_p (TREE_TYPE (array)))) | |
389 | { | |
390 | error ("can only take slice of array or string"); | |
391 | return error_mark_node; | |
392 | } | |
393 | ||
394 | array = save_if_needed (array); | |
395 | ||
396 | /* FIXME: test here for max_value >= min_value, except | |
397 | for max_value == -1, min_value == 0 (empty string) */ | |
398 | min_value = valid_array_index_p (array, min_value, | |
399 | "slice lower limit out-of-range", 0); | |
400 | if (TREE_CODE (min_value) == ERROR_MARK) | |
401 | return min_value; | |
402 | ||
403 | /* FIXME: suppress this test if max_value is the LENGTH of a | |
404 | varying array, which has presumably already been checked. */ | |
405 | max_value = valid_array_index_p (array, max_value, | |
406 | "slice upper limit out-of-range", 0); | |
407 | if (TREE_CODE (max_value) == ERROR_MARK) | |
408 | return error_mark_node; | |
409 | ||
410 | if (TREE_CODE (min_value) == INTEGER_CST | |
411 | && TREE_CODE (max_value) == INTEGER_CST | |
412 | && tree_int_cst_lt (max_value, min_value)) | |
413 | return build_empty_string (TREE_TYPE (TREE_TYPE (array))); | |
414 | ||
fed3cef0 RK |
415 | return |
416 | build_chill_slice | |
417 | (array, min_value, | |
418 | save_expr (fold (build (PLUS_EXPR, integer_type_node, | |
419 | fold (build (MINUS_EXPR, integer_type_node, | |
420 | max_value, min_value)), | |
421 | integer_one_node)))); | |
3c79b2da PB |
422 | } |
423 | ||
3c79b2da PB |
424 | tree |
425 | build_chill_slice_with_length (array, min_value, length) | |
426 | tree array, min_value, length; | |
427 | { | |
428 | tree max_index; | |
429 | tree cond, high_cond, atype; | |
430 | ||
431 | if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK | |
432 | || min_value == NULL_TREE || TREE_CODE(min_value) == ERROR_MARK | |
433 | || length == NULL_TREE || TREE_CODE(length) == ERROR_MARK) | |
434 | return error_mark_node; | |
435 | ||
436 | if (TREE_TYPE (array) == NULL_TREE | |
437 | || (TREE_CODE (TREE_TYPE (array)) != ARRAY_TYPE | |
438 | && TREE_CODE (TREE_TYPE (array)) != SET_TYPE | |
439 | && !chill_varying_type_p (TREE_TYPE (array)))) | |
440 | { | |
441 | error ("can only take slice of array or string"); | |
442 | return error_mark_node; | |
443 | } | |
444 | ||
445 | if (TREE_CONSTANT (length) | |
446 | && tree_int_cst_lt (length, integer_zero_node)) | |
447 | return build_empty_string (TREE_TYPE (TREE_TYPE (array))); | |
448 | ||
449 | array = save_if_needed (array); | |
450 | min_value = save_expr (min_value); | |
451 | length = save_expr (length); | |
452 | ||
453 | if (! CH_SIMILAR (TREE_TYPE (length), integer_type_node)) | |
454 | { | |
455 | error ("slice length is not an integer"); | |
456 | length = integer_one_node; | |
457 | } | |
458 | ||
fed3cef0 RK |
459 | max_index = fold (build (MINUS_EXPR, integer_type_node, |
460 | fold (build (PLUS_EXPR, integer_type_node, | |
461 | length, min_value)), | |
462 | integer_one_node)); | |
3c79b2da PB |
463 | max_index = convert_to_class (chill_expr_class (min_value), max_index); |
464 | ||
465 | min_value = valid_array_index_p (array, min_value, | |
466 | "slice start index out-of-range", 0); | |
467 | if (TREE_CODE (min_value) == ERROR_MARK) | |
468 | return error_mark_node; | |
469 | ||
470 | atype = TREE_TYPE (array); | |
471 | ||
472 | if (chill_varying_type_p (atype)) | |
473 | high_cond = build_component_ref (array, var_length_id); | |
474 | else | |
475 | high_cond = TYPE_MAX_VALUE (TYPE_DOMAIN (atype)); | |
476 | ||
477 | /* an invalid index expression meets this condition */ | |
478 | cond = fold (build (TRUTH_ORIF_EXPR, boolean_type_node, | |
479 | build_compare_discrete_expr (LT_EXPR, | |
480 | length, integer_zero_node), | |
481 | build_compare_discrete_expr (GT_EXPR, | |
482 | max_index, high_cond))); | |
483 | ||
484 | if (TREE_CODE (cond) == INTEGER_CST) | |
485 | { | |
486 | if (! tree_int_cst_equal (cond, boolean_false_node)) | |
487 | { | |
488 | error ("slice length out-of-range"); | |
489 | return error_mark_node; | |
490 | } | |
491 | ||
492 | } | |
493 | else if (range_checking) | |
494 | { | |
495 | min_value = check_expression (min_value, cond, | |
496 | ridpointers[(int) RID_RANGEFAIL]); | |
497 | } | |
498 | ||
499 | return build_chill_slice (array, min_value, length); | |
500 | } | |
501 | \f | |
502 | tree | |
503 | build_chill_array_ref (array, indexlist) | |
504 | tree array, indexlist; | |
505 | { | |
506 | tree idx; | |
507 | ||
508 | if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK) | |
509 | return error_mark_node; | |
510 | if (indexlist == NULL_TREE || TREE_CODE (indexlist) == ERROR_MARK) | |
511 | return error_mark_node; | |
512 | ||
513 | idx = TREE_VALUE (indexlist); /* handle first index */ | |
514 | ||
515 | idx = valid_array_index_p (array, idx, | |
516 | "array index out-of-range", 0); | |
517 | if (TREE_CODE (idx) == ERROR_MARK) | |
518 | return error_mark_node; | |
519 | ||
520 | array = build_chill_array_ref_1 (array, idx); | |
521 | ||
522 | if (array && TREE_CODE (array) != ERROR_MARK | |
523 | && TREE_CHAIN (indexlist)) | |
524 | { | |
525 | /* Z.200 (1988) section 4.2.8 says that: | |
526 | <array> '(' <expression {',' <expression> }* ')' | |
527 | is derived syntax (i.e. syntactic sugar) for: | |
528 | <array> '(' <expression ')' { '(' <expression> ')' }* | |
529 | The intent is clear if <array> has mode: ARRAY (...) ARRAY (...) XXX. | |
530 | But what if <array> has mode: ARRAY (...) CHARS (N) | |
531 | or: ARRAY (...) BOOLS (N). | |
532 | Z.200 doesn't explicitly prohibit it, but the intent is unclear. | |
533 | We'll allow it, since it seems reasonable and useful. | |
534 | However, we won't allow it if <array> is: | |
535 | ARRAY (...) PROC (...). | |
536 | (The latter would make sense if we allowed general | |
537 | Currying, which Chill doesn't.) */ | |
538 | if (TREE_CODE (TREE_TYPE (array)) == ARRAY_TYPE | |
539 | || chill_varying_type_p (TREE_TYPE (array)) | |
540 | || CH_BOOLS_TYPE_P (TREE_TYPE (array))) | |
541 | array = build_generalized_call (array, TREE_CHAIN (indexlist)); | |
542 | else | |
543 | error ("too many index expressions"); | |
544 | } | |
545 | return array; | |
546 | } | |
547 | ||
548 | /* | |
549 | * Don't error check the index in here. It's supposed to be | |
550 | * checked by the caller. | |
551 | */ | |
552 | tree | |
553 | build_chill_array_ref_1 (array, idx) | |
554 | tree array, idx; | |
555 | { | |
556 | tree type; | |
557 | tree domain; | |
558 | tree rval; | |
559 | ||
560 | if (array == NULL_TREE || TREE_CODE (array) == ERROR_MARK | |
561 | || idx == NULL_TREE || TREE_CODE (idx) == ERROR_MARK) | |
562 | return error_mark_node; | |
563 | ||
564 | if (chill_varying_type_p (TREE_TYPE (array))) | |
565 | array = varying_to_slice (array); | |
566 | ||
567 | domain = TYPE_DOMAIN (TREE_TYPE (array)); | |
568 | ||
569 | #if 0 | |
570 | if (! integer_zerop (TYPE_MIN_VALUE (domain))) | |
571 | { | |
572 | /* The C part of the compiler doesn't understand how to do | |
573 | arithmetic with dissimilar enum types. So we check compatability | |
574 | here, and perform the math in INTEGER_TYPE. */ | |
575 | if (TREE_CODE (TREE_TYPE (idx)) == ENUMERAL_TYPE | |
576 | && chill_comptypes (TREE_TYPE (idx), domain, 0)) | |
577 | idx = convert (TREE_TYPE (TYPE_MIN_VALUE (domain)), idx); | |
578 | idx = build_binary_op (MINUS_EXPR, idx, TYPE_MIN_VALUE (domain), 0); | |
579 | } | |
580 | #endif | |
581 | ||
582 | if (CH_STRING_TYPE_P (TREE_TYPE (array))) | |
583 | { | |
584 | /* Could be bitstring or char string. */ | |
585 | if (TREE_TYPE (TREE_TYPE (array)) == boolean_type_node) | |
586 | { | |
587 | rval = build (SET_IN_EXPR, boolean_type_node, idx, array); | |
588 | TREE_READONLY (rval) = TREE_READONLY (array); | |
589 | return rval; | |
590 | } | |
591 | } | |
592 | ||
593 | if (!discrete_type_p (TREE_TYPE (idx))) | |
594 | { | |
595 | error ("array index is not discrete"); | |
596 | return error_mark_node; | |
597 | } | |
598 | ||
599 | /* An array that is indexed by a non-constant | |
600 | cannot be stored in a register; we must be able to do | |
601 | address arithmetic on its address. | |
602 | Likewise an array of elements of variable size. */ | |
603 | if (TREE_CODE (idx) != INTEGER_CST | |
604 | || (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))) != 0 | |
605 | && TREE_CODE (TYPE_SIZE (TREE_TYPE (TREE_TYPE (array)))) != INTEGER_CST)) | |
606 | { | |
607 | if (mark_addressable (array) == 0) | |
608 | return error_mark_node; | |
609 | } | |
610 | ||
611 | type = TREE_TYPE (TREE_TYPE (array)); | |
612 | ||
613 | /* Do constant folding */ | |
614 | if (TREE_CODE (idx) == INTEGER_CST && TREE_CONSTANT (array)) | |
615 | { | |
616 | struct ch_class class; | |
617 | class.kind = CH_VALUE_CLASS; | |
618 | class.mode = type; | |
619 | ||
620 | if (TREE_CODE (array) == CONSTRUCTOR) | |
621 | { | |
622 | tree list = CONSTRUCTOR_ELTS (array); | |
623 | for ( ; list != NULL_TREE; list = TREE_CHAIN (list)) | |
624 | { | |
625 | if (tree_int_cst_equal (TREE_PURPOSE (list), idx)) | |
626 | return convert_to_class (class, TREE_VALUE (list)); | |
627 | } | |
628 | } | |
629 | else if (TREE_CODE (array) == STRING_CST | |
630 | && CH_CHARS_TYPE_P (TREE_TYPE (array))) | |
631 | { | |
665f2503 RK |
632 | HOST_WIDE_INT i = tree_low_cst (idx, 0); |
633 | ||
3c79b2da | 634 | if (i >= 0 && i < TREE_STRING_LENGTH (array)) |
665f2503 RK |
635 | return |
636 | convert_to_class | |
637 | (class, | |
638 | build_int_2 | |
639 | ((unsigned char) TREE_STRING_POINTER (array) [i], 0)); | |
3c79b2da PB |
640 | } |
641 | } | |
642 | ||
643 | if (TYPE_PACKED (TREE_TYPE (array))) | |
644 | rval = build (PACKED_ARRAY_REF, type, array, idx); | |
645 | else | |
646 | rval = build (ARRAY_REF, type, array, idx); | |
647 | ||
648 | /* Array ref is const/volatile if the array elements are | |
649 | or if the array is. */ | |
650 | TREE_READONLY (rval) = TREE_READONLY (array) | TYPE_READONLY (type); | |
651 | TREE_SIDE_EFFECTS (rval) | |
652 | |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array))) | |
653 | | TREE_SIDE_EFFECTS (array)); | |
654 | TREE_THIS_VOLATILE (rval) | |
655 | |= (TYPE_VOLATILE (TREE_TYPE (TREE_TYPE (array))) | |
656 | /* This was added by rms on 16 Nov 91. | |
657 | It fixes vol struct foo *a; a->elts[1] | |
658 | in an inline function. | |
659 | Hope it doesn't break something else. */ | |
660 | | TREE_THIS_VOLATILE (array)); | |
661 | return fold (rval); | |
662 | } | |
663 | \f | |
664 | tree | |
665 | build_chill_bitref (bitstring, indexlist) | |
666 | tree bitstring, indexlist; | |
667 | { | |
668 | if (TREE_CODE (bitstring) == ERROR_MARK) | |
669 | return bitstring; | |
670 | if (TREE_CODE (indexlist) == ERROR_MARK) | |
671 | return indexlist; | |
672 | ||
673 | if (TREE_CHAIN (indexlist) != NULL_TREE) | |
674 | { | |
675 | error ("invalid compound index for bitstring mode"); | |
676 | return error_mark_node; | |
677 | } | |
678 | ||
679 | if (TREE_CODE (indexlist) == TREE_LIST) | |
680 | { | |
681 | tree result = build (SET_IN_EXPR, boolean_type_node, | |
682 | TREE_VALUE (indexlist), bitstring); | |
683 | TREE_READONLY (result) = TREE_READONLY (bitstring); | |
684 | return result; | |
685 | } | |
686 | else abort (); | |
687 | } | |
688 | ||
689 | \f | |
690 | int | |
691 | discrete_type_p (type) | |
692 | tree type; | |
693 | { | |
694 | return INTEGRAL_TYPE_P (type); | |
695 | } | |
696 | ||
697 | /* Checks that EXP has discrete type, or can be converted to discrete. | |
698 | Otherwise, returns NULL_TREE. | |
699 | Normally returns the (possibly-converted) EXP. */ | |
700 | ||
701 | tree | |
702 | convert_to_discrete (exp) | |
703 | tree exp; | |
704 | { | |
705 | if (! discrete_type_p (TREE_TYPE (exp))) | |
706 | { | |
707 | if (flag_old_strings) | |
708 | { | |
709 | if (CH_CHARS_ONE_P (TREE_TYPE (exp))) | |
710 | return convert (char_type_node, exp); | |
711 | if (CH_BOOLS_ONE_P (TREE_TYPE (exp))) | |
712 | return convert (boolean_type_node, exp); | |
713 | } | |
714 | return NULL_TREE; | |
715 | } | |
716 | return exp; | |
717 | } | |
718 | \f | |
719 | /* Write into BUFFER the target-machine representation of VALUE. | |
720 | Returns 1 on success, or 0 on failure. (Either the VALUE was | |
721 | not constant, or we don't know how to do the conversion.) */ | |
722 | ||
75111422 | 723 | static int |
3c79b2da PB |
724 | expand_constant_to_buffer (value, buffer, buf_size) |
725 | tree value; | |
726 | unsigned char *buffer; | |
727 | int buf_size; | |
728 | { | |
729 | tree type = TREE_TYPE (value); | |
730 | int size = int_size_in_bytes (type); | |
731 | int i; | |
732 | if (size < 0 || size > buf_size) | |
733 | return 0; | |
734 | switch (TREE_CODE (value)) | |
735 | { | |
736 | case INTEGER_CST: | |
737 | { | |
665f2503 | 738 | unsigned HOST_WIDE_INT lo = TREE_INT_CST_LOW (value); |
3c79b2da PB |
739 | HOST_WIDE_INT hi = TREE_INT_CST_HIGH (value); |
740 | for (i = 0; i < size; i++) | |
741 | { | |
742 | /* Doesn't work if host and target BITS_PER_UNIT differ. */ | |
743 | unsigned char byte = lo & ((1 << BITS_PER_UNIT) - 1); | |
665f2503 | 744 | |
3c79b2da PB |
745 | if (BYTES_BIG_ENDIAN) |
746 | buffer[size - i - 1] = byte; | |
747 | else | |
748 | buffer[i] = byte; | |
665f2503 | 749 | |
3c79b2da PB |
750 | rshift_double (lo, hi, BITS_PER_UNIT, BITS_PER_UNIT * size, |
751 | &lo, &hi, 0); | |
752 | } | |
753 | } | |
754 | break; | |
755 | case STRING_CST: | |
756 | { | |
757 | size = TREE_STRING_LENGTH (value); | |
758 | if (size > buf_size) | |
759 | return 0; | |
760 | bcopy (TREE_STRING_POINTER (value), buffer, size); | |
761 | break; | |
762 | } | |
763 | case CONSTRUCTOR: | |
764 | if (TREE_CODE (type) == ARRAY_TYPE) | |
765 | { | |
766 | tree element_type = TREE_TYPE (type); | |
767 | int element_size = int_size_in_bytes (element_type); | |
768 | tree list = CONSTRUCTOR_ELTS (value); | |
769 | HOST_WIDE_INT next_index; | |
770 | HOST_WIDE_INT min_index = 0; | |
771 | if (element_size < 0) | |
772 | return 0; | |
773 | ||
774 | if (TYPE_DOMAIN (type) != 0) | |
775 | { | |
776 | tree min_val = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); | |
777 | if (min_val) | |
75111422 | 778 | { |
665f2503 | 779 | if (! host_integerp (min_val, 0)) |
75111422 KG |
780 | return 0; |
781 | else | |
665f2503 | 782 | min_index = tree_low_cst (min_val, 0); |
75111422 | 783 | } |
3c79b2da PB |
784 | } |
785 | ||
786 | next_index = min_index; | |
787 | ||
788 | for (; list != NULL_TREE; list = TREE_CHAIN (list)) | |
789 | { | |
790 | HOST_WIDE_INT offset; | |
791 | HOST_WIDE_INT last_index; | |
792 | tree purpose = TREE_PURPOSE (list); | |
665f2503 | 793 | |
3c79b2da PB |
794 | if (purpose) |
795 | { | |
665f2503 RK |
796 | if (host_integerp (purpose, 0)) |
797 | last_index = next_index = tree_low_cst (purpose, 0); | |
3c79b2da PB |
798 | else if (TREE_CODE (purpose) == RANGE_EXPR) |
799 | { | |
665f2503 RK |
800 | next_index = tree_low_cst (TREE_OPERAND (purpose, 0), 0); |
801 | last_index = tree_low_cst (TREE_OPERAND (purpose, 1), 0); | |
3c79b2da PB |
802 | } |
803 | else | |
804 | return 0; | |
805 | } | |
806 | else | |
807 | last_index = next_index; | |
808 | for ( ; next_index <= last_index; next_index++) | |
809 | { | |
810 | offset = (next_index - min_index) * element_size; | |
811 | if (!expand_constant_to_buffer (TREE_VALUE (list), | |
812 | buffer + offset, | |
813 | buf_size - offset)) | |
814 | return 0; | |
815 | } | |
816 | } | |
817 | break; | |
818 | } | |
819 | else if (TREE_CODE (type) == RECORD_TYPE) | |
820 | { | |
821 | tree list = CONSTRUCTOR_ELTS (value); | |
822 | for (; list != NULL_TREE; list = TREE_CHAIN (list)) | |
823 | { | |
824 | tree field = TREE_PURPOSE (list); | |
825 | HOST_WIDE_INT offset; | |
665f2503 | 826 | |
3c79b2da PB |
827 | if (field == NULL_TREE || TREE_CODE (field) != FIELD_DECL) |
828 | return 0; | |
665f2503 | 829 | |
3c79b2da PB |
830 | if (DECL_BIT_FIELD (field)) |
831 | return 0; | |
665f2503 RK |
832 | |
833 | offset = int_bit_position (field) / BITS_PER_UNIT; | |
3c79b2da PB |
834 | if (!expand_constant_to_buffer (TREE_VALUE (list), |
835 | buffer + offset, | |
836 | buf_size - offset)) | |
837 | return 0; | |
838 | } | |
839 | break; | |
840 | } | |
841 | else if (TREE_CODE (type) == SET_TYPE) | |
842 | { | |
843 | if (get_set_constructor_bytes (value, buffer, buf_size) | |
844 | != NULL_TREE) | |
845 | return 0; | |
846 | } | |
847 | break; | |
848 | default: | |
849 | return 0; | |
850 | } | |
851 | return 1; | |
852 | } | |
853 | ||
854 | /* Given that BUFFER contains a target-machine representation of | |
855 | a value of type TYPE, return that value as a tree. | |
856 | Returns NULL_TREE on failure. (E.g. the TYPE might be variable size, | |
857 | or perhaps we don't know how to do the conversion.) */ | |
858 | ||
75111422 | 859 | static tree |
3c79b2da PB |
860 | extract_constant_from_buffer (type, buffer, buf_size) |
861 | tree type; | |
31029ad7 | 862 | const unsigned char *buffer; |
3c79b2da PB |
863 | int buf_size; |
864 | { | |
865 | tree value; | |
665f2503 RK |
866 | HOST_WIDE_INT size = int_size_in_bytes (type); |
867 | HOST_WIDE_INT i; | |
868 | ||
3c79b2da PB |
869 | if (size < 0 || size > buf_size) |
870 | return 0; | |
665f2503 | 871 | |
3c79b2da PB |
872 | switch (TREE_CODE (type)) |
873 | { | |
874 | case INTEGER_TYPE: | |
875 | case CHAR_TYPE: | |
876 | case BOOLEAN_TYPE: | |
877 | case ENUMERAL_TYPE: | |
878 | case POINTER_TYPE: | |
879 | { | |
880 | HOST_WIDE_INT lo = 0, hi = 0; | |
881 | /* Accumulate (into (lo,hi) the bytes (from buffer). */ | |
882 | for (i = size; --i >= 0; ) | |
883 | { | |
884 | unsigned char byte; | |
885 | /* Get next byte (in big-endian order). */ | |
886 | if (BYTES_BIG_ENDIAN) | |
887 | byte = buffer[size - i - 1]; | |
888 | else | |
889 | byte = buffer[i]; | |
890 | lshift_double (lo, hi, BITS_PER_UNIT, TYPE_PRECISION (type), | |
891 | &lo, &hi, 0); | |
892 | add_double (lo, hi, byte, 0, &lo, &hi); | |
893 | } | |
894 | value = build_int_2 (lo, hi); | |
895 | TREE_TYPE (value) = type; | |
896 | return value; | |
897 | } | |
898 | case ARRAY_TYPE: | |
899 | { | |
900 | tree element_type = TREE_TYPE (type); | |
901 | int element_size = int_size_in_bytes (element_type); | |
902 | tree list = NULL_TREE; | |
903 | HOST_WIDE_INT min_index = 0, max_index, cur_index; | |
904 | if (element_size == 1 && CH_CHARS_TYPE_P (type)) | |
905 | { | |
906 | value = build_string (size, buffer); | |
907 | CH_DERIVED_FLAG (value) = 1; | |
908 | TREE_TYPE (value) = type; | |
909 | return value; | |
910 | } | |
911 | if (TYPE_DOMAIN (type) == 0) | |
912 | return 0; | |
913 | value = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); | |
914 | if (value) | |
75111422 | 915 | { |
665f2503 | 916 | if (! host_integerp (value, 0)) |
75111422 KG |
917 | return 0; |
918 | else | |
665f2503 | 919 | min_index = tree_low_cst (value, 0); |
75111422 | 920 | } |
665f2503 | 921 | |
3c79b2da | 922 | value = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); |
665f2503 | 923 | if (value == NULL_TREE || ! host_integerp (value, 0)) |
3c79b2da PB |
924 | return 0; |
925 | else | |
665f2503 RK |
926 | max_index = tree_low_cst (value, 0); |
927 | ||
3c79b2da PB |
928 | for (cur_index = max_index; cur_index >= min_index; cur_index--) |
929 | { | |
930 | HOST_WIDE_INT offset = (cur_index - min_index) * element_size; | |
931 | value = extract_constant_from_buffer (element_type, | |
932 | buffer + offset, | |
933 | buf_size - offset); | |
934 | if (value == NULL_TREE) | |
935 | return NULL_TREE; | |
936 | list = tree_cons (build_int_2 (cur_index, 0), value, list); | |
937 | } | |
938 | value = build (CONSTRUCTOR, type, NULL_TREE, list); | |
939 | TREE_CONSTANT (value) = 1; | |
940 | TREE_STATIC (value) = 1; | |
941 | return value; | |
942 | } | |
943 | case RECORD_TYPE: | |
944 | { | |
945 | tree list = NULL_TREE; | |
946 | tree field = TYPE_FIELDS (type); | |
947 | for (; field != NULL_TREE; field = TREE_CHAIN (field)) | |
948 | { | |
665f2503 RK |
949 | HOST_WIDE_INT offset = int_bit_position (field) / BITS_PER_UNIT; |
950 | ||
3c79b2da PB |
951 | if (DECL_BIT_FIELD (field)) |
952 | return 0; | |
953 | value = extract_constant_from_buffer (TREE_TYPE (field), | |
954 | buffer + offset, | |
955 | buf_size - offset); | |
956 | if (value == NULL_TREE) | |
957 | return NULL_TREE; | |
958 | list = tree_cons (field, value, list); | |
959 | } | |
960 | value = build (CONSTRUCTOR, type, NULL_TREE, nreverse (list)); | |
961 | TREE_CONSTANT (value) = 1; | |
962 | TREE_STATIC (value) = 1; | |
963 | return value; | |
964 | } | |
965 | ||
966 | case UNION_TYPE: | |
967 | { | |
968 | tree longest_variant = NULL_TREE; | |
665f2503 | 969 | unsigned HOST_WIDE_INT longest_size = 0; |
3c79b2da PB |
970 | tree field = TYPE_FIELDS (type); |
971 | ||
972 | /* This is a kludge. We assume that converting the data to te | |
973 | longest variant will provide valid data for the "correct" | |
974 | variant. This is usually the case, but is not guaranteed. | |
975 | For example, the longest variant may include holes. | |
976 | Also incorrect interpreting the given value as the longest | |
977 | variant may confuse the compiler if that should happen | |
978 | to yield invalid values. ??? */ | |
979 | ||
980 | for (; field != NULL_TREE; field = TREE_CHAIN (field)) | |
981 | { | |
665f2503 RK |
982 | unsigned HOST_WIDE_INT size |
983 | = int_size_in_bytes (TREE_TYPE (field)); | |
3c79b2da PB |
984 | |
985 | if (size > longest_size) | |
986 | { | |
987 | longest_size = size; | |
988 | longest_variant = field; | |
989 | } | |
990 | } | |
665f2503 | 991 | |
3c79b2da PB |
992 | if (longest_variant == NULL_TREE) |
993 | return NULL_TREE; | |
665f2503 RK |
994 | |
995 | return | |
996 | extract_constant_from_buffer (TREE_TYPE (longest_variant), | |
997 | buffer, buf_size); | |
3c79b2da PB |
998 | } |
999 | ||
1000 | case SET_TYPE: | |
1001 | { | |
1002 | tree list = NULL_TREE; | |
1003 | int i; | |
1004 | HOST_WIDE_INT min_index, max_index; | |
665f2503 | 1005 | |
3c79b2da PB |
1006 | if (TYPE_DOMAIN (type) == 0) |
1007 | return 0; | |
665f2503 | 1008 | |
3c79b2da PB |
1009 | value = TYPE_MIN_VALUE (TYPE_DOMAIN (type)); |
1010 | if (value == NULL_TREE) | |
1011 | min_index = 0; | |
665f2503 RK |
1012 | |
1013 | else if (! host_integerp (value, 0)) | |
3c79b2da PB |
1014 | return 0; |
1015 | else | |
665f2503 RK |
1016 | min_index = tree_low_cst (value, 0); |
1017 | ||
3c79b2da PB |
1018 | value = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); |
1019 | if (value == NULL_TREE) | |
1020 | max_index = 0; | |
665f2503 | 1021 | else if (! host_integerp (value, 0)) |
3c79b2da PB |
1022 | return 0; |
1023 | else | |
665f2503 RK |
1024 | max_index = tree_low_cst (value, 0); |
1025 | ||
3c79b2da PB |
1026 | for (i = max_index + 1 - min_index; --i >= 0; ) |
1027 | { | |
665f2503 RK |
1028 | unsigned char byte = (unsigned char) buffer[i / BITS_PER_UNIT]; |
1029 | unsigned bit_pos = (unsigned) i % (unsigned) BITS_PER_UNIT; | |
1030 | ||
3c79b2da PB |
1031 | if (BYTES_BIG_ENDIAN |
1032 | ? (byte & (1 << (BITS_PER_UNIT - 1 - bit_pos))) | |
1033 | : (byte & (1 << bit_pos))) | |
1034 | list = tree_cons (NULL_TREE, | |
1035 | build_int_2 (i + min_index, 0), list); | |
1036 | } | |
1037 | value = build (CONSTRUCTOR, type, NULL_TREE, list); | |
1038 | TREE_CONSTANT (value) = 1; | |
1039 | TREE_STATIC (value) = 1; | |
1040 | return value; | |
1041 | } | |
1042 | ||
1043 | default: | |
1044 | return NULL_TREE; | |
1045 | } | |
1046 | } | |
1047 | ||
1048 | tree | |
1049 | build_chill_cast (type, expr) | |
1050 | tree type, expr; | |
1051 | { | |
1052 | tree expr_type; | |
1053 | int expr_type_size; | |
1054 | int type_size; | |
1055 | int type_is_discrete; | |
1056 | int expr_type_is_discrete; | |
1057 | ||
1058 | if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) | |
1059 | return error_mark_node; | |
1060 | if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) | |
1061 | return error_mark_node; | |
1062 | ||
1063 | /* if expression was untyped because of its context (an | |
1064 | if_expr or case_expr in a tuple, perhaps) just apply | |
1065 | the type */ | |
1066 | expr_type = TREE_TYPE (expr); | |
1067 | if (expr_type == NULL_TREE | |
1068 | || TREE_CODE (expr_type) == ERROR_MARK) | |
1069 | return convert (type, expr); | |
1070 | ||
1071 | if (expr_type == type) | |
1072 | return expr; | |
1073 | ||
1074 | expr_type_size = int_size_in_bytes (expr_type); | |
1075 | type_size = int_size_in_bytes (type); | |
1076 | ||
1077 | if (expr_type_size == -1) | |
1078 | { | |
1079 | error ("conversions from variable_size value"); | |
1080 | return error_mark_node; | |
1081 | } | |
1082 | if (type_size == -1) | |
1083 | { | |
1084 | error ("conversions to variable_size mode"); | |
1085 | return error_mark_node; | |
1086 | } | |
1087 | ||
1088 | /* FIXME: process REAL ==> INT && INT ==> REAL && REAL ==> REAL. I hope this is correct. */ | |
1089 | if ((TREE_CODE (expr_type) == INTEGER_TYPE && TREE_CODE (type) == REAL_TYPE) || | |
1090 | (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == INTEGER_TYPE) || | |
1091 | (TREE_CODE (expr_type) == REAL_TYPE && TREE_CODE (type) == REAL_TYPE)) | |
1092 | return convert (type, expr); | |
1093 | ||
1094 | /* FIXME: Don't know if this is correct */ | |
1095 | /* Don't allow conversions to or from REAL with others then integer */ | |
1096 | if (TREE_CODE (type) == REAL_TYPE) | |
1097 | { | |
1098 | error ("cannot convert to float"); | |
1099 | return error_mark_node; | |
1100 | } | |
1101 | else if (TREE_CODE (expr_type) == REAL_TYPE) | |
1102 | { | |
1103 | error ("cannot convert float to this mode"); | |
1104 | return error_mark_node; | |
1105 | } | |
1106 | ||
1107 | if (expr_type_size == type_size && CH_REFERABLE (expr)) | |
1108 | goto do_location_conversion; | |
1109 | ||
1110 | type_is_discrete | |
1111 | = discrete_type_p (type) || TREE_CODE (type) == POINTER_TYPE; | |
1112 | expr_type_is_discrete | |
1113 | = discrete_type_p (expr_type) || TREE_CODE (expr_type) == POINTER_TYPE; | |
1114 | if (expr_type_is_discrete && type_is_discrete) | |
1115 | { | |
1116 | /* do an overflow check | |
1117 | FIXME: is this always neccessary ??? */ | |
1118 | /* FIXME: don't do range chacking when target type is PTR. | |
1119 | PTR doesn't have MIN and MAXVALUE. result is sigsegv. */ | |
1120 | if (range_checking && type != ptr_type_node) | |
1121 | { | |
1122 | tree tmp = expr; | |
1123 | ||
1124 | STRIP_NOPS (tmp); | |
1125 | if (TREE_CONSTANT (tmp) && TREE_CODE (tmp) != ADDR_EXPR) | |
1126 | { | |
1127 | if (compare_int_csts (LT_EXPR, tmp, TYPE_MIN_VALUE (type)) || | |
1128 | compare_int_csts (GT_EXPR, tmp, TYPE_MAX_VALUE (type))) | |
1129 | { | |
1130 | error ("OVERFLOW in expression conversion"); | |
1131 | return error_mark_node; | |
1132 | } | |
1133 | } | |
1134 | else | |
1135 | { | |
1136 | int cond1 = tree_int_cst_lt (TYPE_SIZE (type), | |
1137 | TYPE_SIZE (expr_type)); | |
1138 | int cond2 = TREE_UNSIGNED (type) && (! TREE_UNSIGNED (expr_type)); | |
1139 | int cond3 = (! TREE_UNSIGNED (type)) | |
1140 | && TREE_UNSIGNED (expr_type) | |
1141 | && tree_int_cst_equal (TYPE_SIZE (type), | |
1142 | TYPE_SIZE (expr_type)); | |
1143 | int cond4 = TREE_TYPE (type) && type_is_discrete; | |
1144 | ||
1145 | if (cond1 || cond2 || cond3 || cond4) | |
1146 | { | |
1147 | tree type_min = TYPE_MIN_VALUE (type); | |
1148 | tree type_max = TYPE_MAX_VALUE (type); | |
1149 | ||
1150 | expr = save_if_needed (expr); | |
1151 | if (expr && type_min && type_max) | |
1152 | { | |
1153 | tree check = test_range (expr, type_min, type_max); | |
1154 | if (!integer_zerop (check)) | |
1155 | { | |
1156 | if (current_function_decl == NULL_TREE) | |
1157 | { | |
1158 | if (TREE_CODE (check) == INTEGER_CST) | |
1159 | error ("overflow (not inside function)"); | |
1160 | else | |
1161 | warning ("possible overflow (not inside function)"); | |
1162 | } | |
1163 | else | |
1164 | { | |
1165 | if (TREE_CODE (check) == INTEGER_CST) | |
1166 | warning ("expression will always cause OVERFLOW"); | |
1167 | expr = check_expression (expr, check, | |
1168 | ridpointers[(int) RID_OVERFLOW]); | |
1169 | } | |
1170 | } | |
1171 | } | |
1172 | } | |
1173 | } | |
1174 | } | |
1175 | return convert (type, expr); | |
1176 | } | |
1177 | ||
1178 | if (TREE_CODE (expr) == INTEGER_CST && expr_type_size != type_size) | |
1179 | { | |
1180 | /* There should probably be a pedwarn here ... */ | |
1181 | tree itype = type_for_size (type_size * BITS_PER_UNIT, 1); | |
1182 | if (itype) | |
1183 | { | |
1184 | expr = convert (itype, expr); | |
1185 | expr_type = TREE_TYPE (expr); | |
1186 | expr_type_size= type_size; | |
1187 | } | |
1188 | } | |
1189 | ||
1190 | /* If expr is a constant of the right size, use it to to | |
1191 | initialize a static variable. */ | |
1192 | if (expr_type_size == type_size && TREE_CONSTANT (expr) && !pedantic) | |
1193 | { | |
1194 | unsigned char *buffer = (unsigned char*) alloca (type_size); | |
1195 | tree value; | |
1196 | bzero (buffer, type_size); | |
1197 | if (!expand_constant_to_buffer (expr, buffer, type_size)) | |
1198 | { | |
1199 | error ("not implemented: constant conversion from that kind of expression"); | |
1200 | return error_mark_node; | |
1201 | } | |
1202 | value = extract_constant_from_buffer (type, buffer, type_size); | |
1203 | if (value == NULL_TREE) | |
1204 | { | |
1205 | error ("not implemented: constant conversion to that kind of mode"); | |
1206 | return error_mark_node; | |
1207 | } | |
1208 | return value; | |
1209 | } | |
1210 | ||
1211 | if (!CH_REFERABLE (expr) && expr_type_size == type_size) | |
1212 | { | |
1213 | tree temp = decl_temp1 (get_unique_identifier ("CAST"), | |
1214 | TREE_TYPE (expr), 0, 0, 0, 0); | |
1215 | tree convert1 = build_chill_modify_expr (temp, expr); | |
1216 | pedwarn ("non-standard, non-portable value conversion"); | |
1217 | return build (COMPOUND_EXPR, type, convert1, | |
1218 | build_chill_cast (type, temp)); | |
1219 | } | |
1220 | ||
1221 | if (CH_REFERABLE (expr) && expr_type_size != type_size) | |
1222 | error ("location conversion between differently-sized modes"); | |
1223 | else | |
1224 | error ("unsupported value conversion"); | |
1225 | return error_mark_node; | |
1226 | ||
1227 | do_location_conversion: | |
1228 | /* To avoid confusing other parts of gcc, | |
1229 | represent this as the C expression: *(TYPE*)EXPR. */ | |
1230 | mark_addressable (expr); | |
1231 | expr = build1 (INDIRECT_REF, type, | |
1232 | build1 (NOP_EXPR, build_pointer_type (type), | |
1233 | build1 (ADDR_EXPR, build_pointer_type (expr_type), | |
1234 | expr))); | |
bd748f74 | 1235 | TREE_READONLY (expr) = TYPE_READONLY (type); |
3c79b2da PB |
1236 | return expr; |
1237 | } | |
1238 | \f | |
fed3cef0 RK |
1239 | /* Given a set_type, build an integer array from it that C will grok. */ |
1240 | ||
3c79b2da PB |
1241 | tree |
1242 | build_array_from_set (type) | |
1243 | tree type; | |
1244 | { | |
1245 | tree bytespint, bit_array_size, int_array_count; | |
1246 | ||
fed3cef0 RK |
1247 | if (type == NULL_TREE || type == error_mark_node |
1248 | || TREE_CODE (type) != SET_TYPE) | |
3c79b2da PB |
1249 | return error_mark_node; |
1250 | ||
fed3cef0 RK |
1251 | /* ??? Should this really be *HOST*?? */ |
1252 | bytespint = size_int (HOST_BITS_PER_INT / HOST_BITS_PER_CHAR); | |
3c79b2da | 1253 | bit_array_size = size_in_bytes (type); |
fed3cef0 | 1254 | int_array_count = size_binop (TRUNC_DIV_EXPR, bit_array_size, bytespint); |
3c79b2da PB |
1255 | if (integer_zerop (int_array_count)) |
1256 | int_array_count = size_one_node; | |
1257 | type = build_array_type (integer_type_node, | |
1258 | build_index_type (int_array_count)); | |
1259 | return type; | |
1260 | } | |
1261 | ||
1262 | ||
1263 | tree | |
1264 | build_chill_bin_type (size) | |
1265 | tree size; | |
1266 | { | |
1267 | #if 0 | |
665f2503 | 1268 | HOST_WIDE_INT isize; |
3c79b2da | 1269 | |
665f2503 | 1270 | if (! host_integerp (size, 1)) |
3c79b2da PB |
1271 | { |
1272 | error ("operand to bin must be a non-negative integer literal"); | |
1273 | return error_mark_node; | |
1274 | } | |
665f2503 RK |
1275 | |
1276 | isize = tree_low_cst (size, 1); | |
1277 | ||
3c79b2da PB |
1278 | if (isize <= TYPE_PRECISION (unsigned_char_type_node)) |
1279 | return unsigned_char_type_node; | |
1280 | if (isize <= TYPE_PRECISION (short_unsigned_type_node)) | |
1281 | return short_unsigned_type_node; | |
1282 | if (isize <= TYPE_PRECISION (unsigned_type_node)) | |
1283 | return unsigned_type_node; | |
1284 | if (isize <= TYPE_PRECISION (long_unsigned_type_node)) | |
1285 | return long_unsigned_type_node; | |
1286 | if (isize <= TYPE_PRECISION (long_long_unsigned_type_node)) | |
1287 | return long_long_unsigned_type_node; | |
1288 | error ("size %d of BIN too big - no such integer mode", isize); | |
1289 | return error_mark_node; | |
1290 | #endif | |
1291 | tree bintype; | |
1292 | ||
1293 | if (pass == 1) | |
1294 | { | |
1295 | bintype = make_node (INTEGER_TYPE); | |
1296 | TREE_TYPE (bintype) = ridpointers[(int) RID_BIN]; | |
1297 | TYPE_MIN_VALUE (bintype) = size; | |
1298 | TYPE_MAX_VALUE (bintype) = size; | |
1299 | } | |
1300 | else | |
1301 | { | |
1302 | error ("BIN in pass 2"); | |
1303 | return error_mark_node; | |
1304 | } | |
1305 | return bintype; | |
1306 | } | |
1307 | \f | |
1308 | tree | |
1309 | chill_expand_tuple (type, constructor) | |
1310 | tree type, constructor; | |
1311 | { | |
31029ad7 | 1312 | const char *name; |
3c79b2da PB |
1313 | tree nonreft = type; |
1314 | ||
1315 | if (TYPE_NAME (type) != NULL_TREE) | |
1316 | { | |
1317 | if (TREE_CODE (TYPE_NAME (type)) == IDENTIFIER_NODE) | |
1318 | name = IDENTIFIER_POINTER (TYPE_NAME (type)); | |
1319 | else | |
1320 | name = IDENTIFIER_POINTER (DECL_NAME (TYPE_NAME (type))); | |
1321 | } | |
1322 | else | |
1323 | name = ""; | |
1324 | ||
1325 | /* get to actual underlying type for digest_init */ | |
1326 | while (nonreft && TREE_CODE (nonreft) == REFERENCE_TYPE) | |
1327 | nonreft = TREE_TYPE (nonreft); | |
1328 | ||
1329 | if (TREE_CODE (nonreft) == ARRAY_TYPE | |
1330 | || TREE_CODE (nonreft) == RECORD_TYPE | |
1331 | || TREE_CODE (nonreft) == SET_TYPE) | |
1332 | return convert (nonreft, constructor); | |
1333 | else | |
1334 | { | |
1335 | error ("mode of tuple is neither ARRAY, STRUCT, nor POWERSET"); | |
1336 | return error_mark_node; | |
1337 | } | |
1338 | } | |
1339 | \f | |
1340 | /* This function classifies an expr into the Null class, | |
1341 | the All class, the M-Value, the M-derived, or the M-reference class. | |
1342 | It probably has some inaccuracies. */ | |
1343 | ||
1344 | struct ch_class | |
1345 | chill_expr_class (expr) | |
1346 | tree expr; | |
1347 | { | |
1348 | struct ch_class class; | |
1349 | /* The Null class contains the NULL pointer constant (only). */ | |
1350 | if (expr == null_pointer_node) | |
1351 | { | |
1352 | class.kind = CH_NULL_CLASS; | |
1353 | class.mode = NULL_TREE; | |
1354 | return class; | |
1355 | } | |
1356 | ||
1357 | /* The All class contains the <undefined value> "*". */ | |
1358 | if (TREE_CODE (expr) == UNDEFINED_EXPR) | |
1359 | { | |
1360 | class.kind = CH_ALL_CLASS; | |
1361 | class.mode = NULL_TREE; | |
1362 | return class; | |
1363 | } | |
1364 | ||
1365 | if (CH_DERIVED_FLAG (expr)) | |
1366 | { | |
1367 | class.kind = CH_DERIVED_CLASS; | |
1368 | class.mode = TREE_TYPE (expr); | |
1369 | return class; | |
1370 | } | |
1371 | ||
1372 | /* The M-Reference contains <references location> (address-of) expressions. | |
1373 | Note that something that's been converted to a reference doesn't count. */ | |
1374 | if (TREE_CODE (expr) == ADDR_EXPR | |
1375 | && TREE_CODE (TREE_TYPE (expr)) != REFERENCE_TYPE) | |
1376 | { | |
1377 | class.kind = CH_REFERENCE_CLASS; | |
1378 | class.mode = TREE_TYPE (TREE_TYPE (expr)); | |
1379 | return class; | |
1380 | } | |
1381 | ||
1382 | /* The M-Value class contains expressions with a known, specific mode M. */ | |
1383 | class.kind = CH_VALUE_CLASS; | |
1384 | class.mode = TREE_TYPE (expr); | |
1385 | return class; | |
1386 | } | |
1387 | ||
1388 | /* Returns >= 1 iff REF is a location. Return 2 if it is referable. */ | |
1389 | ||
1390 | int chill_location (ref) | |
1391 | tree ref; | |
1392 | { | |
1393 | register enum tree_code code = TREE_CODE (ref); | |
1394 | ||
1395 | switch (code) | |
1396 | { | |
1397 | case REALPART_EXPR: | |
1398 | case IMAGPART_EXPR: | |
1399 | case ARRAY_REF: | |
1400 | case PACKED_ARRAY_REF: | |
1401 | case COMPONENT_REF: | |
1402 | case NOP_EXPR: /* RETYPE_EXPR */ | |
1403 | return chill_location (TREE_OPERAND (ref, 0)); | |
1404 | case COMPOUND_EXPR: | |
1405 | return chill_location (TREE_OPERAND (ref, 1)); | |
1406 | ||
1407 | case BIT_FIELD_REF: | |
1408 | case SLICE_EXPR: | |
1409 | /* A bit-string slice is nor referable. */ | |
1410 | return chill_location (TREE_OPERAND (ref, 0)) == 0 ? 0 : 1; | |
1411 | ||
1412 | case CONSTRUCTOR: | |
1413 | case STRING_CST: | |
1414 | return 0; | |
1415 | ||
1416 | case INDIRECT_REF: | |
1417 | case VAR_DECL: | |
1418 | case PARM_DECL: | |
1419 | case RESULT_DECL: | |
1420 | case ERROR_MARK: | |
1421 | if (TREE_CODE (TREE_TYPE (ref)) != FUNCTION_TYPE | |
1422 | && TREE_CODE (TREE_TYPE (ref)) != METHOD_TYPE) | |
1423 | return 2; | |
1424 | break; | |
1425 | ||
1426 | default: | |
1427 | break; | |
1428 | } | |
1429 | return 0; | |
1430 | } | |
1431 | ||
1432 | int | |
1433 | chill_referable (val) | |
1434 | tree val; | |
1435 | { | |
1436 | return chill_location (val) > 1; | |
1437 | } | |
1438 | ||
1439 | /* Make a copy of MODE, but with the given NOVELTY. */ | |
1440 | ||
1441 | tree | |
1442 | copy_novelty (novelty, mode) | |
1443 | tree novelty, mode; | |
1444 | { | |
1445 | if (CH_NOVELTY (mode) != novelty) | |
1446 | { | |
1447 | mode = copy_node (mode); | |
1448 | TYPE_MAIN_VARIANT (mode) = mode; | |
1449 | TYPE_NEXT_VARIANT (mode) = 0; | |
1450 | TYPE_POINTER_TO (mode) = 0; | |
1451 | TYPE_REFERENCE_TO (mode) = 0; | |
1452 | SET_CH_NOVELTY (mode, novelty); | |
1453 | } | |
1454 | return mode; | |
1455 | } | |
1456 | ||
1457 | ||
1458 | struct mode_chain | |
1459 | { | |
1460 | struct mode_chain *prev; | |
1461 | tree mode1, mode2; | |
1462 | }; | |
1463 | ||
1464 | /* Tests if MODE1 and MODE2 are SIMILAR. | |
1465 | This is more or less as defined in the Blue Book, though | |
1466 | see FIXME for parts that are unfinished. | |
1467 | CHAIN is used to catch infinite recursion: It is a list of pairs | |
1468 | of mode arguments to calls to chill_similar "outer" to this call. */ | |
1469 | ||
1470 | int | |
1471 | chill_similar (mode1, mode2, chain) | |
1472 | tree mode1, mode2; | |
1473 | struct mode_chain *chain; | |
1474 | { | |
1475 | int varying1, varying2; | |
1476 | tree t1, t2; | |
1477 | struct mode_chain *link, node; | |
1478 | if (mode1 == NULL_TREE || mode2 == NULL_TREE) | |
1479 | return 0; | |
1480 | ||
1481 | while (TREE_CODE (mode1) == REFERENCE_TYPE) | |
1482 | mode1 = TREE_TYPE (mode1); | |
1483 | while (TREE_CODE (mode2) == REFERENCE_TYPE) | |
1484 | mode2 = TREE_TYPE (mode2); | |
1485 | ||
1486 | /* Range modes are similar to their parent types. */ | |
1487 | while (TREE_CODE (mode1) == INTEGER_TYPE && TREE_TYPE (mode1) != NULL_TREE) | |
1488 | mode1 = TREE_TYPE (mode1); | |
1489 | while (TREE_CODE (mode2) == INTEGER_TYPE && TREE_TYPE (mode2) != NULL_TREE) | |
1490 | mode2 = TREE_TYPE (mode2); | |
1491 | ||
1492 | ||
1493 | /* see Z.200 sections 12.1.2.2 and 13.2 - all integer precisions | |
1494 | are similar to INT and to each other */ | |
1495 | if (mode1 == mode2 || | |
1496 | (TREE_CODE (mode1) == INTEGER_TYPE && TREE_CODE (mode2) == INTEGER_TYPE)) | |
1497 | return 1; | |
1498 | ||
1499 | /* This guards against certain kinds of recursion. | |
1500 | For example: | |
1501 | SYNMODE a = STRUCT ( next REF a ); | |
1502 | SYNMODE b = STRUCT ( next REF b ); | |
1503 | These moes are similar, but will get an infite recursion trying | |
1504 | to prove that. So, if we are recursing, assume the moes are similar. | |
1505 | If they are not, we'll find some other discrepancy. */ | |
1506 | for (link = chain; link != NULL; link = link->prev) | |
1507 | { | |
1508 | if (link->mode1 == mode1 && link->mode2 == mode2) | |
1509 | return 1; | |
1510 | } | |
1511 | ||
1512 | node.mode1 = mode1; | |
1513 | node.mode2 = mode2; | |
1514 | node.prev = chain; | |
1515 | ||
1516 | varying1 = chill_varying_type_p (mode1); | |
1517 | varying2 = chill_varying_type_p (mode2); | |
1518 | /* FIXME: This isn't quite strict enough. */ | |
1519 | if ((varying1 && varying2) | |
1520 | || (varying1 && TREE_CODE (mode2) == ARRAY_TYPE) | |
1521 | || (varying2 && TREE_CODE (mode1) == ARRAY_TYPE)) | |
1522 | return 1; | |
1523 | ||
1524 | if (TREE_CODE(mode1) != TREE_CODE(mode2)) | |
1525 | { | |
1526 | if (flag_old_strings) | |
1527 | { | |
1528 | /* The recursion is to handle varying strings. */ | |
1529 | if ((TREE_CODE (mode1) == CHAR_TYPE | |
1530 | && CH_SIMILAR (mode2, string_one_type_node)) | |
1531 | || (TREE_CODE (mode2) == CHAR_TYPE | |
1532 | && CH_SIMILAR (mode1, string_one_type_node))) | |
1533 | return 1; | |
1534 | if ((TREE_CODE (mode1) == BOOLEAN_TYPE | |
1535 | && CH_SIMILAR (mode2, bitstring_one_type_node)) | |
1536 | || (TREE_CODE (mode2) == BOOLEAN_TYPE | |
1537 | && CH_SIMILAR (mode1, bitstring_one_type_node))) | |
1538 | return 1; | |
1539 | } | |
1540 | if (TREE_CODE (mode1) == FUNCTION_TYPE | |
1541 | && TREE_CODE (mode2) == POINTER_TYPE | |
1542 | && TREE_CODE (TREE_TYPE (mode2)) == FUNCTION_TYPE) | |
1543 | mode2 = TREE_TYPE (mode2); | |
1544 | else if (TREE_CODE (mode2) == FUNCTION_TYPE | |
1545 | && TREE_CODE (mode1) == POINTER_TYPE | |
1546 | && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE) | |
1547 | mode1 = TREE_TYPE (mode1); | |
1548 | else | |
1549 | return 0; | |
1550 | } | |
1551 | ||
1552 | if (CH_IS_BUFFER_MODE (mode1) && CH_IS_BUFFER_MODE (mode2)) | |
1553 | { | |
1554 | tree len1 = max_queue_size (mode1); | |
1555 | tree len2 = max_queue_size (mode2); | |
1556 | return tree_int_cst_equal (len1, len2); | |
1557 | } | |
1558 | else if (CH_IS_EVENT_MODE (mode1) && CH_IS_EVENT_MODE (mode2)) | |
1559 | { | |
1560 | tree len1 = max_queue_size (mode1); | |
1561 | tree len2 = max_queue_size (mode2); | |
1562 | return tree_int_cst_equal (len1, len2); | |
1563 | } | |
1564 | else if (CH_IS_ACCESS_MODE (mode1) && CH_IS_ACCESS_MODE (mode2)) | |
1565 | { | |
1566 | tree index1 = access_indexmode (mode1); | |
1567 | tree index2 = access_indexmode (mode2); | |
1568 | tree record1 = access_recordmode (mode1); | |
1569 | tree record2 = access_recordmode (mode2); | |
1570 | if (! chill_read_compatible (index1, index2)) | |
1571 | return 0; | |
1572 | return chill_read_compatible (record1, record2); | |
1573 | } | |
1574 | switch ((enum chill_tree_code)TREE_CODE (mode1)) | |
1575 | { | |
1576 | case INTEGER_TYPE: | |
1577 | case BOOLEAN_TYPE: | |
1578 | case CHAR_TYPE: | |
1579 | return 1; | |
1580 | case ENUMERAL_TYPE: | |
1581 | if (TYPE_VALUES (mode1) == TYPE_VALUES (mode2)) | |
1582 | return 1; | |
1583 | else | |
1584 | { | |
1585 | /* FIXME: This is more strict than z.200, which seems to | |
1586 | allow the elements to be reordered, as long as they | |
1587 | have the same values. */ | |
1588 | ||
1589 | tree field1 = TYPE_VALUES (mode1); | |
1590 | tree field2 = TYPE_VALUES (mode2); | |
1591 | ||
1592 | while (field1 != NULL_TREE && field2 != NULL_TREE) | |
1593 | { | |
1594 | tree value1, value2; | |
1595 | /* Check that the names are equal. */ | |
1596 | if (TREE_PURPOSE (field1) != TREE_PURPOSE (field2)) | |
1597 | break; | |
1598 | ||
1599 | value1 = TREE_VALUE (field1); | |
1600 | value2 = TREE_VALUE (field2); | |
1601 | /* This isn't quite sufficient in general, but will do ... */ | |
1602 | /* Note that proclaim_decl can cause the SET modes to be | |
1603 | compared BEFORE they are satisfied, but otherwise | |
1604 | chill_similar is mostly called after satisfaction. */ | |
1605 | if (TREE_CODE (value1) == CONST_DECL) | |
1606 | value1 = DECL_INITIAL (value1); | |
1607 | if (TREE_CODE (value2) == CONST_DECL) | |
1608 | value2 = DECL_INITIAL (value2); | |
1609 | /* Check that the values are equal or both NULL. */ | |
1610 | if (!(value1 == NULL_TREE && value2 == NULL_TREE) | |
1611 | && (value1 == NULL_TREE || value2 == NULL_TREE | |
1612 | || ! tree_int_cst_equal (value1, value2))) | |
1613 | break; | |
1614 | field1 = TREE_CHAIN (field1); | |
1615 | field2 = TREE_CHAIN (field2); | |
1616 | } | |
1617 | return field1 == NULL_TREE && field2 == NULL_TREE; | |
1618 | } | |
1619 | case SET_TYPE: | |
1620 | /* check for bit strings */ | |
1621 | if (CH_BOOLS_TYPE_P (mode1)) | |
1622 | return CH_BOOLS_TYPE_P (mode2); | |
1623 | if (CH_BOOLS_TYPE_P (mode2)) | |
1624 | return CH_BOOLS_TYPE_P (mode1); | |
1625 | /* both are powerset modes */ | |
1626 | return CH_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2)); | |
1627 | ||
1628 | case POINTER_TYPE: | |
1629 | /* Are the referenced modes equivalent? */ | |
1630 | return !integer_zerop (chill_equivalent (TREE_TYPE (mode1), | |
1631 | TREE_TYPE (mode2), | |
1632 | &node)); | |
1633 | ||
1634 | case ARRAY_TYPE: | |
1635 | /* char for char strings */ | |
1636 | if (CH_CHARS_TYPE_P (mode1)) | |
1637 | return CH_CHARS_TYPE_P (mode2); | |
1638 | if (CH_CHARS_TYPE_P (mode2)) | |
1639 | return CH_CHARS_TYPE_P (mode1); | |
1640 | /* array modes */ | |
1641 | if (CH_V_EQUIVALENT (TYPE_DOMAIN (mode1), TYPE_DOMAIN (mode2)) | |
1642 | /* Are the elements modes equivalent? */ | |
1643 | && !integer_zerop (chill_equivalent (TREE_TYPE (mode1), | |
1644 | TREE_TYPE (mode2), | |
1645 | &node))) | |
1646 | { | |
1647 | /* FIXME: Check that element layouts are equivalent */ | |
1648 | ||
1649 | tree count1 = fold (build (MINUS_EXPR, sizetype, | |
1650 | TYPE_MAX_VALUE (TYPE_DOMAIN (mode1)), | |
1651 | TYPE_MIN_VALUE (TYPE_DOMAIN (mode1)))); | |
1652 | tree count2 = fold (build (MINUS_EXPR, sizetype, | |
1653 | TYPE_MAX_VALUE (TYPE_DOMAIN (mode2)), | |
1654 | TYPE_MIN_VALUE (TYPE_DOMAIN (mode2)))); | |
1655 | tree cond = build_compare_discrete_expr (EQ_EXPR, count1, count2); | |
1656 | if (TREE_CODE (cond) == INTEGER_CST) | |
1657 | return !integer_zerop (cond); | |
1658 | else | |
1659 | { | |
1660 | #if 0 | |
1661 | extern int ignoring; | |
1662 | if (!ignoring | |
1663 | && range_checking | |
1664 | && current_function_decl) | |
1665 | return cond; | |
1666 | #endif | |
1667 | return 1; | |
1668 | } | |
1669 | } | |
1670 | return 0; | |
1671 | ||
1672 | case RECORD_TYPE: | |
1673 | case UNION_TYPE: | |
1674 | for (t1 = TYPE_FIELDS (mode1), t2 = TYPE_FIELDS (mode2); | |
1675 | t1 && t2; t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2)) | |
1676 | { | |
1677 | if (TREE_CODE (t1) != TREE_CODE (t2)) | |
1678 | return 0; | |
1679 | /* Are the field modes equivalent? */ | |
1680 | if (integer_zerop (chill_equivalent (TREE_TYPE (t1), | |
1681 | TREE_TYPE (t2), | |
1682 | &node))) | |
1683 | return 0; | |
1684 | } | |
1685 | return t1 == t2; | |
1686 | ||
1687 | case FUNCTION_TYPE: | |
1688 | if (!chill_l_equivalent (TREE_TYPE (mode1), TREE_TYPE (mode2), &node)) | |
1689 | return 0; | |
1690 | for (t1 = TYPE_ARG_TYPES (mode1), t2 = TYPE_ARG_TYPES (mode2); | |
1691 | t1 != NULL_TREE && t2 != NULL_TREE; | |
1692 | t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2)) | |
1693 | { | |
1694 | tree attr1 = TREE_PURPOSE (t1) | |
1695 | ? TREE_PURPOSE (t1) : ridpointers[(int) RID_IN]; | |
1696 | tree attr2 = TREE_PURPOSE (t2) | |
1697 | ? TREE_PURPOSE (t2) : ridpointers[(int) RID_IN]; | |
1698 | if (attr1 != attr2) | |
1699 | return 0; | |
1700 | if (!chill_l_equivalent (TREE_VALUE (t1), TREE_VALUE (t2), &node)) | |
1701 | return 0; | |
1702 | } | |
1703 | if (t1 != t2) /* Both NULL_TREE */ | |
1704 | return 0; | |
1705 | /* check list of exception names */ | |
1706 | t1 = TYPE_RAISES_EXCEPTIONS (mode1); | |
1707 | t2 = TYPE_RAISES_EXCEPTIONS (mode2); | |
1708 | if (t1 == NULL_TREE && t2 != NULL_TREE) | |
1709 | return 0; | |
1710 | if (t1 != NULL_TREE && t2 == NULL_TREE) | |
1711 | return 0; | |
1712 | if (list_length (t1) != list_length (t2)) | |
1713 | return 0; | |
1714 | while (t1 != NULL_TREE) | |
1715 | { | |
1716 | if (value_member (TREE_VALUE (t1), t2) == NULL_TREE) | |
1717 | return 0; | |
1718 | t1 = TREE_CHAIN (t1); | |
1719 | } | |
1720 | /* FIXME: Should also check they have the same RECURSIVITY */ | |
1721 | return 1; | |
1722 | ||
1723 | default: | |
1724 | ; | |
1725 | #if 0 | |
1726 | /* Need to handle row modes, instance modes, | |
1727 | association modes, access modes, text modes, | |
1728 | duration modes, absolute time modes, structure modes, | |
1729 | parameterized structure modes */ | |
1730 | #endif | |
1731 | } | |
1732 | return 1; | |
1733 | } | |
1734 | ||
1735 | /* Return a node that is true iff MODE1 and MODE2 are equivalent. | |
1736 | This is normally boolean_true_node or boolean_false_node, | |
1737 | but can be dynamic for dynamic types. | |
1738 | CHAIN is as for chill_similar. */ | |
1739 | ||
1740 | tree | |
1741 | chill_equivalent (mode1, mode2, chain) | |
1742 | tree mode1, mode2; | |
1743 | struct mode_chain *chain; | |
1744 | { | |
1745 | int varying1, varying2; | |
1746 | int is_string1, is_string2; | |
1747 | tree base_mode1, base_mode2; | |
1748 | ||
1749 | /* Are the modes v-equivalent? */ | |
1750 | #if 0 | |
1751 | if (!chill_similar (mode1, mode2, chain) | |
1752 | || CH_NOVELTY(mode1) != CH_NOVELTY(mode2)) | |
1753 | return boolean_false_node; | |
1754 | #endif | |
1755 | if (!chill_similar (mode1, mode2, chain)) | |
1756 | return boolean_false_node; | |
1757 | else if (TREE_CODE (mode2) == FUNCTION_TYPE | |
1758 | && TREE_CODE (mode1) == POINTER_TYPE | |
1759 | && TREE_CODE (TREE_TYPE (mode1)) == FUNCTION_TYPE) | |
1760 | /* don't check novelty in this case to avoid error in case of | |
1761 | NEWMODE'd proceduremode gets assigned a function */ | |
1762 | return boolean_true_node; | |
1763 | else if (CH_NOVELTY(mode1) != CH_NOVELTY(mode2)) | |
1764 | return boolean_false_node; | |
1765 | ||
1766 | varying1 = chill_varying_type_p (mode1); | |
1767 | varying2 = chill_varying_type_p (mode2); | |
1768 | ||
1769 | if (varying1 != varying2) | |
1770 | return boolean_false_node; | |
1771 | base_mode1 = varying1 ? CH_VARYING_ARRAY_TYPE (mode1) : mode1; | |
1772 | base_mode2 = varying2 ? CH_VARYING_ARRAY_TYPE (mode2) : mode2; | |
1773 | is_string1 = CH_STRING_TYPE_P (base_mode1); | |
1774 | is_string2 = CH_STRING_TYPE_P (base_mode2); | |
1775 | if (is_string1 || is_string2) | |
1776 | { | |
1777 | if (is_string1 != is_string2) | |
1778 | return boolean_false_node; | |
1779 | return fold (build (EQ_EXPR, boolean_type_node, | |
1780 | TYPE_SIZE (base_mode1), | |
1781 | TYPE_SIZE (base_mode2))); | |
1782 | } | |
1783 | ||
1784 | /* && some more stuff FIXME! */ | |
1785 | if (TREE_CODE(mode1) == INTEGER_TYPE || TREE_CODE(mode2) == INTEGER_TYPE) | |
1786 | { | |
1787 | if (TREE_CODE(mode1) != INTEGER_TYPE || TREE_CODE(mode2) != INTEGER_TYPE) | |
1788 | return boolean_false_node; | |
1789 | /* If one is a range, the other has to be a range. */ | |
1790 | if ((TREE_TYPE (mode1) != NULL_TREE) != (TREE_TYPE (mode2) != NULL_TREE)) | |
1791 | return boolean_false_node; | |
1792 | if (TYPE_PRECISION (mode1) != TYPE_PRECISION (mode2)) | |
1793 | return boolean_false_node; | |
1794 | if (!tree_int_cst_equal (TYPE_MIN_VALUE (mode1), TYPE_MIN_VALUE (mode2))) | |
1795 | return boolean_false_node; | |
1796 | if (!tree_int_cst_equal (TYPE_MAX_VALUE (mode1), TYPE_MAX_VALUE (mode2))) | |
1797 | return boolean_false_node; | |
1798 | } | |
1799 | return boolean_true_node; | |
1800 | } | |
1801 | ||
1802 | static int | |
1803 | chill_l_equivalent (mode1, mode2, chain) | |
1804 | tree mode1, mode2; | |
1805 | struct mode_chain *chain; | |
1806 | { | |
1807 | /* Are the modes equivalent? */ | |
1808 | if (integer_zerop (chill_equivalent (mode1, mode2, chain))) | |
1809 | return 0; | |
1810 | if (TYPE_READONLY (mode1) != TYPE_READONLY (mode2)) | |
1811 | return 0; | |
1812 | #if 0 | |
1813 | ... other conditions ...; | |
1814 | #endif | |
1815 | return 1; | |
1816 | } | |
1817 | ||
1818 | /* See Z200 12.1.2.12 */ | |
1819 | ||
1820 | int | |
1821 | chill_read_compatible (modeM, modeN) | |
1822 | tree modeM, modeN; | |
1823 | { | |
1824 | while (TREE_CODE (modeM) == REFERENCE_TYPE) | |
1825 | modeM = TREE_TYPE (modeM); | |
1826 | while (TREE_CODE (modeN) == REFERENCE_TYPE) | |
1827 | modeN = TREE_TYPE (modeN); | |
1828 | ||
1829 | if (!CH_EQUIVALENT (modeM, modeN)) | |
1830 | return 0; | |
1831 | if (TYPE_READONLY (modeN)) | |
1832 | { | |
1833 | if (!TYPE_READONLY (modeM)) | |
1834 | return 0; | |
1835 | if (CH_IS_BOUND_REFERENCE_MODE (modeM) | |
1836 | && CH_IS_BOUND_REFERENCE_MODE (modeN)) | |
1837 | { | |
1838 | return chill_l_equivalent (TREE_TYPE (modeM), TREE_TYPE (modeN), 0); | |
1839 | } | |
1840 | #if 0 | |
1841 | ...; | |
1842 | #endif | |
1843 | } | |
1844 | return 1; | |
1845 | } | |
1846 | ||
1847 | /* Tests if MODE is compatible with the class of EXPR. | |
1848 | Cfr. Chill Blue Book 12.1.2.15. */ | |
1849 | ||
1850 | int | |
1851 | chill_compatible (expr, mode) | |
1852 | tree expr, mode; | |
1853 | { | |
1854 | struct ch_class class; | |
1855 | ||
1856 | if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK) | |
1857 | return 0; | |
1858 | if (mode == NULL_TREE || TREE_CODE (mode) == ERROR_MARK) | |
1859 | return 0; | |
1860 | ||
1861 | while (TREE_CODE (mode) == REFERENCE_TYPE) | |
1862 | mode = TREE_TYPE (mode); | |
1863 | ||
1864 | if (TREE_TYPE (expr) == NULL_TREE) | |
75111422 KG |
1865 | { |
1866 | if (TREE_CODE (expr) == CONSTRUCTOR) | |
1867 | return TREE_CODE (mode) == RECORD_TYPE | |
1868 | || ((TREE_CODE (mode) == SET_TYPE || TREE_CODE (mode) == ARRAY_TYPE) | |
1869 | && ! TYPE_STRING_FLAG (mode)); | |
1870 | else | |
1871 | return TREE_CODE (expr) == CASE_EXPR || TREE_CODE (expr) == COND_EXPR; | |
1872 | } | |
3c79b2da PB |
1873 | |
1874 | class = chill_expr_class (expr); | |
1875 | switch (class.kind) | |
1876 | { | |
1877 | case CH_ALL_CLASS: | |
1878 | return 1; | |
1879 | case CH_NULL_CLASS: | |
1880 | return CH_IS_REFERENCE_MODE (mode) || CH_IS_PROCEDURE_MODE (mode) | |
1881 | || CH_IS_INSTANCE_MODE (mode); | |
1882 | case CH_VALUE_CLASS: | |
1883 | if (CH_HAS_REFERENCING_PROPERTY (mode)) | |
1884 | return CH_RESTRICTABLE_TO(mode, class.mode); | |
1885 | else | |
1886 | return CH_V_EQUIVALENT(mode, class.mode); | |
1887 | case CH_DERIVED_CLASS: | |
1888 | return CH_SIMILAR (class.mode, mode); | |
1889 | case CH_REFERENCE_CLASS: | |
1890 | if (!CH_IS_REFERENCE_MODE (mode)) | |
1891 | return 0; | |
1892 | #if 0 | |
1893 | /* FIXME! */ | |
1894 | if (class.mode is a row mode) | |
1895 | ...; | |
1896 | else if (class.mode is not a static mode) | |
1897 | return 0; /* is this possible? FIXME */ | |
1898 | #endif | |
1899 | return !CH_IS_BOUND_REFERENCE_MODE(mode) | |
1900 | || CH_READ_COMPATIBLE (TREE_TYPE (mode), class.mode); | |
1901 | } | |
1902 | return 0; /* ERROR! */ | |
1903 | } | |
1904 | ||
1905 | /* Tests if the class of of EXPR1 and EXPR2 are compatible. | |
1906 | Cfr. Chill Blue Book 12.1.2.16. */ | |
1907 | ||
1908 | int | |
1909 | chill_compatible_classes (expr1, expr2) | |
1910 | tree expr1, expr2; | |
1911 | { | |
1912 | struct ch_class temp; | |
1913 | struct ch_class class1, class2; | |
1914 | class1 = chill_expr_class (expr1); | |
1915 | class2 = chill_expr_class (expr2); | |
1916 | ||
1917 | switch (class1.kind) | |
1918 | { | |
1919 | case CH_ALL_CLASS: | |
1920 | return 1; | |
1921 | case CH_NULL_CLASS: | |
1922 | switch (class2.kind) | |
1923 | { | |
1924 | case CH_ALL_CLASS: | |
1925 | case CH_NULL_CLASS: | |
1926 | case CH_REFERENCE_CLASS: | |
1927 | return 1; | |
1928 | case CH_VALUE_CLASS: | |
1929 | case CH_DERIVED_CLASS: | |
1930 | goto rule4; | |
1931 | } | |
1932 | case CH_REFERENCE_CLASS: | |
1933 | switch (class2.kind) | |
1934 | { | |
1935 | case CH_ALL_CLASS: | |
1936 | case CH_NULL_CLASS: | |
1937 | return 1; | |
1938 | case CH_REFERENCE_CLASS: | |
1939 | return CH_EQUIVALENT (class1.mode, class2.mode); | |
1940 | case CH_VALUE_CLASS: | |
1941 | goto rule6; | |
1942 | case CH_DERIVED_CLASS: | |
1943 | return 0; | |
1944 | } | |
1945 | case CH_DERIVED_CLASS: | |
1946 | switch (class2.kind) | |
1947 | { | |
1948 | case CH_ALL_CLASS: | |
1949 | return 1; | |
1950 | case CH_VALUE_CLASS: | |
1951 | case CH_DERIVED_CLASS: | |
1952 | return CH_SIMILAR (class1.mode, class2.mode); | |
1953 | case CH_NULL_CLASS: | |
1954 | class2 = class1; | |
1955 | goto rule4; | |
1956 | case CH_REFERENCE_CLASS: | |
1957 | return 0; | |
1958 | } | |
1959 | case CH_VALUE_CLASS: | |
1960 | switch (class2.kind) | |
1961 | { | |
1962 | case CH_ALL_CLASS: | |
1963 | return 1; | |
1964 | case CH_DERIVED_CLASS: | |
1965 | return CH_SIMILAR (class1.mode, class2.mode); | |
1966 | case CH_VALUE_CLASS: | |
1967 | return CH_V_EQUIVALENT (class1.mode, class2.mode); | |
1968 | case CH_NULL_CLASS: | |
1969 | class2 = class1; | |
1970 | goto rule4; | |
1971 | case CH_REFERENCE_CLASS: | |
1972 | temp = class1; class1 = class2; class2 = temp; | |
1973 | goto rule6; | |
1974 | } | |
1975 | } | |
1976 | rule4: | |
1977 | /* The Null class is Compatible with the M-derived class or M-value class | |
1978 | if and only if M is a reference mdoe, procedure mode or instance mode.*/ | |
1979 | return CH_IS_REFERENCE_MODE (class2.mode) | |
1980 | || CH_IS_PROCEDURE_MODE (class2.mode) | |
1981 | || CH_IS_INSTANCE_MODE (class2.mode); | |
1982 | ||
1983 | rule6: | |
1984 | /* The M-reference class is compatible with the N-value class if and | |
1985 | only if N is a reference mode and ... */ | |
1986 | if (!CH_IS_REFERENCE_MODE (class2.mode)) | |
1987 | return 0; | |
1988 | if (1) /* If M is a static mode - FIXME */ | |
1989 | { | |
1990 | if (!CH_IS_BOUND_REFERENCE_MODE (class2.mode)) | |
1991 | return 1; | |
1992 | if (CH_EQUIVALENT (TREE_TYPE (class2.mode), class1.mode)) | |
1993 | return 1; | |
1994 | } | |
1995 | /* If N is a row mode whose .... FIXME */ | |
1996 | return 0; | |
1997 | } | |
1998 | ||
1999 | /* Cfr. Blue Book 12.1.1.6, with some "extensions." */ | |
2000 | ||
2001 | tree | |
2002 | chill_root_mode (mode) | |
2003 | tree mode; | |
2004 | { | |
2005 | /* Reference types are not user-visible types. | |
2006 | This seems like a good place to get rid of them. */ | |
2007 | if (TREE_CODE (mode) == REFERENCE_TYPE) | |
2008 | mode = TREE_TYPE (mode); | |
2009 | ||
2010 | while (TREE_CODE (mode) == INTEGER_TYPE && TREE_TYPE (mode) != NULL_TREE) | |
2011 | mode = TREE_TYPE (mode); /* a sub-range */ | |
2012 | ||
2013 | /* This extension in not in the Blue Book - which only has a | |
2014 | single Integer type. | |
2015 | We should probably use chill_integer_type_node rather | |
2016 | than integer_type_node, but that is likely to bomb. | |
2017 | At some point, these will become the same, I hope. FIXME */ | |
2018 | if (TREE_CODE (mode) == INTEGER_TYPE | |
2019 | && TYPE_PRECISION (mode) < TYPE_PRECISION (integer_type_node) | |
2020 | && CH_NOVELTY (mode) == NULL_TREE) | |
2021 | mode = integer_type_node; | |
2022 | ||
2023 | if (TREE_CODE (mode) == FUNCTION_TYPE) | |
2024 | return build_pointer_type (mode); | |
2025 | ||
2026 | return mode; | |
2027 | } | |
2028 | ||
2029 | /* Cfr. Blue Book 12.1.1.7. */ | |
2030 | ||
2031 | tree | |
2032 | chill_resulting_mode (mode1, mode2) | |
2033 | tree mode1, mode2; | |
2034 | { | |
2035 | mode1 = CH_ROOT_MODE (mode1); | |
2036 | mode2 = CH_ROOT_MODE (mode2); | |
2037 | if (chill_varying_type_p (mode1)) | |
2038 | return mode1; | |
2039 | if (chill_varying_type_p (mode2)) | |
2040 | return mode2; | |
2041 | return mode1; | |
2042 | } | |
2043 | ||
2044 | /* Cfr. Blue Book (z200, 1988) 12.1.1.7 Resulting class. */ | |
2045 | ||
2046 | struct ch_class | |
2047 | chill_resulting_class (class1, class2) | |
2048 | struct ch_class class1, class2; | |
2049 | { | |
2050 | struct ch_class class; | |
2051 | switch (class1.kind) | |
2052 | { | |
2053 | case CH_VALUE_CLASS: | |
2054 | switch (class2.kind) | |
2055 | { | |
2056 | case CH_DERIVED_CLASS: | |
2057 | case CH_ALL_CLASS: | |
2058 | class.kind = CH_VALUE_CLASS; | |
2059 | class.mode = CH_ROOT_MODE (class1.mode); | |
2060 | return class; | |
2061 | case CH_VALUE_CLASS: | |
2062 | class.kind = CH_VALUE_CLASS; | |
2063 | class.mode | |
2064 | = CH_ROOT_MODE (CH_RESULTING_MODE (class1.mode, class2.mode)); | |
2065 | return class; | |
875ac75a KG |
2066 | default: |
2067 | break; | |
3c79b2da | 2068 | } |
875ac75a | 2069 | break; |
3c79b2da PB |
2070 | case CH_DERIVED_CLASS: |
2071 | switch (class2.kind) | |
2072 | { | |
2073 | case CH_VALUE_CLASS: | |
2074 | class.kind = CH_VALUE_CLASS; | |
2075 | class.mode = CH_ROOT_MODE (class2.mode); | |
2076 | return class; | |
2077 | case CH_DERIVED_CLASS: | |
2078 | class.kind = CH_DERIVED_CLASS; | |
2079 | class.mode = CH_RESULTING_MODE (class1.mode, class2.mode); | |
2080 | return class; | |
2081 | case CH_ALL_CLASS: | |
2082 | class.kind = CH_DERIVED_CLASS; | |
2083 | class.mode = CH_ROOT_MODE (class1.mode); | |
2084 | return class; | |
875ac75a KG |
2085 | default: |
2086 | break; | |
3c79b2da | 2087 | } |
875ac75a | 2088 | break; |
3c79b2da PB |
2089 | case CH_ALL_CLASS: |
2090 | switch (class2.kind) | |
2091 | { | |
2092 | case CH_VALUE_CLASS: | |
2093 | class.kind = CH_VALUE_CLASS; | |
2094 | class.mode = CH_ROOT_MODE (class2.mode); | |
2095 | return class; | |
2096 | case CH_ALL_CLASS: | |
2097 | class.kind = CH_ALL_CLASS; | |
2098 | class.mode = NULL_TREE; | |
2099 | return class; | |
2100 | case CH_DERIVED_CLASS: | |
2101 | class.kind = CH_DERIVED_CLASS; | |
2102 | class.mode = CH_ROOT_MODE (class2.mode); | |
2103 | return class; | |
875ac75a KG |
2104 | default: |
2105 | break; | |
3c79b2da | 2106 | } |
875ac75a KG |
2107 | break; |
2108 | default: | |
2109 | break; | |
3c79b2da PB |
2110 | } |
2111 | error ("internal error in chill_root_resulting_mode"); | |
2112 | class.kind = CH_VALUE_CLASS; | |
2113 | class.mode = CH_ROOT_MODE (class1.mode); | |
2114 | return class; | |
2115 | } | |
2116 | \f | |
2117 | ||
2118 | /* | |
2119 | * See Z.200, section 6.3, static conditions. This function | |
2120 | * returns bool_false_node if the condition is not met at compile time, | |
2121 | * bool_true_node if the condition is detectably met at compile time | |
2122 | * an expression if a runtime check would be required or was generated. | |
2123 | * It should only be called with string modes and values. | |
2124 | */ | |
2125 | tree | |
2126 | string_assignment_condition (lhs_mode, rhs_value) | |
2127 | tree lhs_mode, rhs_value; | |
2128 | { | |
2129 | tree lhs_size, rhs_size, cond; | |
2130 | tree rhs_mode = TREE_TYPE (rhs_value); | |
2131 | int lhs_varying = chill_varying_type_p (lhs_mode); | |
2132 | ||
2133 | if (lhs_varying) | |
2134 | lhs_size = size_in_bytes (CH_VARYING_ARRAY_TYPE (lhs_mode)); | |
2135 | else if (CH_BOOLS_TYPE_P (lhs_mode)) | |
2136 | lhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (lhs_mode)); | |
2137 | else | |
2138 | lhs_size = size_in_bytes (lhs_mode); | |
2139 | lhs_size = convert (chill_unsigned_type_node, lhs_size); | |
2140 | ||
2141 | if (rhs_mode && TREE_CODE (rhs_mode) == REFERENCE_TYPE) | |
2142 | rhs_mode = TREE_TYPE (rhs_mode); | |
2143 | if (rhs_mode == NULL_TREE) | |
2144 | { | |
2145 | /* actually, count constructor's length */ | |
2146 | abort (); | |
2147 | } | |
2148 | else if (chill_varying_type_p (rhs_mode)) | |
2149 | rhs_size = build_component_ref (rhs_value, var_length_id); | |
2150 | else if (CH_BOOLS_TYPE_P (rhs_mode)) | |
2151 | rhs_size = TYPE_MAX_VALUE (TYPE_DOMAIN (rhs_mode)); | |
2152 | else | |
2153 | rhs_size = size_in_bytes (rhs_mode); | |
2154 | rhs_size = convert (chill_unsigned_type_node, rhs_size); | |
2155 | ||
2156 | /* validity condition */ | |
2157 | cond = fold (build (lhs_varying ? GE_EXPR : EQ_EXPR, | |
2158 | boolean_type_node, lhs_size, rhs_size)); | |
2159 | return cond; | |
2160 | } | |
2161 | \f | |
2162 | /* | |
2163 | * take a basic CHILL type and wrap it in a VARYING structure. | |
2164 | * Be sure the length field is initialized. Return the wrapper. | |
2165 | */ | |
2166 | tree | |
2167 | build_varying_struct (type) | |
2168 | tree type; | |
2169 | { | |
2170 | tree decl1, decl2, result; | |
2171 | ||
2172 | if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) | |
2173 | return error_mark_node; | |
2174 | ||
2175 | decl1 = build_decl (FIELD_DECL, var_length_id, chill_integer_type_node); | |
2176 | decl2 = build_decl (FIELD_DECL, var_data_id, type); | |
2177 | TREE_CHAIN (decl1) = decl2; | |
2178 | TREE_CHAIN (decl2) = NULL_TREE; | |
2179 | result = build_chill_struct_type (decl1); | |
2180 | ||
2181 | /* mark this so we don't complain about missing initializers. | |
2182 | It's fine for a VARYING array to be partially initialized.. */ | |
2183 | C_TYPE_VARIABLE_SIZE(type) = 1; | |
2184 | return result; | |
2185 | } | |
2186 | ||
2187 | ||
2188 | /* | |
2189 | * This is the struct type that forms the runtime initializer | |
2190 | * list. There's at least one of these generated per module. | |
2191 | * It's attached to the global initializer list by the module's | |
2192 | * 'constructor' code. Should only be called in pass 2. | |
2193 | */ | |
2194 | tree | |
2195 | build_init_struct () | |
2196 | { | |
2197 | tree decl1, decl2, result; | |
2198 | /* We temporarily reset the maximum_field_alignment to zero so the | |
2199 | compiler's init data structures can be compatible with the | |
2200 | run-time system, even when we're compiling with -fpack. */ | |
f7077394 | 2201 | unsigned int save_maximum_field_alignment = maximum_field_alignment; |
3c79b2da PB |
2202 | maximum_field_alignment = 0; |
2203 | ||
2204 | decl1 = build_decl (FIELD_DECL, get_identifier ("__INIT_ENTRY"), | |
2205 | build_chill_pointer_type ( | |
2206 | build_function_type (void_type_node, NULL_TREE))); | |
2207 | ||
2208 | decl2 = build_decl (FIELD_DECL, get_identifier ("__INIT_NEXT"), | |
2209 | build_chill_pointer_type (void_type_node)); | |
2210 | ||
2211 | TREE_CHAIN (decl1) = decl2; | |
2212 | TREE_CHAIN (decl2) = NULL_TREE; | |
2213 | result = build_chill_struct_type (decl1); | |
2214 | maximum_field_alignment = save_maximum_field_alignment; | |
2215 | return result; | |
2216 | } | |
2217 | \f | |
2218 | \f | |
2219 | /* | |
2220 | * Return 1 if the given type is a single-bit boolean set, | |
2221 | * in which the domain's min and max values | |
2222 | * are both zero, | |
2223 | * 0 if not. This can become a macro later.. | |
2224 | */ | |
2225 | int | |
2226 | ch_singleton_set (type) | |
2227 | tree type; | |
2228 | { | |
2229 | if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) | |
2230 | return 0; | |
2231 | if (TREE_CODE (type) != SET_TYPE) | |
2232 | return 0; | |
2233 | if (TREE_TYPE (type) == NULL_TREE | |
2234 | || TREE_CODE (TREE_TYPE (type)) != BOOLEAN_TYPE) | |
2235 | return 0; | |
2236 | if (TYPE_DOMAIN (type) == NULL_TREE) | |
2237 | return 0; | |
2238 | if (! tree_int_cst_equal (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), | |
2239 | integer_zero_node)) | |
2240 | return 0; | |
2241 | if (! tree_int_cst_equal (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), | |
2242 | integer_zero_node)) | |
2243 | return 0; | |
2244 | return 1; | |
2245 | } | |
2246 | \f | |
2247 | /* return non-zero if TYPE is a compiler-generated VARYING | |
2248 | array of some base type */ | |
2249 | int | |
2250 | chill_varying_type_p (type) | |
2251 | tree type; | |
2252 | { | |
2253 | if (type == NULL_TREE) | |
2254 | return 0; | |
2255 | if (TREE_CODE (type) != RECORD_TYPE) | |
2256 | return 0; | |
2257 | if (TYPE_FIELDS (type) == NULL_TREE | |
2258 | || TREE_CHAIN (TYPE_FIELDS (type)) == NULL_TREE) | |
2259 | return 0; | |
2260 | if (DECL_NAME (TYPE_FIELDS (type)) != var_length_id) | |
2261 | return 0; | |
2262 | if (DECL_NAME (TREE_CHAIN (TYPE_FIELDS (type))) != var_data_id) | |
2263 | return 0; | |
2264 | if (TREE_CHAIN (TREE_CHAIN (TYPE_FIELDS (type))) != NULL_TREE) | |
2265 | return 0; | |
2266 | return 1; | |
2267 | } | |
2268 | ||
2269 | /* return non-zero if TYPE is a compiler-generated VARYING | |
2270 | string record */ | |
2271 | int | |
2272 | chill_varying_string_type_p (type) | |
2273 | tree type; | |
2274 | { | |
2275 | tree var_data_type; | |
2276 | ||
2277 | if (!chill_varying_type_p (type)) | |
2278 | return 0; | |
2279 | ||
2280 | var_data_type = CH_VARYING_ARRAY_TYPE (type); | |
2281 | return CH_CHARS_TYPE_P (var_data_type); | |
2282 | } | |
2283 | \f | |
2284 | /* swiped from c-typeck.c */ | |
2285 | /* Build an assignment expression of lvalue LHS from value RHS. */ | |
2286 | ||
2287 | tree | |
2288 | build_chill_modify_expr (lhs, rhs) | |
2289 | tree lhs, rhs; | |
2290 | { | |
2291 | register tree result; | |
2292 | ||
2293 | ||
2294 | tree lhstype = TREE_TYPE (lhs); | |
2295 | ||
2296 | /* Avoid duplicate error messages from operands that had errors. */ | |
2297 | if (lhs == NULL_TREE || TREE_CODE (lhs) == ERROR_MARK || rhs == NULL_TREE || TREE_CODE (rhs) == ERROR_MARK) | |
2298 | return error_mark_node; | |
2299 | ||
2300 | /* Strip NON_LVALUE_EXPRs since we aren't using as an lvalue. */ | |
2301 | /* Do not use STRIP_NOPS here. We do not want an enumerator | |
2302 | whose value is 0 to count as a null pointer constant. */ | |
2303 | if (TREE_CODE (rhs) == NON_LVALUE_EXPR) | |
2304 | rhs = TREE_OPERAND (rhs, 0); | |
2305 | ||
2306 | #if 0 | |
2307 | /* Handle a cast used as an "lvalue". | |
2308 | We have already performed any binary operator using the value as cast. | |
2309 | Now convert the result to the cast type of the lhs, | |
2310 | and then true type of the lhs and store it there; | |
2311 | then convert result back to the cast type to be the value | |
2312 | of the assignment. */ | |
2313 | ||
2314 | switch (TREE_CODE (lhs)) | |
2315 | { | |
2316 | case NOP_EXPR: | |
2317 | case CONVERT_EXPR: | |
2318 | case FLOAT_EXPR: | |
2319 | case FIX_TRUNC_EXPR: | |
2320 | case FIX_FLOOR_EXPR: | |
2321 | case FIX_ROUND_EXPR: | |
2322 | case FIX_CEIL_EXPR: | |
2323 | { | |
2324 | tree inner_lhs = TREE_OPERAND (lhs, 0); | |
2325 | tree result; | |
2326 | result = build_chill_modify_expr (inner_lhs, | |
2327 | convert (TREE_TYPE (inner_lhs), | |
2328 | convert (lhstype, rhs))); | |
2329 | pedantic_lvalue_warning (CONVERT_EXPR); | |
2330 | return convert (TREE_TYPE (lhs), result); | |
2331 | } | |
2332 | } | |
2333 | ||
2334 | /* Now we have handled acceptable kinds of LHS that are not truly lvalues. | |
2335 | Reject anything strange now. */ | |
2336 | ||
2337 | if (!lvalue_or_else (lhs, "assignment")) | |
2338 | return error_mark_node; | |
2339 | #endif | |
2340 | /* FIXME: need to generate a RANGEFAIL if the RHS won't | |
2341 | fit into the LHS. */ | |
2342 | ||
2343 | if (TREE_CODE (lhs) != VAR_DECL | |
2344 | && ((TREE_CODE (TREE_TYPE (lhs)) == ARRAY_TYPE && | |
2345 | (TREE_TYPE (rhs) && TREE_CODE (TREE_TYPE (rhs)) == ARRAY_TYPE)) || | |
2346 | chill_varying_type_p (TREE_TYPE (lhs)) || | |
2347 | chill_varying_type_p (TREE_TYPE (rhs)))) | |
2348 | { | |
2349 | int lhs_varying = chill_varying_type_p (TREE_TYPE (lhs)); | |
2350 | int rhs_varying = chill_varying_type_p (TREE_TYPE (rhs)); | |
2351 | ||
2352 | /* point at actual RHS data's type */ | |
2353 | tree rhs_data_type = rhs_varying ? | |
2354 | CH_VARYING_ARRAY_TYPE (TREE_TYPE (rhs)) : | |
2355 | TREE_TYPE (rhs); | |
2356 | { | |
2357 | /* point at actual LHS data's type */ | |
2358 | tree lhs_data_type = lhs_varying ? | |
2359 | CH_VARYING_ARRAY_TYPE (TREE_TYPE (lhs)) : | |
2360 | TREE_TYPE (lhs); | |
2361 | ||
2362 | int lhs_bytes = int_size_in_bytes (lhs_data_type); | |
2363 | int rhs_bytes = int_size_in_bytes (rhs_data_type); | |
2364 | ||
2365 | /* if both sides not varying, and sizes not dynamically | |
2366 | computed, sizes must *match* */ | |
2367 | if (! lhs_varying && ! rhs_varying && lhs_bytes != rhs_bytes | |
2368 | && lhs_bytes > 0 && rhs_bytes > 0) | |
2369 | { | |
2370 | error ("string lengths not equal"); | |
2371 | return error_mark_node; | |
2372 | } | |
2373 | /* Must have enough space on LHS for static size of RHS */ | |
2374 | ||
2375 | if (lhs_bytes > 0 && rhs_bytes > 0 | |
2376 | && lhs_bytes < rhs_bytes) | |
2377 | { | |
2378 | if (rhs_varying) | |
2379 | { | |
2380 | /* FIXME: generate runtime test for room */ | |
2381 | ; | |
2382 | } | |
2383 | else | |
2384 | { | |
2385 | error ("can't do ARRAY assignment - too large"); | |
2386 | return error_mark_node; | |
2387 | } | |
2388 | } | |
2389 | } | |
2390 | ||
2391 | /* now we know the RHS will fit in LHS, build trees for the | |
2392 | emit_block_move parameters */ | |
2393 | ||
2394 | if (lhs_varying) | |
2395 | rhs = convert (TREE_TYPE (lhs), rhs); | |
2396 | else | |
2397 | { | |
2398 | if (rhs_varying) | |
2399 | rhs = build_component_ref (rhs, var_data_id); | |
2400 | ||
2401 | if (! mark_addressable (rhs)) | |
2402 | { | |
2403 | error ("rhs of array assignment is not addressable"); | |
2404 | return error_mark_node; | |
2405 | } | |
2406 | ||
2407 | lhs = force_addr_of (lhs); | |
2408 | rhs = build1 (ADDR_EXPR, const_ptr_type_node, rhs); | |
2409 | return | |
2410 | build_chill_function_call (lookup_name (get_identifier ("memmove")), | |
2411 | tree_cons (NULL_TREE, lhs, | |
2412 | tree_cons (NULL_TREE, rhs, | |
2413 | tree_cons (NULL_TREE, size_in_bytes (rhs_data_type), | |
2414 | NULL_TREE)))); | |
2415 | } | |
2416 | } | |
2417 | ||
2418 | result = build (MODIFY_EXPR, lhstype, lhs, rhs); | |
2419 | TREE_SIDE_EFFECTS (result) = 1; | |
2420 | ||
2421 | return result; | |
2422 | } | |
2423 | \f | |
2424 | /* Constructors for pointer, array and function types. | |
2425 | (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are | |
2426 | constructed by language-dependent code, not here.) */ | |
2427 | ||
2428 | /* Construct, lay out and return the type of pointers to TO_TYPE. | |
2429 | If such a type has already been constructed, reuse it. */ | |
2430 | ||
31029ad7 | 2431 | static tree |
3c79b2da PB |
2432 | make_chill_pointer_type (to_type, code) |
2433 | tree to_type; | |
2434 | enum tree_code code; /* POINTER_TYPE or REFERENCE_TYPE */ | |
2435 | { | |
2436 | extern struct obstack *current_obstack; | |
2437 | extern struct obstack *saveable_obstack; | |
2438 | extern struct obstack permanent_obstack; | |
2439 | tree t; | |
2440 | register struct obstack *ambient_obstack = current_obstack; | |
2441 | register struct obstack *ambient_saveable_obstack = saveable_obstack; | |
2442 | ||
2443 | /* If TO_TYPE is permanent, make this permanent too. */ | |
2444 | if (TREE_PERMANENT (to_type)) | |
2445 | { | |
2446 | current_obstack = &permanent_obstack; | |
2447 | saveable_obstack = &permanent_obstack; | |
2448 | } | |
2449 | ||
2450 | t = make_node (code); | |
2451 | TREE_TYPE (t) = to_type; | |
2452 | ||
2453 | current_obstack = ambient_obstack; | |
2454 | saveable_obstack = ambient_saveable_obstack; | |
2455 | return t; | |
2456 | } | |
2457 | ||
2458 | ||
2459 | tree | |
2460 | build_chill_pointer_type (to_type) | |
2461 | tree to_type; | |
2462 | { | |
2463 | int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't'; | |
2464 | register tree t = is_type_node ? TYPE_POINTER_TO (to_type) : NULL_TREE; | |
2465 | ||
2466 | /* First, if we already have a type for pointers to TO_TYPE, use it. */ | |
2467 | ||
2468 | if (t) | |
2469 | return t; | |
2470 | ||
2471 | /* We need a new one. */ | |
2472 | t = make_chill_pointer_type (to_type, POINTER_TYPE); | |
2473 | ||
2474 | /* Lay out the type. This function has many callers that are concerned | |
2475 | with expression-construction, and this simplifies them all. | |
2476 | Also, it guarantees the TYPE_SIZE is permanent if the type is. */ | |
2477 | if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE)) | |
2478 | || pass == 2) | |
2479 | { | |
2480 | /* Record this type as the pointer to TO_TYPE. */ | |
2481 | TYPE_POINTER_TO (to_type) = t; | |
2482 | layout_type (t); | |
2483 | } | |
2484 | ||
2485 | return t; | |
2486 | } | |
2487 | ||
2488 | tree | |
2489 | build_chill_reference_type (to_type) | |
2490 | tree to_type; | |
2491 | { | |
2492 | int is_type_node = TREE_CODE_CLASS (TREE_CODE (to_type)) == 't'; | |
2493 | register tree t = is_type_node ? TYPE_REFERENCE_TO (to_type) : NULL_TREE; | |
2494 | ||
2495 | /* First, if we already have a type for references to TO_TYPE, use it. */ | |
2496 | ||
2497 | if (t) | |
2498 | return t; | |
2499 | ||
2500 | /* We need a new one. */ | |
2501 | t = make_chill_pointer_type (to_type, REFERENCE_TYPE); | |
2502 | ||
2503 | /* Lay out the type. This function has many callers that are concerned | |
2504 | with expression-construction, and this simplifies them all. | |
2505 | Also, it guarantees the TYPE_SIZE is permanent if the type is. */ | |
2506 | if ((is_type_node && (TYPE_SIZE (to_type) != NULL_TREE)) | |
2507 | || pass == 2) | |
2508 | { | |
2509 | /* Record this type as the reference to TO_TYPE. */ | |
2510 | TYPE_REFERENCE_TO (to_type) = t; | |
2511 | layout_type (t); | |
2512 | CH_NOVELTY (t) = CH_NOVELTY (to_type); | |
2513 | } | |
2514 | ||
2515 | return t; | |
2516 | } | |
2517 | \f | |
31029ad7 | 2518 | static tree |
3c79b2da PB |
2519 | make_chill_range_type (type, lowval, highval) |
2520 | tree type, lowval, highval; | |
2521 | { | |
2522 | register tree itype = make_node (INTEGER_TYPE); | |
2523 | TREE_TYPE (itype) = type; | |
2524 | TYPE_MIN_VALUE (itype) = lowval; | |
2525 | TYPE_MAX_VALUE (itype) = highval; | |
2526 | return itype; | |
2527 | } | |
2528 | ||
665f2503 RK |
2529 | \f |
2530 | /* Return the minimum number of bits needed to represent VALUE in a | |
2531 | signed or unsigned type, UNSIGNEDP says which. */ | |
2532 | ||
2533 | static unsigned int | |
2534 | min_precision (value, unsignedp) | |
2535 | tree value; | |
2536 | int unsignedp; | |
2537 | { | |
2538 | int log; | |
2539 | ||
2540 | /* If the value is negative, compute its negative minus 1. The latter | |
2541 | adjustment is because the absolute value of the largest negative value | |
2542 | is one larger than the largest positive value. This is equivalent to | |
2543 | a bit-wise negation, so use that operation instead. */ | |
2544 | ||
2545 | if (tree_int_cst_sgn (value) < 0) | |
2546 | value = fold (build1 (BIT_NOT_EXPR, TREE_TYPE (value), value)); | |
2547 | ||
2548 | /* Return the number of bits needed, taking into account the fact | |
2549 | that we need one more bit for a signed than unsigned type. */ | |
2550 | ||
2551 | if (integer_zerop (value)) | |
2552 | log = 0; | |
2553 | else | |
2554 | log = tree_floor_log2 (value); | |
2555 | ||
2556 | return log + 1 + ! unsignedp; | |
2557 | } | |
2558 | ||
3c79b2da PB |
2559 | tree |
2560 | layout_chill_range_type (rangetype, must_be_const) | |
2561 | tree rangetype; | |
2562 | int must_be_const; | |
2563 | { | |
2564 | tree type = TREE_TYPE (rangetype); | |
2565 | tree lowval = TYPE_MIN_VALUE (rangetype); | |
2566 | tree highval = TYPE_MAX_VALUE (rangetype); | |
2567 | int bad_limits = 0; | |
2568 | ||
2569 | if (TYPE_SIZE (rangetype) != NULL_TREE) | |
2570 | return rangetype; | |
2571 | ||
2572 | /* process BIN */ | |
2573 | if (type == ridpointers[(int) RID_BIN]) | |
2574 | { | |
2575 | int binsize; | |
2576 | ||
665f2503 | 2577 | /* Make a range out of it */ |
3c79b2da PB |
2578 | if (TREE_CODE (highval) != INTEGER_CST) |
2579 | { | |
2580 | error ("non-constant expression for BIN"); | |
2581 | return error_mark_node; | |
2582 | } | |
665f2503 | 2583 | else if (tree_int_cst_sgn (highval) < 0) |
3c79b2da PB |
2584 | { |
2585 | error ("expression for BIN must not be negative"); | |
2586 | return error_mark_node; | |
2587 | } | |
665f2503 | 2588 | else if (compare_tree_int (highval, 32) > 0) |
3c79b2da PB |
2589 | { |
2590 | error ("cannot process BIN (>32)"); | |
2591 | return error_mark_node; | |
2592 | } | |
665f2503 RK |
2593 | |
2594 | binsize = tree_low_cst (highval, 1); | |
3c79b2da PB |
2595 | type = ridpointers [(int) RID_RANGE]; |
2596 | lowval = integer_zero_node; | |
2597 | highval = build_int_2 ((1 << binsize) - 1, 0); | |
2598 | } | |
2599 | ||
665f2503 RK |
2600 | if (TREE_CODE (lowval) == ERROR_MARK |
2601 | || TREE_CODE (highval) == ERROR_MARK) | |
3c79b2da PB |
2602 | return error_mark_node; |
2603 | ||
2604 | if (!CH_COMPATIBLE_CLASSES (lowval, highval)) | |
2605 | { | |
2606 | error ("bounds of range are not compatible"); | |
2607 | return error_mark_node; | |
2608 | } | |
2609 | ||
2610 | if (type == string_index_type_dummy) | |
2611 | { | |
2612 | if (TREE_CODE (highval) == INTEGER_CST | |
2613 | && compare_int_csts (LT_EXPR, highval, integer_minus_one_node)) | |
2614 | { | |
2615 | error ("negative string length"); | |
2616 | highval = integer_minus_one_node; | |
2617 | } | |
2618 | if (compare_int_csts (EQ_EXPR, highval, integer_minus_one_node)) | |
2619 | type = integer_type_node; | |
2620 | else | |
2621 | type = sizetype; | |
2622 | TREE_TYPE (rangetype) = type; | |
2623 | } | |
2624 | else if (type == ridpointers[(int) RID_RANGE]) | |
2625 | { | |
2626 | /* This isn't 100% right, since the Blue Book definition | |
2627 | uses Resulting Class, rather than Resulting Mode, | |
2628 | but it's close enough. */ | |
2629 | type = CH_ROOT_RESULTING_CLASS (lowval, highval).mode; | |
2630 | ||
2631 | /* The default TYPE is the type of the constants - | |
2632 | except if the constants are integers, we choose an | |
2633 | integer type that fits. */ | |
2634 | if (TREE_CODE (type) == INTEGER_TYPE | |
2635 | && TREE_CODE (lowval) == INTEGER_CST | |
2636 | && TREE_CODE (highval) == INTEGER_CST) | |
2637 | { | |
665f2503 RK |
2638 | int unsignedp = tree_int_cst_sgn (lowval) >= 0; |
2639 | unsigned int precision = MAX (min_precision (highval, unsignedp), | |
2640 | min_precision (lowval, unsignedp)); | |
3c79b2da | 2641 | |
665f2503 | 2642 | type = type_for_size (precision, unsignedp); |
3c79b2da PB |
2643 | |
2644 | } | |
665f2503 | 2645 | |
3c79b2da PB |
2646 | TREE_TYPE (rangetype) = type; |
2647 | } | |
2648 | else | |
2649 | { | |
2650 | if (!CH_COMPATIBLE (lowval, type)) | |
2651 | { | |
2652 | error ("range's lower bound and parent mode don't match"); | |
2653 | return integer_type_node; /* an innocuous fake */ | |
2654 | } | |
2655 | if (!CH_COMPATIBLE (highval, type)) | |
2656 | { | |
2657 | error ("range's upper bound and parent mode don't match"); | |
2658 | return integer_type_node; /* an innocuous fake */ | |
2659 | } | |
2660 | } | |
2661 | ||
2662 | if (TREE_CODE (type) == ERROR_MARK) | |
2663 | return type; | |
2664 | else if (TREE_CODE_CLASS (TREE_CODE (type)) != 't') | |
2665 | { | |
2666 | error ("making range from non-mode"); | |
2667 | return error_mark_node; | |
2668 | } | |
2669 | ||
2670 | if (TREE_CODE (lowval) == REAL_CST || TREE_CODE (highval) == REAL_CST) | |
2671 | { | |
2672 | sorry ("floating point ranges"); | |
2673 | return integer_type_node; /* another fake */ | |
2674 | } | |
2675 | ||
2676 | if (TREE_CODE (lowval) != INTEGER_CST || TREE_CODE (highval) != INTEGER_CST) | |
2677 | { | |
2678 | if (must_be_const) | |
2679 | { | |
2680 | error ("range mode has non-constant limits"); | |
2681 | bad_limits = 1; | |
2682 | } | |
2683 | } | |
2684 | else if (tree_int_cst_equal (lowval, integer_zero_node) | |
2685 | && tree_int_cst_equal (highval, integer_minus_one_node)) | |
2686 | ; /* do nothing - this is the index type for an empty string */ | |
2687 | else if (compare_int_csts (LT_EXPR, highval, TYPE_MIN_VALUE (type))) | |
2688 | { | |
2689 | error ("range's high bound < mode's low bound"); | |
2690 | bad_limits = 1; | |
2691 | } | |
2692 | else if (compare_int_csts (GT_EXPR, highval, TYPE_MAX_VALUE (type))) | |
2693 | { | |
2694 | error ("range's high bound > mode's high bound"); | |
2695 | bad_limits = 1; | |
2696 | } | |
2697 | else if (compare_int_csts (LT_EXPR, highval, lowval)) | |
2698 | { | |
2699 | error ("range mode high bound < range mode low bound"); | |
2700 | bad_limits = 1; | |
2701 | } | |
2702 | else if (compare_int_csts (LT_EXPR, lowval, TYPE_MIN_VALUE (type))) | |
2703 | { | |
2704 | error ("range's low bound < mode's low bound"); | |
2705 | bad_limits = 1; | |
2706 | } | |
2707 | else if (compare_int_csts (GT_EXPR, lowval, TYPE_MAX_VALUE (type))) | |
2708 | { | |
2709 | error ("range's low bound > mode's high bound"); | |
2710 | bad_limits = 1; | |
2711 | } | |
2712 | ||
2713 | if (bad_limits) | |
2714 | { | |
2715 | lowval = TYPE_MIN_VALUE (type); | |
2716 | highval = lowval; | |
2717 | } | |
2718 | ||
2719 | highval = convert (type, highval); | |
2720 | lowval = convert (type, lowval); | |
2721 | TYPE_MIN_VALUE (rangetype) = lowval; | |
2722 | TYPE_MAX_VALUE (rangetype) = highval; | |
2723 | TYPE_PRECISION (rangetype) = TYPE_PRECISION (type); | |
2724 | TYPE_MODE (rangetype) = TYPE_MODE (type); | |
2725 | TYPE_SIZE (rangetype) = TYPE_SIZE (type); | |
24775172 | 2726 | TYPE_SIZE_UNIT (rangetype) = TYPE_SIZE_UNIT (type); |
3c79b2da PB |
2727 | TYPE_ALIGN (rangetype) = TYPE_ALIGN (type); |
2728 | TREE_UNSIGNED (rangetype) = TREE_UNSIGNED (type); | |
2729 | CH_NOVELTY (rangetype) = CH_NOVELTY (type); | |
2730 | return rangetype; | |
2731 | } | |
2732 | ||
2733 | /* Build a _TYPE node that has range bounds associated with its values. | |
2734 | TYPE is the base type for the range type. */ | |
2735 | tree | |
2736 | build_chill_range_type (type, lowval, highval) | |
2737 | tree type, lowval, highval; | |
2738 | { | |
2739 | tree rangetype; | |
2740 | ||
2741 | if (type == NULL_TREE) | |
2742 | type = ridpointers[(int) RID_RANGE]; | |
2743 | else if (TREE_CODE (type) == ERROR_MARK) | |
2744 | return error_mark_node; | |
2745 | ||
2746 | rangetype = make_chill_range_type (type, lowval, highval); | |
2747 | if (pass != 1) | |
2748 | rangetype = layout_chill_range_type (rangetype, 0); | |
2749 | ||
2750 | return rangetype; | |
2751 | } | |
2752 | ||
2753 | /* Build a CHILL array type, but with minimal checking etc. */ | |
2754 | ||
2755 | tree | |
2756 | build_simple_array_type (type, idx, layout) | |
2757 | tree type, idx, layout; | |
2758 | { | |
2759 | tree array_type = make_node (ARRAY_TYPE); | |
2760 | TREE_TYPE (array_type) = type; | |
2761 | TYPE_DOMAIN (array_type) = idx; | |
2762 | TYPE_ATTRIBUTES (array_type) = layout; | |
2763 | if (pass != 1) | |
2764 | array_type = layout_chill_array_type (array_type); | |
2765 | return array_type; | |
2766 | } | |
2767 | ||
2768 | static void | |
2769 | apply_chill_array_layout (array_type) | |
2770 | tree array_type; | |
2771 | { | |
2772 | tree layout, temp, what, element_type; | |
665f2503 RK |
2773 | HOST_WIDE_INT stepsize = 0; |
2774 | HOST_WIDE_INT word, start_bit = 0, length; | |
2775 | HOST_WIDE_INT natural_length; | |
3c79b2da PB |
2776 | int stepsize_specified; |
2777 | int start_bit_error = 0; | |
2778 | int length_error = 0; | |
2779 | ||
2780 | layout = TYPE_ATTRIBUTES (array_type); | |
2781 | if (layout == NULL_TREE) | |
2782 | return; | |
2783 | ||
2784 | if (layout == integer_zero_node) /* NOPACK */ | |
2785 | { | |
2786 | TYPE_PACKED (array_type) = 0; | |
2787 | return; | |
2788 | } | |
2789 | ||
2790 | /* Allow for the packing of 1 bit discrete modes at the bit level. */ | |
2791 | element_type = TREE_TYPE (array_type); | |
2792 | if (discrete_type_p (element_type) | |
2793 | && get_type_precision (TYPE_MIN_VALUE (element_type), | |
2794 | TYPE_MAX_VALUE (element_type)) == 1) | |
2795 | natural_length = 1; | |
665f2503 RK |
2796 | else if (host_integerp (TYPE_SIZE (element_type), 1)) |
2797 | natural_length = tree_low_cst (TYPE_SIZE (element_type), 1); | |
3c79b2da | 2798 | else |
665f2503 | 2799 | natural_length = -1; |
3c79b2da PB |
2800 | |
2801 | if (layout == integer_one_node) /* PACK */ | |
2802 | { | |
2803 | if (natural_length == 1) | |
2804 | TYPE_PACKED (array_type) = 1; | |
2805 | return; | |
2806 | } | |
2807 | ||
2808 | /* The layout is a STEP (...). | |
2809 | The current implementation restricts STEP specifications to be of the form | |
2810 | STEP(POS(0,0,n),n) where n is the natural size of the element mode. */ | |
2811 | stepsize_specified = 0; | |
2812 | temp = TREE_VALUE (layout); | |
2813 | if (TREE_VALUE (temp) != NULL_TREE) | |
2814 | { | |
665f2503 | 2815 | if (! host_integerp (TREE_VALUE (temp), 0)) |
3c79b2da PB |
2816 | error ("Stepsize in STEP must be an integer constant"); |
2817 | else | |
2818 | { | |
665f2503 | 2819 | if (tree_int_cst_sgn (TREE_VALUE (temp)) <= 0) |
3c79b2da PB |
2820 | error ("Stepsize in STEP must be > 0"); |
2821 | else | |
2822 | stepsize_specified = 1; | |
2823 | ||
665f2503 | 2824 | stepsize = tree_low_cst (TREE_VALUE (temp), 1); |
3c79b2da | 2825 | if (stepsize != natural_length) |
509c1e9c | 2826 | sorry ("Stepsize in STEP must be the natural width of the array element mode"); |
3c79b2da PB |
2827 | } |
2828 | } | |
2829 | ||
2830 | temp = TREE_PURPOSE (temp); | |
665f2503 | 2831 | if (! host_integerp (TREE_PURPOSE (temp), 0)) |
3c79b2da PB |
2832 | error ("Starting word in POS must be an integer constant"); |
2833 | else | |
2834 | { | |
665f2503 | 2835 | if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) |
3c79b2da | 2836 | error ("Starting word in POS must be >= 0"); |
665f2503 | 2837 | if (! integer_zerop (TREE_PURPOSE (temp))) |
3c79b2da | 2838 | sorry ("Starting word in POS within STEP must be 0"); |
665f2503 RK |
2839 | |
2840 | word = tree_low_cst (TREE_PURPOSE (temp), 0); | |
3c79b2da PB |
2841 | } |
2842 | ||
2843 | length = natural_length; | |
2844 | temp = TREE_VALUE (temp); | |
2845 | if (temp != NULL_TREE) | |
2846 | { | |
2847 | int wordsize = TYPE_PRECISION (chill_integer_type_node); | |
665f2503 | 2848 | if (! host_integerp (TREE_PURPOSE (temp), 0)) |
3c79b2da PB |
2849 | { |
2850 | error ("Starting bit in POS must be an integer constant"); | |
2851 | start_bit_error = 1; | |
2852 | } | |
2853 | else | |
2854 | { | |
665f2503 | 2855 | if (! integer_zerop (TREE_PURPOSE (temp))) |
3c79b2da | 2856 | sorry ("Starting bit in POS within STEP must be 0"); |
665f2503 RK |
2857 | |
2858 | if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) | |
3c79b2da PB |
2859 | { |
2860 | error ("Starting bit in POS must be >= 0"); | |
2861 | start_bit = 0; | |
2862 | start_bit_error = 1; | |
2863 | } | |
665f2503 RK |
2864 | |
2865 | start_bit = tree_low_cst (TREE_PURPOSE (temp), 0); | |
2866 | if (start_bit >= wordsize) | |
3c79b2da PB |
2867 | { |
2868 | error ("Starting bit in POS must be < the width of a word"); | |
2869 | start_bit = 0; | |
2870 | start_bit_error = 1; | |
2871 | } | |
2872 | } | |
2873 | ||
2874 | temp = TREE_VALUE (temp); | |
2875 | if (temp != NULL_TREE) | |
2876 | { | |
2877 | what = TREE_PURPOSE (temp); | |
2878 | if (what == integer_zero_node) | |
2879 | { | |
665f2503 | 2880 | if (! host_integerp (TREE_VALUE (temp), 0)) |
3c79b2da PB |
2881 | { |
2882 | error ("Length in POS must be an integer constant"); | |
2883 | length_error = 1; | |
2884 | } | |
2885 | else | |
2886 | { | |
665f2503 | 2887 | length = tree_low_cst (TREE_VALUE (temp), 0); |
3c79b2da PB |
2888 | if (length <= 0) |
2889 | error ("Length in POS must be > 0"); | |
2890 | } | |
2891 | } | |
2892 | else | |
2893 | { | |
665f2503 | 2894 | if (! host_integerp (TREE_VALUE (temp), 0)) |
3c79b2da PB |
2895 | { |
2896 | error ("End bit in POS must be an integer constant"); | |
2897 | length_error = 1; | |
2898 | } | |
2899 | else | |
2900 | { | |
665f2503 RK |
2901 | HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0); |
2902 | ||
3c79b2da PB |
2903 | if (end_bit < start_bit) |
2904 | { | |
2905 | error ("End bit in POS must be >= the start bit"); | |
2906 | end_bit = wordsize - 1; | |
2907 | length_error = 1; | |
2908 | } | |
2909 | else if (end_bit >= wordsize) | |
2910 | { | |
2911 | error ("End bit in POS must be < the width of a word"); | |
2912 | end_bit = wordsize - 1; | |
2913 | length_error = 1; | |
2914 | } | |
2915 | else if (start_bit_error) | |
2916 | length_error = 1; | |
2917 | else | |
2918 | length = end_bit - start_bit + 1; | |
2919 | } | |
2920 | } | |
665f2503 | 2921 | |
3c79b2da | 2922 | if (! length_error && length != natural_length) |
665f2503 | 2923 | sorry ("The length specified on POS within STEP must be the natural length of the array element type"); |
3c79b2da PB |
2924 | } |
2925 | } | |
2926 | ||
2927 | if (! length_error && stepsize_specified && stepsize < length) | |
2928 | error ("Step size in STEP must be >= the length in POS"); | |
2929 | ||
2930 | if (length == 1) | |
2931 | TYPE_PACKED (array_type) = 1; | |
2932 | } | |
2933 | ||
2934 | tree | |
2935 | layout_chill_array_type (array_type) | |
2936 | tree array_type; | |
2937 | { | |
2938 | tree itype; | |
2939 | tree element_type = TREE_TYPE (array_type); | |
2940 | ||
2941 | if (TREE_CODE (element_type) == ARRAY_TYPE | |
2942 | && TYPE_SIZE (element_type) == 0) | |
2943 | layout_chill_array_type (element_type); | |
2944 | ||
2945 | itype = TYPE_DOMAIN (array_type); | |
2946 | ||
2947 | if (TREE_CODE (itype) == ERROR_MARK | |
2948 | || TREE_CODE (element_type) == ERROR_MARK) | |
2949 | return error_mark_node; | |
2950 | ||
2951 | /* do a lower/upper bound check. */ | |
2952 | if (TREE_CODE (itype) == INTEGER_CST) | |
2953 | { | |
2954 | error ("array index must be a range, not a single integer"); | |
2955 | return error_mark_node; | |
2956 | } | |
2957 | if (TREE_CODE_CLASS (TREE_CODE (itype)) != 't' | |
2958 | || !discrete_type_p (itype)) | |
2959 | { | |
2960 | error ("array index is not a discrete mode"); | |
2961 | return error_mark_node; | |
2962 | } | |
2963 | ||
2964 | /* apply the array layout, if specified. */ | |
2965 | apply_chill_array_layout (array_type); | |
2966 | TYPE_ATTRIBUTES (array_type) = NULL_TREE; | |
2967 | ||
2968 | /* Make sure TYPE_POINTER_TO (element_type) is filled in. */ | |
2969 | build_pointer_type (element_type); | |
2970 | ||
2971 | if (TYPE_SIZE (array_type) == 0) | |
2972 | layout_type (array_type); | |
2973 | ||
2974 | if (TYPE_READONLY_PROPERTY (element_type)) | |
2975 | TYPE_FIELDS_READONLY (array_type) = 1; | |
2976 | ||
2977 | TYPE_ARRAY_MAX_SIZE (array_type) = size_in_bytes (array_type); | |
2978 | return array_type; | |
2979 | } | |
2980 | ||
2981 | /* Build a CHILL array type. | |
2982 | ||
2983 | TYPE is the element type of the array. | |
2984 | IDXLIST is the list of dimensions of the array. | |
2985 | VARYING_P is non-zero if the array is a varying array. | |
2986 | LAYOUT is (NULL_TREE, integer_one_node, integer_zero_node, tree_list), | |
2987 | meaning (default, pack, nopack, STEP (...) ). */ | |
2988 | tree | |
2989 | build_chill_array_type (type, idxlist, varying_p, layouts) | |
2990 | tree type, idxlist; | |
2991 | int varying_p; | |
2992 | tree layouts; | |
2993 | { | |
2994 | tree array_type = type; | |
2995 | ||
2996 | if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK) | |
2997 | return error_mark_node; | |
2998 | if (idxlist == NULL_TREE || TREE_CODE (idxlist) == ERROR_MARK) | |
2999 | return error_mark_node; | |
3000 | ||
3001 | /* We have to walk down the list of index decls, building inner | |
3002 | array types as we go. We need to reverse the list of layouts so that the | |
3003 | first layout applies to the last index etc. */ | |
3004 | layouts = nreverse (layouts); | |
3005 | for ( ; idxlist; idxlist = TREE_CHAIN (idxlist)) | |
3006 | { | |
3007 | if (layouts != NULL_TREE) | |
3008 | { | |
3009 | type = build_simple_array_type ( | |
3010 | type, TREE_VALUE (idxlist), TREE_VALUE (layouts)); | |
3011 | layouts = TREE_CHAIN (layouts); | |
3012 | } | |
3013 | else | |
3014 | type = build_simple_array_type (type, TREE_VALUE (idxlist), NULL_TREE); | |
3015 | } | |
3016 | array_type = type; | |
3017 | if (varying_p) | |
3018 | array_type = build_varying_struct (array_type); | |
3019 | return array_type; | |
3020 | } | |
3021 | ||
3022 | /* Function to help qsort sort FIELD_DECLs by name order. */ | |
3023 | ||
3024 | static int | |
3025 | field_decl_cmp (x, y) | |
3026 | tree *x, *y; | |
3027 | { | |
3028 | return (long)DECL_NAME (*x) - (long)DECL_NAME (*y); | |
3029 | } | |
3030 | ||
31029ad7 | 3031 | static tree |
3c79b2da PB |
3032 | make_chill_struct_type (fieldlist) |
3033 | tree fieldlist; | |
3034 | { | |
3035 | tree t, x; | |
9df2c88c RK |
3036 | |
3037 | t = make_node (TREE_UNION_ELEM (fieldlist) ? UNION_TYPE : RECORD_TYPE); | |
3038 | ||
3c79b2da PB |
3039 | /* Install struct as DECL_CONTEXT of each field decl. */ |
3040 | for (x = fieldlist; x; x = TREE_CHAIN (x)) | |
9df2c88c | 3041 | DECL_CONTEXT (x) = t; |
3c79b2da PB |
3042 | |
3043 | /* Delete all duplicate fields from the fieldlist */ | |
3044 | for (x = fieldlist; x && TREE_CHAIN (x);) | |
3045 | /* Anonymous fields aren't duplicates. */ | |
3046 | if (DECL_NAME (TREE_CHAIN (x)) == 0) | |
3047 | x = TREE_CHAIN (x); | |
3048 | else | |
3049 | { | |
3050 | register tree y = fieldlist; | |
3051 | ||
3052 | while (1) | |
3053 | { | |
3054 | if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x))) | |
3055 | break; | |
3056 | if (y == x) | |
3057 | break; | |
3058 | y = TREE_CHAIN (y); | |
3059 | } | |
3060 | if (DECL_NAME (y) == DECL_NAME (TREE_CHAIN (x))) | |
3061 | { | |
3062 | error_with_decl (TREE_CHAIN (x), "duplicate member `%s'"); | |
3063 | TREE_CHAIN (x) = TREE_CHAIN (TREE_CHAIN (x)); | |
3064 | } | |
3065 | else x = TREE_CHAIN (x); | |
3066 | } | |
3067 | ||
3068 | TYPE_FIELDS (t) = fieldlist; | |
3069 | ||
3070 | return t; | |
3071 | } | |
3072 | ||
9df2c88c RK |
3073 | /* DECL is a FIELD_DECL. |
3074 | DECL_INIT (decl) is | |
3075 | (NULL_TREE, integer_one_node, integer_zero_node, tree_list) | |
3076 | meaning | |
3077 | (default, pack, nopack, POS (...) ). | |
3078 | ||
3c79b2da | 3079 | The return value is a boolean: 1 if POS specified, 0 if not */ |
9df2c88c | 3080 | |
3c79b2da PB |
3081 | static int |
3082 | apply_chill_field_layout (decl, next_struct_offset) | |
3083 | tree decl; | |
9df2c88c | 3084 | int *next_struct_offset; |
3c79b2da | 3085 | { |
9df2c88c RK |
3086 | tree layout = DECL_INITIAL (decl); |
3087 | tree type = TREE_TYPE (decl); | |
3088 | tree temp, what; | |
3089 | HOST_WIDE_INT word = 0; | |
3090 | HOST_WIDE_INT wordsize, start_bit, offset, length, natural_length; | |
3c79b2da | 3091 | int pos_error = 0; |
9df2c88c | 3092 | int is_discrete = discrete_type_p (type); |
3c79b2da | 3093 | |
3c79b2da | 3094 | if (is_discrete) |
9df2c88c RK |
3095 | natural_length |
3096 | = get_type_precision (TYPE_MIN_VALUE (type), TYPE_MAX_VALUE (type)); | |
665f2503 RK |
3097 | else if (host_integerp (TYPE_SIZE (type), 1)) |
3098 | natural_length = tree_low_cst (TYPE_SIZE (type), 1); | |
3c79b2da | 3099 | else |
665f2503 | 3100 | natural_length = -1; |
3c79b2da | 3101 | |
3c79b2da PB |
3102 | if (layout == integer_zero_node) /* NOPACK */ |
3103 | { | |
3c79b2da PB |
3104 | *next_struct_offset += natural_length; |
3105 | return 0; /* not POS */ | |
3106 | } | |
3107 | ||
3108 | if (layout == integer_one_node) /* PACK */ | |
3109 | { | |
3110 | if (is_discrete) | |
3c79b2da | 3111 | { |
9df2c88c RK |
3112 | DECL_BIT_FIELD (decl) = 1; |
3113 | DECL_SIZE (decl) = bitsize_int (natural_length); | |
3c79b2da | 3114 | } |
9df2c88c RK |
3115 | else |
3116 | DECL_ALIGN (decl) = BITS_PER_UNIT; | |
3117 | ||
3c79b2da | 3118 | DECL_PACKED (decl) = 1; |
3c79b2da PB |
3119 | *next_struct_offset += natural_length; |
3120 | return 0; /* not POS */ | |
3121 | } | |
3122 | ||
3123 | /* The layout is a POS (...). The current implementation restricts the use | |
3124 | of POS to monotonically increasing fields whose width must be the | |
3125 | natural width of the underlying type. */ | |
3126 | temp = TREE_PURPOSE (layout); | |
3127 | ||
665f2503 | 3128 | if (! host_integerp (TREE_PURPOSE (temp), 0)) |
3c79b2da PB |
3129 | { |
3130 | error ("Starting word in POS must be an integer constant"); | |
3131 | pos_error = 1; | |
3132 | } | |
3133 | else | |
3134 | { | |
9df2c88c | 3135 | if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) |
3c79b2da PB |
3136 | { |
3137 | error ("Starting word in POS must be >= 0"); | |
3138 | word = 0; | |
3139 | pos_error = 1; | |
3140 | } | |
665f2503 RK |
3141 | else |
3142 | word = tree_low_cst (TREE_PURPOSE (temp), 0); | |
3c79b2da PB |
3143 | } |
3144 | ||
3145 | wordsize = TYPE_PRECISION (chill_integer_type_node); | |
3146 | offset = word * wordsize; | |
3147 | length = natural_length; | |
3148 | ||
3149 | temp = TREE_VALUE (temp); | |
3150 | if (temp != NULL_TREE) | |
3151 | { | |
665f2503 | 3152 | if (! host_integerp (TREE_PURPOSE (temp), 0)) |
3c79b2da PB |
3153 | { |
3154 | error ("Starting bit in POS must be an integer constant"); | |
3155 | start_bit = *next_struct_offset - offset; | |
3156 | pos_error = 1; | |
3157 | } | |
3158 | else | |
3159 | { | |
9df2c88c | 3160 | if (tree_int_cst_sgn (TREE_PURPOSE (temp)) < 0) |
3c79b2da PB |
3161 | { |
3162 | error ("Starting bit in POS must be >= 0"); | |
3163 | start_bit = *next_struct_offset - offset; | |
3164 | pos_error = 1; | |
3165 | } | |
665f2503 RK |
3166 | |
3167 | start_bit = tree_low_cst (TREE_PURPOSE (temp), 0); | |
3168 | if (start_bit >= wordsize) | |
3c79b2da PB |
3169 | { |
3170 | error ("Starting bit in POS must be < the width of a word"); | |
3171 | start_bit = *next_struct_offset - offset; | |
3172 | pos_error = 1; | |
3173 | } | |
3174 | } | |
3175 | ||
3176 | temp = TREE_VALUE (temp); | |
3177 | if (temp != NULL_TREE) | |
3178 | { | |
3179 | what = TREE_PURPOSE (temp); | |
3180 | if (what == integer_zero_node) | |
3181 | { | |
665f2503 | 3182 | if (! host_integerp (TREE_VALUE (temp), 0)) |
3c79b2da PB |
3183 | { |
3184 | error ("Length in POS must be an integer constant"); | |
3185 | pos_error = 1; | |
3186 | } | |
3187 | else | |
3188 | { | |
9df2c88c | 3189 | if (tree_int_cst_sgn (TREE_VALUE (temp)) < 0) |
3c79b2da PB |
3190 | { |
3191 | error ("Length in POS must be > 0"); | |
3192 | length = natural_length; | |
3193 | pos_error = 1; | |
3194 | } | |
665f2503 RK |
3195 | else |
3196 | length = tree_low_cst (TREE_VALUE (temp), 0); | |
3197 | ||
3c79b2da PB |
3198 | } |
3199 | } | |
3200 | else | |
3201 | { | |
665f2503 | 3202 | if (! host_integerp (TREE_VALUE (temp), 0)) |
3c79b2da PB |
3203 | { |
3204 | error ("End bit in POS must be an integer constant"); | |
3205 | pos_error = 1; | |
3206 | } | |
3207 | else | |
3208 | { | |
665f2503 | 3209 | HOST_WIDE_INT end_bit = tree_low_cst (TREE_VALUE (temp), 0); |
9df2c88c | 3210 | |
3c79b2da PB |
3211 | if (end_bit < start_bit) |
3212 | { | |
3213 | error ("End bit in POS must be >= the start bit"); | |
3214 | pos_error = 1; | |
3215 | } | |
3216 | else if (end_bit >= wordsize) | |
3217 | { | |
3218 | error ("End bit in POS must be < the width of a word"); | |
3219 | pos_error = 1; | |
3220 | } | |
3221 | else | |
3222 | length = end_bit - start_bit + 1; | |
3223 | } | |
3224 | } | |
9df2c88c | 3225 | |
3c79b2da PB |
3226 | if (length != natural_length && ! pos_error) |
3227 | { | |
509c1e9c | 3228 | sorry ("The length specified on POS must be the natural length of the field type"); |
3c79b2da PB |
3229 | length = natural_length; |
3230 | } | |
3231 | } | |
3232 | ||
3233 | offset += start_bit; | |
3234 | } | |
3235 | ||
3236 | if (offset != *next_struct_offset && ! pos_error) | |
3237 | sorry ("STRUCT fields must be layed out in monotonically increasing order"); | |
3238 | ||
3239 | DECL_PACKED (decl) = 1; | |
3240 | DECL_BIT_FIELD (decl) = is_discrete; | |
9df2c88c RK |
3241 | |
3242 | if (is_discrete) | |
3243 | DECL_SIZE (decl) = bitsize_int (length); | |
3244 | ||
3c79b2da PB |
3245 | *next_struct_offset += natural_length; |
3246 | ||
3247 | return 1; /* was POS */ | |
3248 | } | |
3249 | ||
3250 | tree | |
3251 | layout_chill_struct_type (t) | |
3252 | tree t; | |
3253 | { | |
3254 | tree fieldlist = TYPE_FIELDS (t); | |
3255 | tree x; | |
3256 | int old_momentary; | |
3257 | int was_pos; | |
3258 | int pos_seen = 0; | |
3259 | int pos_error = 0; | |
3260 | int next_struct_offset; | |
3261 | ||
3262 | old_momentary = suspend_momentary (); | |
3263 | ||
9df2c88c | 3264 | /* Process specified field sizes. */ |
3c79b2da PB |
3265 | next_struct_offset = 0; |
3266 | for (x = fieldlist; x; x = TREE_CHAIN (x)) | |
3267 | { | |
3268 | /* An EVENT or BUFFER mode is implemented as a RECORD_TYPE | |
3269 | which may contain a CONST_DECL for the maximum queue size. */ | |
3270 | if (TREE_CODE (x) == CONST_DECL) | |
3271 | continue; | |
3272 | ||
3273 | /* If any field is const, the structure type is pseudo-const. */ | |
3274 | /* A field that is pseudo-const makes the structure likewise. */ | |
3275 | if (TREE_READONLY (x) || TYPE_READONLY_PROPERTY (TREE_TYPE (x))) | |
3276 | TYPE_FIELDS_READONLY (t) = 1; | |
3277 | ||
3278 | /* Any field that is volatile means variables of this type must be | |
3279 | treated in some ways as volatile. */ | |
3280 | if (TREE_THIS_VOLATILE (x)) | |
3281 | C_TYPE_FIELDS_VOLATILE (t) = 1; | |
3282 | ||
3283 | if (DECL_INITIAL (x) != NULL_TREE) | |
3284 | { | |
3285 | was_pos = apply_chill_field_layout (x, &next_struct_offset); | |
3286 | DECL_INITIAL (x) = NULL_TREE; | |
3287 | } | |
3288 | else | |
3289 | { | |
36ef59e7 | 3290 | unsigned int min_align = TYPE_ALIGN (TREE_TYPE (x)); |
3c79b2da PB |
3291 | DECL_ALIGN (x) = MAX (DECL_ALIGN (x), min_align); |
3292 | was_pos = 0; | |
3293 | } | |
3294 | if ((! was_pos && pos_seen) || (was_pos && ! pos_seen && x != fieldlist)) | |
3295 | pos_error = 1; | |
3296 | pos_seen |= was_pos; | |
3297 | } | |
3298 | ||
3299 | if (pos_error) | |
3300 | error ("If one field has a POS layout, then all fields must have a POS layout"); | |
3301 | ||
3302 | /* Now DECL_INITIAL is null on all fields. */ | |
3303 | ||
3304 | layout_type (t); | |
3305 | ||
3306 | /* Now we have the truly final field list. | |
3307 | Store it in this type and in the variants. */ | |
3308 | ||
3309 | TYPE_FIELDS (t) = fieldlist; | |
3310 | ||
3311 | /* If there are lots of fields, sort so we can look through them fast. | |
3312 | We arbitrarily consider 16 or more elts to be "a lot". */ | |
3313 | { | |
3314 | int len = 0; | |
3315 | ||
3316 | for (x = fieldlist; x; x = TREE_CHAIN (x)) | |
3317 | { | |
3318 | if (len > 15) | |
3319 | break; | |
3320 | len += 1; | |
3321 | } | |
3322 | if (len > 15) | |
3323 | { | |
3324 | tree *field_array; | |
3325 | char *space; | |
3326 | ||
3327 | len += list_length (x); | |
3328 | /* Use the same allocation policy here that make_node uses, to | |
3329 | ensure that this lives as long as the rest of the struct decl. | |
3330 | All decls in an inline function need to be saved. */ | |
3331 | if (allocation_temporary_p ()) | |
3332 | space = savealloc (sizeof (struct lang_type) + len * sizeof (tree)); | |
3333 | else | |
3334 | space = oballoc (sizeof (struct lang_type) + len * sizeof (tree)); | |
3335 | ||
3336 | TYPE_LANG_SPECIFIC (t) = (struct lang_type *) space; | |
3337 | TYPE_LANG_SPECIFIC (t)->foo.rec.len = len; | |
3338 | ||
3339 | field_array = &TYPE_LANG_SPECIFIC (t)->foo.rec.elts[0]; | |
3340 | len = 0; | |
3341 | for (x = fieldlist; x; x = TREE_CHAIN (x)) | |
3342 | field_array[len++] = x; | |
3343 | ||
31029ad7 | 3344 | qsort (field_array, len, sizeof (tree), |
3b0d91ff | 3345 | (int (*) PARAMS ((const void *, const void *))) field_decl_cmp); |
3c79b2da PB |
3346 | } |
3347 | } | |
3348 | ||
3349 | for (x = TYPE_MAIN_VARIANT (t); x; x = TYPE_NEXT_VARIANT (x)) | |
3350 | { | |
3351 | TYPE_FIELDS (x) = TYPE_FIELDS (t); | |
3352 | TYPE_LANG_SPECIFIC (x) = TYPE_LANG_SPECIFIC (t); | |
3353 | TYPE_ALIGN (x) = TYPE_ALIGN (t); | |
3354 | } | |
3355 | ||
3356 | resume_momentary (old_momentary); | |
3357 | ||
3358 | return t; | |
3359 | } | |
3360 | ||
3361 | /* Given a list of fields, FIELDLIST, return a structure | |
3362 | type that contains these fields. The returned type is | |
3363 | always a new type. */ | |
3364 | tree | |
3365 | build_chill_struct_type (fieldlist) | |
3366 | tree fieldlist; | |
3367 | { | |
3368 | register tree t; | |
3369 | ||
3370 | if (fieldlist == NULL_TREE || TREE_CODE (fieldlist) == ERROR_MARK) | |
3371 | return error_mark_node; | |
3372 | ||
3373 | t = make_chill_struct_type (fieldlist); | |
3374 | if (pass != 1) | |
3375 | t = layout_chill_struct_type (t); | |
3376 | ||
3377 | /* pushtag (NULL_TREE, t); */ | |
3378 | ||
3379 | return t; | |
3380 | } | |
3381 | ||
3382 | /* Fix a LANG_TYPE. These are used for three different uses: | |
3383 | - representing a 'READ M' (in which case TYPE_READONLY is set); | |
3384 | - for a NEWMODE or SYNMODE (CH_NOVELTY is set for a NEWMODE); and | |
3385 | - for a parameterised type (TREE_TYPE points to base type, | |
3386 | while TYPE_DOMAIN is the parameter or parameter list). | |
3387 | Called from satisfy. */ | |
3388 | tree | |
3389 | smash_dummy_type (type) | |
3390 | tree type; | |
3391 | { | |
3392 | /* Save fields that we don't want to copy from ORIGIN. */ | |
3393 | tree origin = TREE_TYPE (type); | |
36ef59e7 | 3394 | tree main_tree = TYPE_MAIN_VARIANT (origin); |
3c79b2da PB |
3395 | int save_uid = TYPE_UID (type); |
3396 | struct obstack *save_obstack = TYPE_OBSTACK (type); | |
3397 | tree save_name = TYPE_NAME (type); | |
3398 | int save_permanent = TREE_PERMANENT (type); | |
3399 | int save_readonly = TYPE_READONLY (type); | |
3400 | tree save_novelty = CH_NOVELTY (type); | |
3401 | tree save_domain = TYPE_DOMAIN (type); | |
3c79b2da PB |
3402 | |
3403 | if (origin == NULL_TREE) | |
3404 | abort (); | |
3405 | ||
3406 | if (save_domain) | |
3407 | { | |
3408 | if (TREE_CODE (save_domain) == ERROR_MARK) | |
3409 | return error_mark_node; | |
3410 | if (origin == char_type_node) | |
3411 | { /* Old-fashioned CHAR(N) declaration. */ | |
3412 | origin = build_string_type (origin, save_domain); | |
3413 | } | |
3414 | else | |
3415 | { /* Handle parameterised modes. */ | |
3416 | int is_varying = chill_varying_type_p (origin); | |
3417 | tree new_max = save_domain; | |
3418 | tree origin_novelty = CH_NOVELTY (origin); | |
3419 | if (is_varying) | |
3420 | origin = CH_VARYING_ARRAY_TYPE (origin); | |
3421 | if (CH_STRING_TYPE_P (origin)) | |
3422 | { | |
3423 | tree oldindex = TYPE_DOMAIN (origin); | |
3424 | new_max = check_range (new_max, new_max, NULL_TREE, | |
fed3cef0 RK |
3425 | fold (build (PLUS_EXPR, integer_type_node, |
3426 | TYPE_MAX_VALUE (oldindex), | |
3427 | integer_one_node))); | |
3c79b2da PB |
3428 | origin = build_string_type (TREE_TYPE (origin), new_max); |
3429 | } | |
3430 | else if (TREE_CODE (origin) == ARRAY_TYPE) | |
3431 | { | |
3432 | tree oldindex = TYPE_DOMAIN (origin); | |
3433 | tree upper = check_range (new_max, new_max, NULL_TREE, | |
3434 | TYPE_MAX_VALUE (oldindex)); | |
3435 | tree newindex | |
3436 | = build_chill_range_type (TREE_TYPE (oldindex), | |
3437 | TYPE_MIN_VALUE (oldindex), upper); | |
3438 | origin = build_simple_array_type (TREE_TYPE (origin), newindex, NULL_TREE); | |
3439 | } | |
3440 | else if (TREE_CODE (origin) == RECORD_TYPE) | |
3441 | { | |
3442 | error ("parameterised structures not implemented"); | |
3443 | return error_mark_node; | |
3444 | } | |
3445 | else | |
3446 | { | |
3447 | error ("invalid parameterised type"); | |
3448 | return error_mark_node; | |
3449 | } | |
3450 | ||
3451 | SET_CH_NOVELTY (origin, origin_novelty); | |
3452 | if (is_varying) | |
3453 | { | |
3454 | origin = build_varying_struct (origin); | |
3455 | SET_CH_NOVELTY (origin, origin_novelty); | |
3456 | } | |
3457 | } | |
3458 | save_domain = NULL_TREE; | |
3459 | } | |
3460 | ||
3461 | if (TREE_CODE (origin) == ERROR_MARK) | |
3462 | return error_mark_node; | |
3463 | ||
3464 | *(struct tree_type*)type = *(struct tree_type*)origin; | |
3465 | /* The following is so that the debug code for | |
3466 | the copy is different from the original type. | |
3467 | The two statements usually duplicate each other | |
3468 | (because they clear fields of the same union), | |
3469 | but the optimizer should catch that. */ | |
3470 | TYPE_SYMTAB_POINTER (type) = 0; | |
3471 | TYPE_SYMTAB_ADDRESS (type) = 0; | |
3472 | ||
3473 | /* Restore fields that we didn't want copied from ORIGIN. */ | |
3474 | TYPE_UID (type) = save_uid; | |
3475 | TYPE_OBSTACK (type) = save_obstack; | |
3476 | TREE_PERMANENT (type) = save_permanent; | |
3477 | TYPE_NAME (type) = save_name; | |
3478 | ||
3479 | TREE_CHAIN (type) = NULL_TREE; | |
3480 | TYPE_VOLATILE (type) = 0; | |
3481 | TYPE_POINTER_TO (type) = 0; | |
3482 | TYPE_REFERENCE_TO (type) = 0; | |
3483 | ||
3484 | if (save_readonly) | |
3485 | { /* TYPE is READ ORIGIN. | |
3486 | Add this type to the chain of variants of TYPE. */ | |
36ef59e7 KG |
3487 | TYPE_NEXT_VARIANT (type) = TYPE_NEXT_VARIANT (main_tree); |
3488 | TYPE_NEXT_VARIANT (main_tree) = type; | |
3c79b2da PB |
3489 | TYPE_READONLY (type) = save_readonly; |
3490 | } | |
3491 | else | |
3492 | { | |
3493 | /* TYPE is the copy of the RHS in a NEWMODE or SYNMODE. | |
3494 | We also get here after old-fashioned CHAR(N) declaration (see above). */ | |
3495 | TYPE_MAIN_VARIANT (type) = type; | |
3496 | TYPE_NEXT_VARIANT (type) = NULL_TREE; | |
3497 | if (save_name) | |
3498 | DECL_ORIGINAL_TYPE (save_name) = origin; | |
3499 | ||
3500 | if (save_novelty != NULL_TREE) /* A NEWMODE declaration. */ | |
3501 | { | |
3502 | CH_NOVELTY (type) = save_novelty; | |
3503 | ||
3504 | /* Z.200: "If the DEFINING mode of the NEWMODE name is a range mode, | |
3505 | then the virtual mode &name is introduced as the PARENT mode | |
3506 | of the NEWMODE name. The DEFINING mode of &name is the PARENT | |
3507 | mode of the range mode, and the NOVELTY of &name is that of | |
3508 | the NEWMODE name." */ | |
3509 | ||
3510 | if (TREE_CODE (type) == INTEGER_TYPE && TREE_TYPE (type)) | |
3511 | { | |
3512 | tree parent; | |
3513 | /* PARENT is the virtual mode &name mentioned above. */ | |
3514 | push_obstacks_nochange (); | |
3515 | end_temporary_allocation (); | |
3516 | parent = copy_novelty (save_novelty,TREE_TYPE (type)); | |
3517 | pop_obstacks (); | |
3518 | ||
3519 | TREE_TYPE (type) = parent; | |
3520 | TYPE_MIN_VALUE (type) = convert (parent, TYPE_MIN_VALUE (type)); | |
3521 | TYPE_MAX_VALUE (type) = convert (parent, TYPE_MAX_VALUE (type)); | |
3522 | } | |
3523 | } | |
3524 | } | |
3525 | return type; | |
3526 | } | |
3527 | ||
3528 | /* This generates a LANG_TYPE node that represents 'READ TYPE'. */ | |
3529 | ||
3530 | tree | |
3531 | build_readonly_type (type) | |
3532 | tree type; | |
3533 | { | |
3534 | tree node = make_node (LANG_TYPE); | |
3535 | TREE_TYPE (node) = type; | |
3536 | TYPE_READONLY (node) = 1; | |
3537 | if (pass != 1) | |
3538 | node = smash_dummy_type (node); | |
3539 | return node; | |
3540 | } | |
3541 | ||
3542 | \f | |
3543 | /* Return an unsigned type the same as TYPE in other respects. */ | |
3544 | ||
3545 | tree | |
3546 | unsigned_type (type) | |
3547 | tree type; | |
3548 | { | |
3549 | tree type1 = TYPE_MAIN_VARIANT (type); | |
3550 | if (type1 == signed_char_type_node || type1 == char_type_node) | |
3551 | return unsigned_char_type_node; | |
3552 | if (type1 == integer_type_node) | |
3553 | return unsigned_type_node; | |
3554 | if (type1 == short_integer_type_node) | |
3555 | return short_unsigned_type_node; | |
3556 | if (type1 == long_integer_type_node) | |
3557 | return long_unsigned_type_node; | |
3558 | if (type1 == long_long_integer_type_node) | |
3559 | return long_long_unsigned_type_node; | |
3560 | ||
3561 | return signed_or_unsigned_type (1, type); | |
3562 | } | |
3563 | ||
3564 | /* Return a signed type the same as TYPE in other respects. */ | |
3565 | ||
3566 | tree | |
3567 | signed_type (type) | |
3568 | tree type; | |
3569 | { | |
3570 | tree type1 = TYPE_MAIN_VARIANT (type); | |
3571 | while (TREE_CODE (type1) == INTEGER_TYPE && TREE_TYPE (type1) != NULL_TREE) | |
3572 | type1 = TREE_TYPE (type1); | |
3573 | if (type1 == unsigned_char_type_node || type1 == char_type_node) | |
3574 | return signed_char_type_node; | |
3575 | if (type1 == unsigned_type_node) | |
3576 | return integer_type_node; | |
3577 | if (type1 == short_unsigned_type_node) | |
3578 | return short_integer_type_node; | |
3579 | if (type1 == long_unsigned_type_node) | |
3580 | return long_integer_type_node; | |
3581 | if (type1 == long_long_unsigned_type_node) | |
3582 | return long_long_integer_type_node; | |
3583 | if (TYPE_PRECISION (type1) == 1) | |
3584 | return signed_boolean_type_node; | |
3585 | ||
3586 | return signed_or_unsigned_type (0, type); | |
3587 | } | |
3588 | ||
3589 | /* Return a type the same as TYPE except unsigned or | |
3590 | signed according to UNSIGNEDP. */ | |
3591 | ||
3592 | tree | |
3593 | signed_or_unsigned_type (unsignedp, type) | |
3594 | int unsignedp; | |
3595 | tree type; | |
3596 | { | |
3597 | if (! INTEGRAL_TYPE_P (type) | |
3598 | || TREE_UNSIGNED (type) == unsignedp) | |
3599 | return type; | |
3600 | ||
3601 | if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node)) | |
3602 | return unsignedp ? unsigned_char_type_node : signed_char_type_node; | |
3603 | if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node)) | |
3604 | return unsignedp ? unsigned_type_node : integer_type_node; | |
3605 | if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node)) | |
3606 | return unsignedp ? short_unsigned_type_node : short_integer_type_node; | |
3607 | if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node)) | |
3608 | return unsignedp ? long_unsigned_type_node : long_integer_type_node; | |
3609 | if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node)) | |
3610 | return (unsignedp ? long_long_unsigned_type_node | |
3611 | : long_long_integer_type_node); | |
3612 | return type; | |
3613 | } | |
3614 | \f | |
3615 | /* Mark EXP saying that we need to be able to take the | |
3616 | address of it; it should not be allocated in a register. | |
3617 | Value is 1 if successful. */ | |
3618 | ||
3619 | int | |
3620 | mark_addressable (exp) | |
3621 | tree exp; | |
3622 | { | |
3623 | register tree x = exp; | |
3624 | while (1) | |
3625 | switch (TREE_CODE (x)) | |
3626 | { | |
3627 | case ADDR_EXPR: | |
3628 | case COMPONENT_REF: | |
3629 | case ARRAY_REF: | |
3630 | case REALPART_EXPR: | |
3631 | case IMAGPART_EXPR: | |
3632 | x = TREE_OPERAND (x, 0); | |
3633 | break; | |
3634 | ||
3635 | case TRUTH_ANDIF_EXPR: | |
3636 | case TRUTH_ORIF_EXPR: | |
3637 | case COMPOUND_EXPR: | |
3638 | x = TREE_OPERAND (x, 1); | |
3639 | break; | |
3640 | ||
3641 | case COND_EXPR: | |
3642 | return mark_addressable (TREE_OPERAND (x, 1)) | |
3643 | & mark_addressable (TREE_OPERAND (x, 2)); | |
3644 | ||
3645 | case CONSTRUCTOR: | |
3646 | TREE_ADDRESSABLE (x) = 1; | |
3647 | return 1; | |
3648 | ||
3649 | case INDIRECT_REF: | |
3650 | /* We sometimes add a cast *(TYPE*)&FOO to handle type and mode | |
3651 | incompatibility problems. Handle this case by marking FOO. */ | |
3652 | if (TREE_CODE (TREE_OPERAND (x, 0)) == NOP_EXPR | |
3653 | && TREE_CODE (TREE_OPERAND (TREE_OPERAND (x, 0), 0)) == ADDR_EXPR) | |
3654 | { | |
3655 | x = TREE_OPERAND (TREE_OPERAND (x, 0), 0); | |
3656 | break; | |
3657 | } | |
3658 | if (TREE_CODE (TREE_OPERAND (x, 0)) == ADDR_EXPR) | |
3659 | { | |
3660 | x = TREE_OPERAND (x, 0); | |
3661 | break; | |
3662 | } | |
3663 | return 1; | |
3664 | ||
3665 | case VAR_DECL: | |
3666 | case CONST_DECL: | |
3667 | case PARM_DECL: | |
3668 | case RESULT_DECL: | |
3669 | if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) | |
3670 | && DECL_NONLOCAL (x)) | |
3671 | { | |
3672 | if (TREE_PUBLIC (x)) | |
3673 | { | |
3674 | error ("global register variable `%s' used in nested function", | |
3675 | IDENTIFIER_POINTER (DECL_NAME (x))); | |
3676 | return 0; | |
3677 | } | |
3678 | pedwarn ("register variable `%s' used in nested function", | |
3679 | IDENTIFIER_POINTER (DECL_NAME (x))); | |
3680 | } | |
3681 | else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)) | |
3682 | { | |
3683 | if (TREE_PUBLIC (x)) | |
3684 | { | |
3685 | error ("address of global register variable `%s' requested", | |
3686 | IDENTIFIER_POINTER (DECL_NAME (x))); | |
3687 | return 0; | |
3688 | } | |
3689 | ||
3690 | /* If we are making this addressable due to its having | |
3691 | volatile components, give a different error message. Also | |
3692 | handle the case of an unnamed parameter by not trying | |
3693 | to give the name. */ | |
3694 | ||
3695 | else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x))) | |
3696 | { | |
3697 | error ("cannot put object with volatile field into register"); | |
3698 | return 0; | |
3699 | } | |
3700 | ||
3701 | pedwarn ("address of register variable `%s' requested", | |
3702 | IDENTIFIER_POINTER (DECL_NAME (x))); | |
3703 | } | |
3704 | put_var_into_stack (x); | |
3705 | ||
3706 | /* drops through */ | |
3707 | case FUNCTION_DECL: | |
3708 | TREE_ADDRESSABLE (x) = 1; | |
3709 | #if 0 /* poplevel deals with this now. */ | |
3710 | if (DECL_CONTEXT (x) == 0) | |
3711 | TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1; | |
3712 | #endif | |
3713 | /* drops through */ | |
3714 | default: | |
3715 | return 1; | |
3716 | } | |
3717 | } | |
3718 | \f | |
3c79b2da PB |
3719 | /* Return an integer type with BITS bits of precision, |
3720 | that is unsigned if UNSIGNEDP is nonzero, otherwise signed. */ | |
3721 | ||
3722 | tree | |
3723 | type_for_size (bits, unsignedp) | |
3724 | unsigned bits; | |
3725 | int unsignedp; | |
3726 | { | |
3727 | if (bits == TYPE_PRECISION (integer_type_node)) | |
3728 | return unsignedp ? unsigned_type_node : integer_type_node; | |
3729 | ||
3730 | if (bits == TYPE_PRECISION (signed_char_type_node)) | |
3731 | return unsignedp ? unsigned_char_type_node : signed_char_type_node; | |
3732 | ||
3733 | if (bits == TYPE_PRECISION (short_integer_type_node)) | |
3734 | return unsignedp ? short_unsigned_type_node : short_integer_type_node; | |
3735 | ||
3736 | if (bits == TYPE_PRECISION (long_integer_type_node)) | |
3737 | return unsignedp ? long_unsigned_type_node : long_integer_type_node; | |
3738 | ||
3739 | if (bits == TYPE_PRECISION (long_long_integer_type_node)) | |
3740 | return (unsignedp ? long_long_unsigned_type_node | |
3741 | : long_long_integer_type_node); | |
3742 | ||
3743 | if (bits <= TYPE_PRECISION (intQI_type_node)) | |
3744 | return unsignedp ? unsigned_intQI_type_node : intQI_type_node; | |
3745 | ||
3746 | if (bits <= TYPE_PRECISION (intHI_type_node)) | |
3747 | return unsignedp ? unsigned_intHI_type_node : intHI_type_node; | |
3748 | ||
3749 | if (bits <= TYPE_PRECISION (intSI_type_node)) | |
3750 | return unsignedp ? unsigned_intSI_type_node : intSI_type_node; | |
3751 | ||
3752 | if (bits <= TYPE_PRECISION (intDI_type_node)) | |
3753 | return unsignedp ? unsigned_intDI_type_node : intDI_type_node; | |
3754 | ||
e39b138b | 3755 | #if HOST_BITS_PER_WIDE_INT >= 64 |
3c79b2da PB |
3756 | if (bits <= TYPE_PRECISION (intTI_type_node)) |
3757 | return unsignedp ? unsigned_intTI_type_node : intTI_type_node; | |
e39b138b | 3758 | #endif |
3c79b2da PB |
3759 | |
3760 | return 0; | |
3761 | } | |
3762 | ||
3763 | /* Return a data type that has machine mode MODE. | |
3764 | If the mode is an integer, | |
3765 | then UNSIGNEDP selects between signed and unsigned types. */ | |
3766 | ||
3767 | tree | |
3768 | type_for_mode (mode, unsignedp) | |
3769 | enum machine_mode mode; | |
3770 | int unsignedp; | |
3771 | { | |
ed730bcf | 3772 | if ((int)mode == (int)TYPE_MODE (integer_type_node)) |
3c79b2da PB |
3773 | return unsignedp ? unsigned_type_node : integer_type_node; |
3774 | ||
ed730bcf | 3775 | if ((int)mode == (int)TYPE_MODE (signed_char_type_node)) |
3c79b2da PB |
3776 | return unsignedp ? unsigned_char_type_node : signed_char_type_node; |
3777 | ||
ed730bcf | 3778 | if ((int)mode == (int)TYPE_MODE (short_integer_type_node)) |
3c79b2da PB |
3779 | return unsignedp ? short_unsigned_type_node : short_integer_type_node; |
3780 | ||
ed730bcf | 3781 | if ((int)mode == (int)TYPE_MODE (long_integer_type_node)) |
3c79b2da PB |
3782 | return unsignedp ? long_unsigned_type_node : long_integer_type_node; |
3783 | ||
ed730bcf | 3784 | if ((int)mode == (int)TYPE_MODE (long_long_integer_type_node)) |
3c79b2da PB |
3785 | return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node; |
3786 | ||
ed730bcf | 3787 | if ((int)mode == (int)TYPE_MODE (intQI_type_node)) |
3c79b2da PB |
3788 | return unsignedp ? unsigned_intQI_type_node : intQI_type_node; |
3789 | ||
ed730bcf | 3790 | if ((int)mode == (int)TYPE_MODE (intHI_type_node)) |
3c79b2da PB |
3791 | return unsignedp ? unsigned_intHI_type_node : intHI_type_node; |
3792 | ||
ed730bcf | 3793 | if ((int)mode == (int)TYPE_MODE (intSI_type_node)) |
3c79b2da PB |
3794 | return unsignedp ? unsigned_intSI_type_node : intSI_type_node; |
3795 | ||
ed730bcf | 3796 | if ((int)mode == (int)TYPE_MODE (intDI_type_node)) |
3c79b2da PB |
3797 | return unsignedp ? unsigned_intDI_type_node : intDI_type_node; |
3798 | ||
e39b138b | 3799 | #if HOST_BITS_PER_WIDE_INT >= 64 |
ed730bcf | 3800 | if ((int)mode == (int)TYPE_MODE (intTI_type_node)) |
3c79b2da | 3801 | return unsignedp ? unsigned_intTI_type_node : intTI_type_node; |
e39b138b | 3802 | #endif |
3c79b2da | 3803 | |
ed730bcf | 3804 | if ((int)mode == (int)TYPE_MODE (float_type_node)) |
3c79b2da PB |
3805 | return float_type_node; |
3806 | ||
ed730bcf | 3807 | if ((int)mode == (int)TYPE_MODE (double_type_node)) |
3c79b2da PB |
3808 | return double_type_node; |
3809 | ||
ed730bcf | 3810 | if ((int)mode == (int)TYPE_MODE (long_double_type_node)) |
3c79b2da PB |
3811 | return long_double_type_node; |
3812 | ||
ed730bcf | 3813 | if ((int)mode == (int)TYPE_MODE (build_pointer_type (char_type_node))) |
3c79b2da PB |
3814 | return build_pointer_type (char_type_node); |
3815 | ||
ed730bcf | 3816 | if ((int)mode == (int)TYPE_MODE (build_pointer_type (integer_type_node))) |
3c79b2da PB |
3817 | return build_pointer_type (integer_type_node); |
3818 | ||
3819 | return 0; | |
3820 | } |