OSDN Git Service

* runtime/select.c: Moved content to select_inc.c. Include it.
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / spread_generic.c
1 /* Generic implementation of the SPREAD intrinsic
2    Copyright 2002, 2005, 2006, 2007 Free Software Foundation, Inc.
3    Contributed by Paul Brook <paul@nowt.org>
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 2 of the License, or (at your option) any later version.
11
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file.  (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
20
21 Ligbfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
24 GNU General Public License for more details.
25
26 You should have received a copy of the GNU General Public
27 License along with libgfortran; see the file COPYING.  If not,
28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA.  */
30
31 #include "libgfortran.h"
32 #include <stdlib.h>
33 #include <assert.h>
34 #include <string.h>
35
36 static void
37 spread_internal (gfc_array_char *ret, const gfc_array_char *source,
38                  const index_type *along, const index_type *pncopies,
39                  index_type size)
40 {
41   /* r.* indicates the return array.  */
42   index_type rstride[GFC_MAX_DIMENSIONS];
43   index_type rstride0;
44   index_type rdelta = 0;
45   index_type rrank;
46   index_type rs;
47   char *rptr;
48   char *dest;
49   /* s.* indicates the source array.  */
50   index_type sstride[GFC_MAX_DIMENSIONS];
51   index_type sstride0;
52   index_type srank;
53   const char *sptr;
54
55   index_type count[GFC_MAX_DIMENSIONS];
56   index_type extent[GFC_MAX_DIMENSIONS];
57   index_type n;
58   index_type dim;
59   index_type ncopies;
60
61   srank = GFC_DESCRIPTOR_RANK(source);
62
63   rrank = srank + 1;
64   if (rrank > GFC_MAX_DIMENSIONS)
65     runtime_error ("return rank too large in spread()");
66
67   if (*along > rrank)
68       runtime_error ("dim outside of rank in spread()");
69
70   ncopies = *pncopies;
71
72   if (ret->data == NULL)
73     {
74       /* The front end has signalled that we need to populate the
75          return array descriptor.  */
76       ret->dtype = (source->dtype & ~GFC_DTYPE_RANK_MASK) | rrank;
77       dim = 0;
78       rs = 1;
79       for (n = 0; n < rrank; n++)
80         {
81           ret->dim[n].stride = rs;
82           ret->dim[n].lbound = 0;
83           if (n == *along - 1)
84             {
85               ret->dim[n].ubound = ncopies - 1;
86               rdelta = rs * size;
87               rs *= ncopies;
88             }
89           else
90             {
91               count[dim] = 0;
92               extent[dim] = source->dim[dim].ubound + 1
93                 - source->dim[dim].lbound;
94               sstride[dim] = source->dim[dim].stride * size;
95               rstride[dim] = rs * size;
96
97               ret->dim[n].ubound = extent[dim]-1;
98               rs *= extent[dim];
99               dim++;
100             }
101         }
102       ret->offset = 0;
103       if (rs > 0)
104         ret->data = internal_malloc_size (rs * size);
105       else
106         {
107           ret->data = internal_malloc_size (1);
108           return;
109         }
110     }
111   else
112     {
113       int zero_sized;
114
115       zero_sized = 0;
116
117       dim = 0;
118       if (GFC_DESCRIPTOR_RANK(ret) != rrank)
119         runtime_error ("rank mismatch in spread()");
120
121       if (compile_options.bounds_check)
122         {
123           for (n = 0; n < rrank; n++)
124             {
125               index_type ret_extent;
126
127               ret_extent = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
128               if (n == *along - 1)
129                 {
130                   rdelta = ret->dim[n].stride * size;
131
132                   if (ret_extent != ncopies)
133                     runtime_error("Incorrect extent in return value of SPREAD"
134                                   " intrinsic in dimension %ld: is %ld,"
135                                   " should be %ld", (long int) n+1,
136                                   (long int) ret_extent, (long int) ncopies);
137                 }
138               else
139                 {
140                   count[dim] = 0;
141                   extent[dim] = source->dim[dim].ubound + 1
142                     - source->dim[dim].lbound;
143                   if (ret_extent != extent[dim])
144                     runtime_error("Incorrect extent in return value of SPREAD"
145                                   " intrinsic in dimension %ld: is %ld,"
146                                   " should be %ld", (long int) n+1,
147                                   (long int) ret_extent,
148                                   (long int) extent[dim]);
149                     
150                   if (extent[dim] <= 0)
151                     zero_sized = 1;
152                   sstride[dim] = source->dim[dim].stride * size;
153                   rstride[dim] = ret->dim[n].stride * size;
154                   dim++;
155                 }
156             }
157         }
158       else
159         {
160           for (n = 0; n < rrank; n++)
161             {
162               if (n == *along - 1)
163                 {
164                   rdelta = ret->dim[n].stride * size;
165                 }
166               else
167                 {
168                   count[dim] = 0;
169                   extent[dim] = source->dim[dim].ubound + 1
170                     - source->dim[dim].lbound;
171                   if (extent[dim] <= 0)
172                     zero_sized = 1;
173                   sstride[dim] = source->dim[dim].stride * size;
174                   rstride[dim] = ret->dim[n].stride * size;
175                   dim++;
176                 }
177             }
178         }
179
180       if (zero_sized)
181         return;
182
183       if (sstride[0] == 0)
184         sstride[0] = size;
185     }
186   sstride0 = sstride[0];
187   rstride0 = rstride[0];
188   rptr = ret->data;
189   sptr = source->data;
190
191   while (sptr)
192     {
193       /* Spread this element.  */
194       dest = rptr;
195       for (n = 0; n < ncopies; n++)
196         {
197           memcpy (dest, sptr, size);
198           dest += rdelta;
199         }
200       /* Advance to the next element.  */
201       sptr += sstride0;
202       rptr += rstride0;
203       count[0]++;
204       n = 0;
205       while (count[n] == extent[n])
206         {
207           /* When we get to the end of a dimension, reset it and increment
208              the next dimension.  */
209           count[n] = 0;
210           /* We could precalculate these products, but this is a less
211              frequently used path so probably not worth it.  */
212           sptr -= sstride[n] * extent[n];
213           rptr -= rstride[n] * extent[n];
214           n++;
215           if (n >= srank)
216             {
217               /* Break out of the loop.  */
218               sptr = NULL;
219               break;
220             }
221           else
222             {
223               count[n]++;
224               sptr += sstride[n];
225               rptr += rstride[n];
226             }
227         }
228     }
229 }
230
231 /* This version of spread_internal treats the special case of a scalar
232    source.  This is much simpler than the more general case above.  */
233
234 static void
235 spread_internal_scalar (gfc_array_char *ret, const char *source,
236                         const index_type *along, const index_type *pncopies,
237                         index_type size)
238 {
239   int n;
240   int ncopies = *pncopies;
241   char * dest;
242
243   if (GFC_DESCRIPTOR_RANK (ret) != 1)
244     runtime_error ("incorrect destination rank in spread()");
245
246   if (*along > 1)
247     runtime_error ("dim outside of rank in spread()");
248
249   if (ret->data == NULL)
250     {
251       ret->data = internal_malloc_size (ncopies * size);
252       ret->offset = 0;
253       ret->dim[0].stride = 1;
254       ret->dim[0].lbound = 0;
255       ret->dim[0].ubound = ncopies - 1;
256     }
257   else
258     {
259       if (ncopies - 1 > (ret->dim[0].ubound - ret->dim[0].lbound)
260                            / ret->dim[0].stride)
261         runtime_error ("dim too large in spread()");
262     }
263
264   for (n = 0; n < ncopies; n++)
265     {
266       dest = (char*)(ret->data + n*size*ret->dim[0].stride);
267       memcpy (dest , source, size);
268     }
269 }
270
271 extern void spread (gfc_array_char *, const gfc_array_char *,
272                     const index_type *, const index_type *);
273 export_proto(spread);
274
275 void
276 spread (gfc_array_char *ret, const gfc_array_char *source,
277         const index_type *along, const index_type *pncopies)
278 {
279   index_type type_size;
280
281   type_size = GFC_DTYPE_TYPE_SIZE(ret);
282   switch(type_size)
283     {
284     case GFC_DTYPE_DERIVED_1:
285     case GFC_DTYPE_LOGICAL_1:
286     case GFC_DTYPE_INTEGER_1:
287       spread_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) source,
288                  *along, *pncopies);
289       return;
290
291     case GFC_DTYPE_LOGICAL_2:
292     case GFC_DTYPE_INTEGER_2:
293       spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
294                  *along, *pncopies);
295       return;
296
297     case GFC_DTYPE_LOGICAL_4:
298     case GFC_DTYPE_INTEGER_4:
299       spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
300                  *along, *pncopies);
301       return;
302
303     case GFC_DTYPE_LOGICAL_8:
304     case GFC_DTYPE_INTEGER_8:
305       spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
306                  *along, *pncopies);
307       return;
308
309 #ifdef HAVE_GFC_INTEGER_16
310     case GFC_DTYPE_LOGICAL_16:
311     case GFC_DTYPE_INTEGER_16:
312       spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
313                  *along, *pncopies);
314       return;
315 #endif
316
317     case GFC_DTYPE_REAL_4:
318       spread_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) source,
319                  *along, *pncopies);
320       return;
321
322     case GFC_DTYPE_REAL_8:
323       spread_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) source,
324                  *along, *pncopies);
325       return;
326
327 #ifdef GFC_HAVE_REAL_10
328     case GFC_DTYPE_REAL_10:
329       spread_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) source,
330                  *along, *pncopies);
331       return;
332 #endif
333
334 #ifdef GFC_HAVE_REAL_16
335     case GFC_DTYPE_REAL_16:
336       spread_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) source,
337                  *along, *pncopies);
338       return;
339 #endif
340
341     case GFC_DTYPE_COMPLEX_4:
342       spread_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) source,
343                  *along, *pncopies);
344       return;
345
346     case GFC_DTYPE_COMPLEX_8:
347       spread_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) source,
348                  *along, *pncopies);
349       return;
350
351 #ifdef GFC_HAVE_COMPLEX_10
352     case GFC_DTYPE_COMPLEX_10:
353       spread_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) source,
354                  *along, *pncopies);
355       return;
356 #endif
357
358 #ifdef GFC_HAVE_COMPLEX_16
359     case GFC_DTYPE_COMPLEX_16:
360       spread_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) source,
361                  *along, *pncopies);
362       return;
363 #endif
364
365     case GFC_DTYPE_DERIVED_2:
366       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source->data))
367         break;
368       else
369         {
370           spread_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) source,
371                      *along, *pncopies);
372           return;
373         }
374
375     case GFC_DTYPE_DERIVED_4:
376       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source->data))
377         break;
378       else
379         {
380           spread_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) source,
381                      *along, *pncopies);
382           return;
383         }
384
385     case GFC_DTYPE_DERIVED_8:
386       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source->data))
387         break;
388       else
389         {
390           spread_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) source,
391                      *along, *pncopies);
392           return;
393         }
394
395 #ifdef HAVE_GFC_INTEGER_16
396     case GFC_DTYPE_DERIVED_16:
397       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source->data))
398         break;
399       else
400         {
401           spread_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) source,
402                       *along, *pncopies);
403           return;
404         }
405 #endif
406     }
407
408   spread_internal (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (source));
409 }
410
411
412 extern void spread_char (gfc_array_char *, GFC_INTEGER_4,
413                          const gfc_array_char *, const index_type *,
414                          const index_type *, GFC_INTEGER_4);
415 export_proto(spread_char);
416
417 void
418 spread_char (gfc_array_char *ret,
419              GFC_INTEGER_4 ret_length __attribute__((unused)),
420              const gfc_array_char *source, const index_type *along,
421              const index_type *pncopies, GFC_INTEGER_4 source_length)
422 {
423   spread_internal (ret, source, along, pncopies, source_length);
424 }
425
426
427 extern void spread_char4 (gfc_array_char *, GFC_INTEGER_4,
428                           const gfc_array_char *, const index_type *,
429                           const index_type *, GFC_INTEGER_4);
430 export_proto(spread_char4);
431
432 void
433 spread_char4 (gfc_array_char *ret,
434               GFC_INTEGER_4 ret_length __attribute__((unused)),
435               const gfc_array_char *source, const index_type *along,
436               const index_type *pncopies, GFC_INTEGER_4 source_length)
437 {
438   spread_internal (ret, source, along, pncopies,
439                    source_length * sizeof (gfc_char4_t));
440 }
441
442
443 /* The following are the prototypes for the versions of spread with a
444    scalar source.  */
445
446 extern void spread_scalar (gfc_array_char *, const char *,
447                            const index_type *, const index_type *);
448 export_proto(spread_scalar);
449
450 void
451 spread_scalar (gfc_array_char *ret, const char *source,
452                const index_type *along, const index_type *pncopies)
453 {
454   index_type type_size;
455
456   if (!ret->dtype)
457     runtime_error ("return array missing descriptor in spread()");
458
459   type_size = GFC_DTYPE_TYPE_SIZE(ret);
460   switch(type_size)
461     {
462     case GFC_DTYPE_DERIVED_1:
463     case GFC_DTYPE_LOGICAL_1:
464     case GFC_DTYPE_INTEGER_1:
465       spread_scalar_i1 ((gfc_array_i1 *) ret, (GFC_INTEGER_1 *) source,
466                         *along, *pncopies);
467       return;
468
469     case GFC_DTYPE_LOGICAL_2:
470     case GFC_DTYPE_INTEGER_2:
471       spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
472                         *along, *pncopies);
473       return;
474
475     case GFC_DTYPE_LOGICAL_4:
476     case GFC_DTYPE_INTEGER_4:
477       spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
478                         *along, *pncopies);
479       return;
480
481     case GFC_DTYPE_LOGICAL_8:
482     case GFC_DTYPE_INTEGER_8:
483       spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
484                         *along, *pncopies);
485       return;
486
487 #ifdef HAVE_GFC_INTEGER_16
488     case GFC_DTYPE_LOGICAL_16:
489     case GFC_DTYPE_INTEGER_16:
490       spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
491                         *along, *pncopies);
492       return;
493 #endif
494
495     case GFC_DTYPE_REAL_4:
496       spread_scalar_r4 ((gfc_array_r4 *) ret, (GFC_REAL_4 *) source,
497                         *along, *pncopies);
498       return;
499
500     case GFC_DTYPE_REAL_8:
501       spread_scalar_r8 ((gfc_array_r8 *) ret, (GFC_REAL_8 *) source,
502                         *along, *pncopies);
503       return;
504
505 #ifdef HAVE_GFC_REAL_10
506     case GFC_DTYPE_REAL_10:
507       spread_scalar_r10 ((gfc_array_r10 *) ret, (GFC_REAL_10 *) source,
508                         *along, *pncopies);
509       return;
510 #endif
511
512 #ifdef HAVE_GFC_REAL_16
513     case GFC_DTYPE_REAL_16:
514       spread_scalar_r16 ((gfc_array_r16 *) ret, (GFC_REAL_16 *) source,
515                         *along, *pncopies);
516       return;
517 #endif
518
519     case GFC_DTYPE_COMPLEX_4:
520       spread_scalar_c4 ((gfc_array_c4 *) ret, (GFC_COMPLEX_4 *) source,
521                         *along, *pncopies);
522       return;
523
524     case GFC_DTYPE_COMPLEX_8:
525       spread_scalar_c8 ((gfc_array_c8 *) ret, (GFC_COMPLEX_8 *) source,
526                         *along, *pncopies);
527       return;
528
529 #ifdef HAVE_GFC_COMPLEX_10
530     case GFC_DTYPE_COMPLEX_10:
531       spread_scalar_c10 ((gfc_array_c10 *) ret, (GFC_COMPLEX_10 *) source,
532                         *along, *pncopies);
533       return;
534 #endif
535
536 #ifdef HAVE_GFC_COMPLEX_16
537     case GFC_DTYPE_COMPLEX_16:
538       spread_scalar_c16 ((gfc_array_c16 *) ret, (GFC_COMPLEX_16 *) source,
539                         *along, *pncopies);
540       return;
541 #endif
542
543     case GFC_DTYPE_DERIVED_2:
544       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(source))
545         break;
546       else
547         {
548           spread_scalar_i2 ((gfc_array_i2 *) ret, (GFC_INTEGER_2 *) source,
549                             *along, *pncopies);
550           return;
551         }
552
553     case GFC_DTYPE_DERIVED_4:
554       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(source))
555         break;
556       else
557         {
558           spread_scalar_i4 ((gfc_array_i4 *) ret, (GFC_INTEGER_4 *) source,
559                             *along, *pncopies);
560           return;
561         }
562
563     case GFC_DTYPE_DERIVED_8:
564       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(source))
565         break;
566       else
567         {
568           spread_scalar_i8 ((gfc_array_i8 *) ret, (GFC_INTEGER_8 *) source,
569                             *along, *pncopies);
570           return;
571         }
572 #ifdef HAVE_GFC_INTEGER_16
573     case GFC_DTYPE_DERIVED_16:
574       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(source))
575         break;
576       else
577         {
578           spread_scalar_i16 ((gfc_array_i16 *) ret, (GFC_INTEGER_16 *) source,
579                              *along, *pncopies);
580           return;
581         }
582 #endif
583     }
584
585   spread_internal_scalar (ret, source, along, pncopies, GFC_DESCRIPTOR_SIZE (ret));
586 }
587
588
589 extern void spread_char_scalar (gfc_array_char *, GFC_INTEGER_4,
590                                 const char *, const index_type *,
591                                 const index_type *, GFC_INTEGER_4);
592 export_proto(spread_char_scalar);
593
594 void
595 spread_char_scalar (gfc_array_char *ret,
596                     GFC_INTEGER_4 ret_length __attribute__((unused)),
597                     const char *source, const index_type *along,
598                     const index_type *pncopies, GFC_INTEGER_4 source_length)
599 {
600   if (!ret->dtype)
601     runtime_error ("return array missing descriptor in spread()");
602   spread_internal_scalar (ret, source, along, pncopies, source_length);
603 }
604
605
606 extern void spread_char4_scalar (gfc_array_char *, GFC_INTEGER_4,
607                                  const char *, const index_type *,
608                                  const index_type *, GFC_INTEGER_4);
609 export_proto(spread_char4_scalar);
610
611 void
612 spread_char4_scalar (gfc_array_char *ret,
613                      GFC_INTEGER_4 ret_length __attribute__((unused)),
614                      const char *source, const index_type *along,
615                      const index_type *pncopies, GFC_INTEGER_4 source_length)
616 {
617   if (!ret->dtype)
618     runtime_error ("return array missing descriptor in spread()");
619   spread_internal_scalar (ret, source, along, pncopies,
620                           source_length * sizeof (gfc_char4_t));
621 }
622