]>
gcc.gnu.org Git - gcc.git/blob - gcc/fortran/data.c
1 /* Supporting functions for resolving DATA statement.
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Lifang Zeng <zlf605@hotmail.com>
5 This file is part of GCC.
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330,Boston, MA
23 /* Notes for DATA statement implementation:
25 We first assign initial value to each symbol by gfc_assign_data_value
26 during resolveing DATA statement. Refer to check_data_variable and
27 traverse_data_list in resolve.c.
29 The complexity exists in the handleing of array section, implied do
30 and array of struct appeared in DATA statement.
32 We call gfc_conv_structure, gfc_con_array_array_initializer,
33 etc., to convert the initial value. Refer to trans-expr.c and
40 static void formalize_init_expr (gfc_expr
*);
42 /* Calculate the array element offset. */
45 get_array_index (gfc_array_ref
* ar
, mpz_t
* offset
)
54 mpz_set_si (*offset
, 0);
55 mpz_init_set_si (delta
, 1);
56 for (i
= 0; i
< ar
->dimen
; i
++)
58 e
= gfc_copy_expr (ar
->start
[i
]);
59 re
= gfc_simplify_expr (e
, 1);
61 if ((gfc_is_constant_expr (ar
->as
->lower
[i
]) == 0)
62 || (gfc_is_constant_expr (ar
->as
->upper
[i
]) == 0)
63 || (gfc_is_constant_expr (e
) == 0))
64 gfc_error ("non-constant array in DATA statement %L.", &ar
->where
);
65 mpz_set (tmp
, e
->value
.integer
);
66 mpz_sub (tmp
, tmp
, ar
->as
->lower
[i
]->value
.integer
);
67 mpz_mul (tmp
, tmp
, delta
);
68 mpz_add (*offset
, tmp
, *offset
);
70 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
71 ar
->as
->lower
[i
]->value
.integer
);
72 mpz_add_ui (tmp
, tmp
, 1);
73 mpz_mul (delta
, tmp
, delta
);
80 /* Find if there is a constructor which offset is equal to OFFSET. */
82 static gfc_constructor
*
83 find_con_by_offset (mpz_t offset
, gfc_constructor
*con
)
85 for (; con
; con
= con
->next
)
87 if (mpz_cmp (offset
, con
->n
.offset
) == 0)
94 /* Find if there is a constructor which component is equal to COM. */
96 static gfc_constructor
*
97 find_con_by_component (gfc_component
*com
, gfc_constructor
*con
)
99 for (; con
; con
= con
->next
)
101 if (com
== con
->n
.component
)
107 /* Assign RVALUE to LVALUE where we assume that LVALUE is a substring
108 reference. We do a little more than that: if LVALUE already has an
109 initialization, we put RVALUE into the existing initialization as
110 per the rules of assignment to a substring. If LVALUE has no
111 initialization yet, we initialize it to all blanks, then filling in
115 assign_substring_data_value (gfc_expr
* lvalue
, gfc_expr
* rvalue
)
118 gfc_expr
*expr
, *init
;
124 symbol
= lvalue
->symtree
->n
.sym
;
126 init
= symbol
->value
;
128 assert (symbol
->ts
.type
== BT_CHARACTER
);
129 assert (symbol
->ts
.cl
->length
->expr_type
== EXPR_CONSTANT
);
130 assert (symbol
->ts
.cl
->length
->ts
.type
== BT_INTEGER
);
131 assert (symbol
->ts
.kind
== 1);
133 gfc_extract_int (symbol
->ts
.cl
->length
, &len
);
137 /* Setup the expression to hold the constructor. */
138 expr
= gfc_get_expr ();
139 expr
->expr_type
= EXPR_CONSTANT
;
140 expr
->ts
.type
= BT_CHARACTER
;
143 expr
->value
.character
.length
= len
;
144 expr
->value
.character
.string
= gfc_getmem (len
);
145 memset (expr
->value
.character
.string
, ' ', len
);
147 symbol
->value
= expr
;
152 /* Now that we have allocated the memory for the string,
153 fill in the initialized places, truncating the
154 intialization string if necessary, i.e.
156 doesn't initialize a(3:3). */
158 gfc_extract_int (ref
->u
.ss
.start
, &start
);
159 gfc_extract_int (ref
->u
.ss
.end
, &end
);
164 len
= rvalue
->value
.character
.length
;
165 c
= rvalue
->value
.character
.string
;
166 d
= &expr
->value
.character
.string
[start
- 1];
168 for (i
= 0; i
<= end
- start
&& i
< len
; i
++)
171 /* Pad with spaces. I.e.
173 intializes a(1:2) to 'a ' per the rules for assignment.
174 If init == NULL we don't need to do this, as we have
175 intialized the whole string to blanks above. */
178 for (; i
<= end
- start
; i
++)
184 /* Assign the initial value RVALUE to LVALUE's symbol->value. If the
185 LVALUE already has an initialization, we extend this, otherwise we
189 gfc_assign_data_value (gfc_expr
* lvalue
, gfc_expr
* rvalue
, mpz_t index
)
194 gfc_constructor
*con
;
195 gfc_constructor
*last_con
;
200 if (ref
!= NULL
&& ref
->type
== REF_SUBSTRING
)
202 /* No need to go through the for (; ref; ref->next) loop, since
203 a single substring lvalue will only refer to a single
204 substring, and therefore ref->next == NULL. */
205 assert (ref
->next
== NULL
);
206 assign_substring_data_value (lvalue
, rvalue
);
210 symbol
= lvalue
->symtree
->n
.sym
;
211 init
= symbol
->value
;
213 mpz_init_set_si (offset
, 0);
215 for (; ref
; ref
= ref
->next
)
217 /* Use the existing initializer expression if it exists. Otherwise
220 expr
= gfc_get_expr ();
224 /* Find or create this element. */
230 /* Setup the expression to hold the constructor. */
231 expr
->expr_type
= EXPR_ARRAY
;
234 assert (ref
->next
->type
== REF_COMPONENT
);
235 expr
->ts
.type
= BT_DERIVED
;
238 expr
->ts
= rvalue
->ts
;
239 expr
->rank
= ref
->u
.ar
.as
->rank
;
242 assert (expr
->expr_type
== EXPR_ARRAY
);
244 if (ref
->u
.ar
.type
== AR_ELEMENT
)
245 get_array_index (&ref
->u
.ar
, &offset
);
247 mpz_set (offset
, index
);
249 /* Find the same element in the existing constructor. */
250 con
= expr
->value
.constructor
;
251 con
= find_con_by_offset (offset
, con
);
255 /* Create a new constructor. */
256 con
= gfc_get_constructor();
257 mpz_set (con
->n
.offset
, offset
);
258 gfc_insert_constructor (expr
, con
);
265 /* Setup the expression to hold the constructor. */
266 expr
->expr_type
= EXPR_STRUCTURE
;
267 expr
->ts
.type
= BT_DERIVED
;
268 expr
->ts
.derived
= ref
->u
.c
.sym
;
271 assert (expr
->expr_type
== EXPR_STRUCTURE
);
273 /* Find the same element in the existing constructor. */
274 con
= expr
->value
.constructor
;
275 con
= find_con_by_component (ref
->u
.c
.component
, con
);
279 /* Create a new constructor. */
280 con
= gfc_get_constructor ();
281 con
->n
.component
= ref
->u
.c
.component
;
282 con
->next
= expr
->value
.constructor
;
283 expr
->value
.constructor
= con
;
287 /* case REF_SUBSTRING: dealt with separately above. */
295 /* Point the container at the new expression. */
296 if (last_con
== NULL
)
297 symbol
->value
= expr
;
299 last_con
->expr
= expr
;
305 expr
= gfc_copy_expr (rvalue
);
306 if (!gfc_compare_types (&lvalue
->ts
, &expr
->ts
))
307 gfc_convert_type (expr
, &lvalue
->ts
, 0);
309 if (last_con
== NULL
)
310 symbol
->value
= expr
;
313 assert (!last_con
->expr
);
314 last_con
->expr
= expr
;
319 /* Modify the index of array section and re-calculate the array offset. */
322 gfc_advance_section (mpz_t
*section_index
, gfc_array_ref
*ar
,
331 for (i
= 0; i
< ar
->dimen
; i
++)
333 if (ar
->dimen_type
[i
] != DIMEN_RANGE
)
338 mpz_add (section_index
[i
], section_index
[i
],
339 ar
->stride
[i
]->value
.integer
);
340 if (mpz_cmp_si (ar
->stride
[i
]->value
.integer
, 0) >= 0)
347 mpz_add_ui (section_index
[i
], section_index
[i
], 1);
352 cmp
= mpz_cmp (section_index
[i
], ar
->end
[i
]->value
.integer
);
354 cmp
= mpz_cmp (section_index
[i
], ar
->as
->upper
[i
]->value
.integer
);
356 if ((cmp
> 0 && forwards
)
357 || (cmp
< 0 && ! forwards
))
359 /* Reset index to start, then loop to advance the next index. */
361 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
363 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
369 mpz_set_si (*offset_ret
, 0);
370 mpz_init_set_si (delta
, 1);
372 for (i
= 0; i
< ar
->dimen
; i
++)
374 mpz_sub (tmp
, section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
375 mpz_mul (tmp
, tmp
, delta
);
376 mpz_add (*offset_ret
, tmp
, *offset_ret
);
378 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
379 ar
->as
->lower
[i
]->value
.integer
);
380 mpz_add_ui (tmp
, tmp
, 1);
381 mpz_mul (delta
, tmp
, delta
);
388 /* Rearrange a structure constructor so the elements are in the specified
389 order. Also insert NULL entries if neccessary. */
392 formalize_structure_cons (gfc_expr
* expr
)
394 gfc_constructor
*head
;
395 gfc_constructor
*tail
;
396 gfc_constructor
*cur
;
397 gfc_constructor
*last
;
399 gfc_component
*order
;
401 c
= expr
->value
.constructor
;
403 /* Constructor is already fomalized. */
404 if (c
->n
.component
== NULL
)
408 for (order
= expr
->ts
.derived
->components
; order
; order
= order
->next
)
410 /* Find the next component. */
413 while (cur
!= NULL
&& cur
->n
.component
!= order
)
421 /* Create a new one. */
422 cur
= gfc_get_constructor ();
426 /* Remove it from the chain. */
430 last
->next
= cur
->next
;
433 formalize_init_expr (cur
->expr
);
436 /* Add it to the new constructor. */
446 expr
->value
.constructor
= head
;
450 /* Make sure an initialization expression is in normalized form. Ie. all
451 elements of the constructors are in the correct order. */
454 formalize_init_expr (gfc_expr
* expr
)
462 type
= expr
->expr_type
;
466 c
= expr
->value
.constructor
;
469 formalize_init_expr (c
->expr
);
475 formalize_structure_cons (expr
);
484 /* Resolve symbol's initial value after all data statement. */
487 gfc_formalize_init_value (gfc_symbol
*sym
)
489 formalize_init_expr (sym
->value
);
493 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
497 gfc_get_section_index (gfc_array_ref
*ar
, mpz_t
*section_index
, mpz_t
*offset
)
503 mpz_set_si (*offset
, 0);
505 mpz_init_set_si (delta
, 1);
506 for (i
= 0; i
< ar
->dimen
; i
++)
508 mpz_init (section_index
[i
]);
509 switch (ar
->dimen_type
[i
])
515 mpz_sub (tmp
, ar
->start
[i
]->value
.integer
,
516 ar
->as
->lower
[i
]->value
.integer
);
517 mpz_mul (tmp
, tmp
, delta
);
518 mpz_add (*offset
, tmp
, *offset
);
519 mpz_set (section_index
[i
], ar
->start
[i
]->value
.integer
);
522 mpz_set (section_index
[i
], ar
->as
->lower
[i
]->value
.integer
);
526 gfc_internal_error ("TODO: Vector sections in data statements");
532 mpz_sub (tmp
, ar
->as
->upper
[i
]->value
.integer
,
533 ar
->as
->lower
[i
]->value
.integer
);
534 mpz_add_ui (tmp
, tmp
, 1);
535 mpz_mul (delta
, tmp
, delta
);
This page took 0.063411 seconds and 5 git commands to generate.