OSDN Git Service

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