OSDN Git Service

6829fe9cd03f631255992bcf9c812907532945c1
[pf3gnuchains/gcc-fork.git] / gcc / fortran / data.c
1 /* Supporting functions for resolving DATA statement.
2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3    Free Software Foundation, Inc.
4    Contributed by Lifang Zeng <zlf605@hotmail.com>
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22
23 /* Notes for DATA statement implementation:
24                                                                                
25    We first assign initial value to each symbol by gfc_assign_data_value
26    during resolving DATA statement. Refer to check_data_variable and
27    traverse_data_list in resolve.c.
28                                                                                
29    The complexity exists in the handling of array section, implied do
30    and array of struct appeared in DATA statement.
31                                                                                
32    We call gfc_conv_structure, gfc_con_array_array_initializer,
33    etc., to convert the initial value. Refer to trans-expr.c and
34    trans-array.c.  */
35
36 #include "config.h"
37 #include "system.h"
38 #include "gfortran.h"
39 #include "data.h"
40 #include "constructor.h"
41
42 static void formalize_init_expr (gfc_expr *);
43
44 /* Calculate the array element offset.  */
45
46 static void
47 get_array_index (gfc_array_ref *ar, mpz_t *offset)
48 {
49   gfc_expr *e;
50   int i;
51   mpz_t delta;
52   mpz_t tmp;
53
54   mpz_init (tmp);
55   mpz_set_si (*offset, 0);
56   mpz_init_set_si (delta, 1);
57   for (i = 0; i < ar->dimen; i++)
58     {
59       e = gfc_copy_expr (ar->start[i]);
60       gfc_simplify_expr (e, 1);
61
62       if ((gfc_is_constant_expr (ar->as->lower[i]) == 0)
63           || (gfc_is_constant_expr (ar->as->upper[i]) == 0)
64           || (gfc_is_constant_expr (e) == 0))
65         gfc_error ("non-constant array in DATA statement %L", &ar->where);
66
67       mpz_set (tmp, e->value.integer);
68       mpz_sub (tmp, tmp, ar->as->lower[i]->value.integer);
69       mpz_mul (tmp, tmp, delta);
70       mpz_add (*offset, tmp, *offset);
71
72       mpz_sub (tmp, ar->as->upper[i]->value.integer,
73                ar->as->lower[i]->value.integer);
74       mpz_add_ui (tmp, tmp, 1);
75       mpz_mul (delta, tmp, delta);
76     }
77   mpz_clear (delta);
78   mpz_clear (tmp);
79 }
80
81 /* Find if there is a constructor which component is equal to COM.
82    TODO: remove this, use symbol.c(gfc_find_component) instead.  */
83
84 static gfc_constructor *
85 find_con_by_component (gfc_component *com, gfc_constructor_base base)
86 {
87   gfc_constructor *c;
88
89   for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
90     if (com == c->n.component)
91       return c;
92
93   return NULL;
94 }
95
96
97 /* Create a character type initialization expression from RVALUE.
98    TS [and REF] describe [the substring of] the variable being initialized.
99    INIT is the existing initializer, not NULL.  Initialization is performed
100    according to normal assignment rules.  */
101
102 static gfc_expr *
103 create_character_intializer (gfc_expr *init, gfc_typespec *ts,
104                              gfc_ref *ref, gfc_expr *rvalue)
105 {
106   int len, start, end;
107   gfc_char_t *dest;
108             
109   gfc_extract_int (ts->u.cl->length, &len);
110
111   if (init == NULL)
112     {
113       /* Create a new initializer.  */
114       init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
115       init->ts = *ts;
116     }
117
118   dest = init->value.character.string;
119
120   if (ref)
121     {
122       gfc_expr *start_expr, *end_expr;
123
124       gcc_assert (ref->type == REF_SUBSTRING);
125
126       /* Only set a substring of the destination.  Fortran substring bounds
127          are one-based [start, end], we want zero based [start, end).  */
128       start_expr = gfc_copy_expr (ref->u.ss.start);
129       end_expr = gfc_copy_expr (ref->u.ss.end);
130
131       if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
132           || (gfc_simplify_expr (end_expr, 1)) == FAILURE)
133         {
134           gfc_error ("failure to simplify substring reference in DATA "
135                      "statement at %L", &ref->u.ss.start->where);
136           return NULL;
137         }
138
139       gfc_extract_int (start_expr, &start);
140       start--;
141       gfc_extract_int (end_expr, &end);
142     }
143   else
144     {
145       /* Set the whole string.  */
146       start = 0;
147       end = len;
148     }
149
150   /* Copy the initial value.  */
151   if (rvalue->ts.type == BT_HOLLERITH)
152     len = rvalue->representation.length;
153   else
154     len = rvalue->value.character.length;
155
156   if (len > end - start)
157     {
158       gfc_warning_now ("Initialization string starting at %L was "
159                        "truncated to fit the variable (%d/%d)",
160                        &rvalue->where, end - start, len);
161       len = end - start;
162     }
163
164   if (rvalue->ts.type == BT_HOLLERITH)
165     {
166       int i;
167       for (i = 0; i < len; i++)
168         dest[start+i] = rvalue->representation.string[i];
169     }
170   else
171     memcpy (&dest[start], rvalue->value.character.string,
172             len * sizeof (gfc_char_t));
173
174   /* Pad with spaces.  Substrings will already be blanked.  */
175   if (len < end - start && ref == NULL)
176     gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
177
178   if (rvalue->ts.type == BT_HOLLERITH)
179     {
180       init->representation.length = init->value.character.length;
181       init->representation.string
182         = gfc_widechar_to_char (init->value.character.string,
183                                 init->value.character.length);
184     }
185
186   return init;
187 }
188
189
190 /* Assign the initial value RVALUE to  LVALUE's symbol->value. If the
191    LVALUE already has an initialization, we extend this, otherwise we
192    create a new one.  */
193
194 gfc_try
195 gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
196 {
197   gfc_ref *ref;
198   gfc_expr *init;
199   gfc_expr *expr;
200   gfc_constructor *con;
201   gfc_constructor *last_con;
202   gfc_symbol *symbol;
203   gfc_typespec *last_ts;
204   mpz_t offset;
205
206   symbol = lvalue->symtree->n.sym;
207   init = symbol->value;
208   last_ts = &symbol->ts;
209   last_con = NULL;
210   mpz_init_set_si (offset, 0);
211
212   /* Find/create the parent expressions for subobject references.  */
213   for (ref = lvalue->ref; ref; ref = ref->next)
214     {
215       /* Break out of the loop if we find a substring.  */
216       if (ref->type == REF_SUBSTRING)
217         {
218           /* A substring should always be the last subobject reference.  */
219           gcc_assert (ref->next == NULL);
220           break;
221         }
222
223       /* Use the existing initializer expression if it exists.  Otherwise
224          create a new one.  */
225       if (init == NULL)
226         expr = gfc_get_expr ();
227       else
228         expr = init;
229
230       /* Find or create this element.  */
231       switch (ref->type)
232         {
233         case REF_ARRAY:
234           if (ref->u.ar.as->rank == 0)
235             {
236               gcc_assert (ref->u.ar.as->corank > 0);
237               if (init == NULL)
238                 gfc_free (expr);
239               continue;
240             }
241
242           if (init && expr->expr_type != EXPR_ARRAY)
243             {
244               gfc_error ("'%s' at %L already is initialized at %L",
245                          lvalue->symtree->n.sym->name, &lvalue->where,
246                          &init->where);
247               goto abort;
248             }
249
250           if (init == NULL)
251             {
252               /* The element typespec will be the same as the array
253                  typespec.  */
254               expr->ts = *last_ts;
255               /* Setup the expression to hold the constructor.  */
256               expr->expr_type = EXPR_ARRAY;
257               expr->rank = ref->u.ar.as->rank;
258             }
259
260           if (ref->u.ar.type == AR_ELEMENT)
261             get_array_index (&ref->u.ar, &offset);
262           else
263             mpz_set (offset, index);
264
265           /* Check the bounds.  */
266           if (mpz_cmp_si (offset, 0) < 0)
267             {
268               gfc_error ("Data element below array lower bound at %L",
269                          &lvalue->where);
270               goto abort;
271             }
272           else
273             {
274               mpz_t size;
275               if (spec_size (ref->u.ar.as, &size) == SUCCESS)
276                 {
277                   if (mpz_cmp (offset, size) >= 0)
278                     {
279                       mpz_clear (size);
280                       gfc_error ("Data element above array upper bound at %L",
281                                  &lvalue->where);
282                       goto abort;
283                     }
284                   mpz_clear (size);
285                 }
286             }
287
288           con = gfc_constructor_lookup (expr->value.constructor,
289                                         mpz_get_si (offset));
290           if (!con)
291             {
292               con = gfc_constructor_insert_expr (&expr->value.constructor,
293                                                  NULL, &rvalue->where,
294                                                  mpz_get_si (offset));
295             }
296           break;
297
298         case REF_COMPONENT:
299           if (init == NULL)
300             {
301               /* Setup the expression to hold the constructor.  */
302               expr->expr_type = EXPR_STRUCTURE;
303               expr->ts.type = BT_DERIVED;
304               expr->ts.u.derived = ref->u.c.sym;
305             }
306           else
307             gcc_assert (expr->expr_type == EXPR_STRUCTURE);
308           last_ts = &ref->u.c.component->ts;
309
310           /* Find the same element in the existing constructor.  */
311           con = find_con_by_component (ref->u.c.component,
312                                        expr->value.constructor);
313
314           if (con == NULL)
315             {
316               /* Create a new constructor.  */
317               con = gfc_constructor_append_expr (&expr->value.constructor,
318                                                  NULL, NULL);
319               con->n.component = ref->u.c.component;
320             }
321           break;
322
323         default:
324           gcc_unreachable ();
325         }
326
327       if (init == NULL)
328         {
329           /* Point the container at the new expression.  */
330           if (last_con == NULL)
331             symbol->value = expr;
332           else
333             last_con->expr = expr;
334         }
335       init = con->expr;
336       last_con = con;
337     }
338
339   mpz_clear (offset);
340
341   if (ref || last_ts->type == BT_CHARACTER)
342     {
343       if (lvalue->ts.u.cl->length == NULL && !(ref && ref->u.ss.length != NULL))
344         return FAILURE;
345       expr = create_character_intializer (init, last_ts, ref, rvalue);
346     }
347   else
348     {
349       /* Overwriting an existing initializer is non-standard but usually only
350          provokes a warning from other compilers.  */
351       if (init != NULL)
352         {
353           /* Order in which the expressions arrive here depends on whether
354              they are from data statements or F95 style declarations.
355              Therefore, check which is the most recent.  */
356           expr = (LOCATION_LINE (init->where.lb->location)
357                   > LOCATION_LINE (rvalue->where.lb->location))
358                ? init : rvalue;
359           if (gfc_notify_std (GFC_STD_GNU,"Extension: "
360                               "re-initialization of '%s' at %L",
361                               symbol->name, &expr->where) == FAILURE)
362             return FAILURE;
363         }
364
365       expr = gfc_copy_expr (rvalue);
366       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
367         gfc_convert_type (expr, &lvalue->ts, 0);
368     }
369
370   if (last_con == NULL)
371     symbol->value = expr;
372   else
373     last_con->expr = expr;
374
375   return SUCCESS;
376
377 abort:
378   mpz_clear (offset);
379   return FAILURE;
380 }
381
382
383 /* Similarly, but initialize REPEAT consecutive values in LVALUE the same
384    value in RVALUE.  */
385
386 gfc_try
387 gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
388                              mpz_t index, mpz_t repeat)
389 {
390   mpz_t offset, last_offset;
391   gfc_try t;
392
393   mpz_init (offset);
394   mpz_init (last_offset);
395   mpz_add (last_offset, index, repeat);
396
397   t = SUCCESS;
398   for (mpz_set(offset, index) ; mpz_cmp(offset, last_offset) < 0;
399                    mpz_add_ui (offset, offset, 1))
400     if (gfc_assign_data_value (lvalue, rvalue, offset) == FAILURE)
401       {
402         t = FAILURE;
403         break;
404       }
405
406   mpz_clear (offset);
407   mpz_clear (last_offset);
408
409   return t;
410 }
411
412
413 /* Modify the index of array section and re-calculate the array offset.  */
414
415 void 
416 gfc_advance_section (mpz_t *section_index, gfc_array_ref *ar,
417                      mpz_t *offset_ret)
418 {
419   int i;
420   mpz_t delta;
421   mpz_t tmp; 
422   bool forwards;
423   int cmp;
424
425   for (i = 0; i < ar->dimen; i++)
426     {
427       if (ar->dimen_type[i] != DIMEN_RANGE)
428         continue;
429
430       if (ar->stride[i])
431         {
432           mpz_add (section_index[i], section_index[i],
433                    ar->stride[i]->value.integer);
434         if (mpz_cmp_si (ar->stride[i]->value.integer, 0) >= 0)
435           forwards = true;
436         else
437           forwards = false;
438         }
439       else
440         {
441           mpz_add_ui (section_index[i], section_index[i], 1);
442           forwards = true;
443         }
444       
445       if (ar->end[i])
446         cmp = mpz_cmp (section_index[i], ar->end[i]->value.integer);
447       else
448         cmp = mpz_cmp (section_index[i], ar->as->upper[i]->value.integer);
449
450       if ((cmp > 0 && forwards) || (cmp < 0 && !forwards))
451         {
452           /* Reset index to start, then loop to advance the next index.  */
453           if (ar->start[i])
454             mpz_set (section_index[i], ar->start[i]->value.integer);
455           else
456             mpz_set (section_index[i], ar->as->lower[i]->value.integer);
457         }
458       else
459         break;
460     }
461
462   mpz_set_si (*offset_ret, 0);
463   mpz_init_set_si (delta, 1);
464   mpz_init (tmp);
465   for (i = 0; i < ar->dimen; i++)
466     {
467       mpz_sub (tmp, section_index[i], ar->as->lower[i]->value.integer);
468       mpz_mul (tmp, tmp, delta);
469       mpz_add (*offset_ret, tmp, *offset_ret);
470
471       mpz_sub (tmp, ar->as->upper[i]->value.integer, 
472                ar->as->lower[i]->value.integer);
473       mpz_add_ui (tmp, tmp, 1);
474       mpz_mul (delta, tmp, delta);
475     }
476   mpz_clear (tmp);
477   mpz_clear (delta);
478 }
479
480
481 /* Rearrange a structure constructor so the elements are in the specified
482    order.  Also insert NULL entries if necessary.  */
483
484 static void
485 formalize_structure_cons (gfc_expr *expr)
486 {
487   gfc_constructor_base base = NULL;
488   gfc_constructor *cur;
489   gfc_component *order;
490
491   /* Constructor is already formalized.  */
492   cur = gfc_constructor_first (expr->value.constructor);
493   if (!cur || cur->n.component == NULL)
494     return;
495
496   for (order = expr->ts.u.derived->components; order; order = order->next)
497     {
498       cur = find_con_by_component (order, expr->value.constructor);
499       if (cur)
500         gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
501       else
502         gfc_constructor_append_expr (&base, NULL, NULL);
503     }
504
505   /* For all what it's worth, one would expect
506        gfc_constructor_free (expr->value.constructor);
507      here. However, if the constructor is actually free'd,
508      hell breaks loose in the testsuite?!  */
509
510   expr->value.constructor = base;
511 }
512
513
514 /* Make sure an initialization expression is in normalized form, i.e., all
515    elements of the constructors are in the correct order.  */
516
517 static void
518 formalize_init_expr (gfc_expr *expr)
519 {
520   expr_t type;
521   gfc_constructor *c;
522
523   if (expr == NULL)
524     return;
525
526   type = expr->expr_type;
527   switch (type)
528     {
529     case EXPR_ARRAY:
530       for (c = gfc_constructor_first (expr->value.constructor);
531            c; c = gfc_constructor_next (c))
532         formalize_init_expr (c->expr);
533
534     break;
535
536     case EXPR_STRUCTURE:
537       formalize_structure_cons (expr);
538       break;
539
540     default:
541       break;
542     }
543 }
544
545
546 /* Resolve symbol's initial value after all data statement.  */
547
548 void
549 gfc_formalize_init_value (gfc_symbol *sym)
550 {
551   formalize_init_expr (sym->value);
552 }
553
554
555 /* Get the integer value into RET_AS and SECTION from AS and AR, and return
556    offset.  */
557  
558 void
559 gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
560 {
561   int i;
562   mpz_t delta;
563   mpz_t tmp;
564
565   mpz_set_si (*offset, 0);
566   mpz_init (tmp);
567   mpz_init_set_si (delta, 1);
568   for (i = 0; i < ar->dimen; i++)
569     {
570       mpz_init (section_index[i]);
571       switch (ar->dimen_type[i])
572         {
573         case DIMEN_ELEMENT:
574         case DIMEN_RANGE:
575           if (ar->start[i])
576             {
577               mpz_sub (tmp, ar->start[i]->value.integer,
578                        ar->as->lower[i]->value.integer);
579               mpz_mul (tmp, tmp, delta);
580               mpz_add (*offset, tmp, *offset);
581               mpz_set (section_index[i], ar->start[i]->value.integer);
582             }
583           else
584               mpz_set (section_index[i], ar->as->lower[i]->value.integer);
585           break;
586
587         case DIMEN_VECTOR:
588           gfc_internal_error ("TODO: Vector sections in data statements");
589
590         default:
591           gcc_unreachable ();
592         }
593
594       mpz_sub (tmp, ar->as->upper[i]->value.integer, 
595                ar->as->lower[i]->value.integer);
596       mpz_add_ui (tmp, tmp, 1);
597       mpz_mul (delta, tmp, delta);
598     }
599
600   mpz_clear (tmp);
601   mpz_clear (delta);
602 }
603