OSDN Git Service

* runtime/select.c: Moved content to select_inc.c. Include it.
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / unpack_generic.c
1 /* Generic implementation of the UNPACK intrinsic
2    Copyright 2002, 2003, 2004, 2005, 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 unpack_internal (gfc_array_char *ret, const gfc_array_char *vector,
38                  const gfc_array_l1 *mask, const gfc_array_char *field,
39                  index_type size, index_type fsize)
40 {
41   /* r.* indicates the return array.  */
42   index_type rstride[GFC_MAX_DIMENSIONS];
43   index_type rstride0;
44   index_type rs;
45   char *rptr;
46   /* v.* indicates the vector array.  */
47   index_type vstride0;
48   char *vptr;
49   /* f.* indicates the field array.  */
50   index_type fstride[GFC_MAX_DIMENSIONS];
51   index_type fstride0;
52   const char *fptr;
53   /* m.* indicates the mask array.  */
54   index_type mstride[GFC_MAX_DIMENSIONS];
55   index_type mstride0;
56   const GFC_LOGICAL_1 *mptr;
57
58   index_type count[GFC_MAX_DIMENSIONS];
59   index_type extent[GFC_MAX_DIMENSIONS];
60   index_type n;
61   index_type dim;
62
63   int empty;
64   int mask_kind;
65
66   empty = 0;
67
68   mptr = mask->data;
69
70   /* Use the same loop for all logical types, by using GFC_LOGICAL_1
71      and using shifting to address size and endian issues.  */
72
73   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
74
75   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
76 #ifdef HAVE_GFC_LOGICAL_16
77       || mask_kind == 16
78 #endif
79       )
80     {
81       /*  Don't convert a NULL pointer as we use test for NULL below.  */
82       if (mptr)
83         mptr = GFOR_POINTER_TO_L1 (mptr, mask_kind);
84     }
85   else
86     runtime_error ("Funny sized logical array");
87
88   if (ret->data == NULL)
89     {
90       /* The front end has signalled that we need to populate the
91          return array descriptor.  */
92       dim = GFC_DESCRIPTOR_RANK (mask);
93       rs = 1;
94       for (n = 0; n < dim; n++)
95         {
96           count[n] = 0;
97           ret->dim[n].stride = rs;
98           ret->dim[n].lbound = 0;
99           ret->dim[n].ubound = mask->dim[n].ubound - mask->dim[n].lbound;
100           extent[n] = ret->dim[n].ubound + 1;
101           empty = empty || extent[n] <= 0;
102           rstride[n] = ret->dim[n].stride * size;
103           fstride[n] = field->dim[n].stride * fsize;
104           mstride[n] = mask->dim[n].stride * mask_kind;
105           rs *= extent[n];
106         }
107       ret->offset = 0;
108       ret->data = internal_malloc_size (rs * size);
109     }
110   else
111     {
112       dim = GFC_DESCRIPTOR_RANK (ret);
113       for (n = 0; n < dim; n++)
114         {
115           count[n] = 0;
116           extent[n] = ret->dim[n].ubound + 1 - ret->dim[n].lbound;
117           empty = empty || extent[n] <= 0;
118           rstride[n] = ret->dim[n].stride * size;
119           fstride[n] = field->dim[n].stride * fsize;
120           mstride[n] = mask->dim[n].stride * mask_kind;
121         }
122       if (rstride[0] == 0)
123         rstride[0] = size;
124     }
125
126   if (empty)
127     return;
128
129   if (fstride[0] == 0)
130     fstride[0] = fsize;
131   if (mstride[0] == 0)
132     mstride[0] = 1;
133
134   vstride0 = vector->dim[0].stride * size;
135   if (vstride0 == 0)
136     vstride0 = size;
137   rstride0 = rstride[0];
138   fstride0 = fstride[0];
139   mstride0 = mstride[0];
140   rptr = ret->data;
141   fptr = field->data;
142   vptr = vector->data;
143
144   while (rptr)
145     {
146       if (*mptr)
147         {
148           /* From vector.  */
149           memcpy (rptr, vptr, size);
150           vptr += vstride0;
151         }
152       else
153         {
154           /* From field.  */
155           memcpy (rptr, fptr, size);
156         }
157       /* Advance to the next element.  */
158       rptr += rstride0;
159       fptr += fstride0;
160       mptr += mstride0;
161       count[0]++;
162       n = 0;
163       while (count[n] == extent[n])
164         {
165           /* When we get to the end of a dimension, reset it and increment
166              the next dimension.  */
167           count[n] = 0;
168           /* We could precalculate these products, but this is a less
169              frequently used path so probably not worth it.  */
170           rptr -= rstride[n] * extent[n];
171           fptr -= fstride[n] * extent[n];
172           mptr -= mstride[n] * extent[n];
173           n++;
174           if (n >= dim)
175             {
176               /* Break out of the loop.  */
177               rptr = NULL;
178               break;
179             }
180           else
181             {
182               count[n]++;
183               rptr += rstride[n];
184               fptr += fstride[n];
185               mptr += mstride[n];
186             }
187         }
188     }
189 }
190
191 extern void unpack1 (gfc_array_char *, const gfc_array_char *,
192                      const gfc_array_l1 *, const gfc_array_char *);
193 export_proto(unpack1);
194
195 void
196 unpack1 (gfc_array_char *ret, const gfc_array_char *vector,
197          const gfc_array_l1 *mask, const gfc_array_char *field)
198 {
199   index_type type_size;
200   index_type size;
201
202   type_size = GFC_DTYPE_TYPE_SIZE (vector);
203   size = GFC_DESCRIPTOR_SIZE (vector);
204
205   switch(type_size)
206     {
207     case GFC_DTYPE_LOGICAL_1:
208     case GFC_DTYPE_INTEGER_1:
209     case GFC_DTYPE_DERIVED_1:
210       unpack1_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
211                   mask, (gfc_array_i1 *) field);
212       return;
213
214     case GFC_DTYPE_LOGICAL_2:
215     case GFC_DTYPE_INTEGER_2:
216       unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
217                   mask, (gfc_array_i2 *) field);
218       return;
219
220     case GFC_DTYPE_LOGICAL_4:
221     case GFC_DTYPE_INTEGER_4:
222       unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
223                   mask, (gfc_array_i4 *) field);
224       return;
225
226     case GFC_DTYPE_LOGICAL_8:
227     case GFC_DTYPE_INTEGER_8:
228       unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
229                   mask, (gfc_array_i8 *) field);
230       return;
231
232 #ifdef HAVE_GFC_INTEGER_16
233     case GFC_DTYPE_LOGICAL_16:
234     case GFC_DTYPE_INTEGER_16:
235       unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
236                    mask, (gfc_array_i16 *) field);
237       return;
238 #endif
239     case GFC_DTYPE_REAL_4:
240       unpack1_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
241                   mask, (gfc_array_r4 *) field);
242       return;
243
244     case GFC_DTYPE_REAL_8:
245       unpack1_r8 ((gfc_array_r8 *) ret, (gfc_array_r8 *) vector,
246                   mask, (gfc_array_r8 *) field);
247       return;
248
249 #ifdef HAVE_GFC_REAL_10
250     case GFC_DTYPE_REAL_10:
251       unpack1_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
252                    mask, (gfc_array_r10 *) field);
253           return;
254 #endif
255
256 #ifdef HAVE_GFC_REAL_16
257     case GFC_DTYPE_REAL_16:
258       unpack1_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
259                    mask, (gfc_array_r16 *) field);
260       return;
261 #endif
262
263     case GFC_DTYPE_COMPLEX_4:
264       unpack1_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
265                   mask, (gfc_array_c4 *) field);
266       return;
267
268     case GFC_DTYPE_COMPLEX_8:
269       unpack1_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
270                   mask, (gfc_array_c8 *) field);
271       return;
272
273 #ifdef HAVE_GFC_COMPLEX_10
274     case GFC_DTYPE_COMPLEX_10:
275       unpack1_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
276                    mask, (gfc_array_c10 *) field);
277       return;
278 #endif
279
280 #ifdef HAVE_GFC_COMPLEX_16
281     case GFC_DTYPE_COMPLEX_16:
282       unpack1_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
283                    mask, (gfc_array_c16 *) field);
284       return;
285 #endif
286
287     case GFC_DTYPE_DERIVED_2:
288       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
289           || GFC_UNALIGNED_2(field->data))
290         break;
291       else
292         {
293           unpack1_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
294                       mask, (gfc_array_i2 *) field);
295           return;
296         }
297
298     case GFC_DTYPE_DERIVED_4:
299       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
300           || GFC_UNALIGNED_4(field->data))
301         break;
302       else
303         {
304           unpack1_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
305                       mask, (gfc_array_i4 *) field);
306           return;
307         }
308
309     case GFC_DTYPE_DERIVED_8:
310       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
311           || GFC_UNALIGNED_8(field->data))
312         break;
313       else
314         {
315           unpack1_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
316                       mask, (gfc_array_i8 *) field);
317           return;
318         }
319
320 #ifdef HAVE_GFC_INTEGER_16
321     case GFC_DTYPE_DERIVED_16:
322       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
323           || GFC_UNALIGNED_16(field->data))
324         break;
325       else
326         {
327           unpack1_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
328                        mask, (gfc_array_i16 *) field);
329           return;
330         }
331 #endif
332     }
333
334   unpack_internal (ret, vector, mask, field, size,
335                    GFC_DESCRIPTOR_SIZE (field));
336 }
337
338
339 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
340                           const gfc_array_char *, const gfc_array_l1 *,
341                           const gfc_array_char *, GFC_INTEGER_4,
342                           GFC_INTEGER_4);
343 export_proto(unpack1_char);
344
345 void
346 unpack1_char (gfc_array_char *ret,
347               GFC_INTEGER_4 ret_length __attribute__((unused)),
348               const gfc_array_char *vector, const gfc_array_l1 *mask,
349               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
350               GFC_INTEGER_4 field_length)
351 {
352   unpack_internal (ret, vector, mask, field, vector_length, field_length);
353 }
354
355
356 extern void unpack1_char4 (gfc_array_char *, GFC_INTEGER_4,
357                            const gfc_array_char *, const gfc_array_l1 *,
358                            const gfc_array_char *, GFC_INTEGER_4,
359                            GFC_INTEGER_4);
360 export_proto(unpack1_char4);
361
362 void
363 unpack1_char4 (gfc_array_char *ret,
364                GFC_INTEGER_4 ret_length __attribute__((unused)),
365                const gfc_array_char *vector, const gfc_array_l1 *mask,
366                const gfc_array_char *field, GFC_INTEGER_4 vector_length,
367                GFC_INTEGER_4 field_length)
368 {
369   unpack_internal (ret, vector, mask, field,
370                    vector_length * sizeof (gfc_char4_t),
371                    field_length * sizeof (gfc_char4_t));
372 }
373
374
375 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
376                      const gfc_array_l1 *, char *);
377 export_proto(unpack0);
378
379 void
380 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
381          const gfc_array_l1 *mask, char *field)
382 {
383   gfc_array_char tmp;
384
385   index_type type_size;
386   index_type size;
387
388   type_size = GFC_DTYPE_TYPE_SIZE (vector);
389   size = GFC_DESCRIPTOR_SIZE (vector);
390
391   switch(type_size)
392     {
393     case GFC_DTYPE_LOGICAL_1:
394     case GFC_DTYPE_INTEGER_1:
395     case GFC_DTYPE_DERIVED_1:
396       unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
397                   mask, (GFC_INTEGER_1 *) field);
398       return;
399
400     case GFC_DTYPE_LOGICAL_2:
401     case GFC_DTYPE_INTEGER_2:
402       unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
403                   mask, (GFC_INTEGER_2 *) field);
404       return;
405
406     case GFC_DTYPE_LOGICAL_4:
407     case GFC_DTYPE_INTEGER_4:
408       unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
409                   mask, (GFC_INTEGER_4 *) field);
410       return;
411
412     case GFC_DTYPE_LOGICAL_8:
413     case GFC_DTYPE_INTEGER_8:
414       unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
415                   mask, (GFC_INTEGER_8 *) field);
416       return;
417
418 #ifdef HAVE_GFC_INTEGER_16
419     case GFC_DTYPE_LOGICAL_16:
420     case GFC_DTYPE_INTEGER_16:
421       unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
422                    mask, (GFC_INTEGER_16 *) field);
423       return;
424 #endif
425     case GFC_DTYPE_REAL_4:
426       unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
427                   mask, (GFC_REAL_4 *) field);
428       return;
429
430     case GFC_DTYPE_REAL_8:
431       unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
432                   mask, (GFC_REAL_8  *) field);
433       return;
434
435 #ifdef HAVE_GFC_REAL_10
436     case GFC_DTYPE_REAL_10:
437       unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
438                    mask, (GFC_REAL_10 *) field);
439       return;
440 #endif
441
442 #ifdef HAVE_GFC_REAL_16
443     case GFC_DTYPE_REAL_16:
444       unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
445                    mask, (GFC_REAL_16 *) field);
446       return;
447 #endif
448
449     case GFC_DTYPE_COMPLEX_4:
450       unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
451                   mask, (GFC_COMPLEX_4 *) field);
452       return;
453
454     case GFC_DTYPE_COMPLEX_8:
455       unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
456                   mask, (GFC_COMPLEX_8 *) field);
457       return;
458
459 #ifdef HAVE_GFC_COMPLEX_10
460     case GFC_DTYPE_COMPLEX_10:
461       unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
462                    mask, (GFC_COMPLEX_10 *) field);
463       return;
464 #endif
465
466 #ifdef HAVE_GFC_COMPLEX_16
467     case GFC_DTYPE_COMPLEX_16:
468       unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
469                    mask, (GFC_COMPLEX_16 *) field);
470       return;
471 #endif
472     case GFC_DTYPE_DERIVED_2:
473       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
474           || GFC_UNALIGNED_2(field))
475         break;
476       else
477         {
478           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
479                       mask, (GFC_INTEGER_2 *) field);
480           return;
481         }
482
483     case GFC_DTYPE_DERIVED_4:
484       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
485           || GFC_UNALIGNED_4(field))
486         break;
487       else
488         {
489           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
490                       mask, (GFC_INTEGER_4 *) field);
491           return;
492         }
493
494     case GFC_DTYPE_DERIVED_8:
495       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
496           || GFC_UNALIGNED_8(field))
497         break;
498       else
499         {
500           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
501                       mask, (GFC_INTEGER_8 *) field);
502           return;
503         }
504 #ifdef HAVE_GFC_INTEGER_16
505     case GFC_DTYPE_DERIVED_16:
506       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
507           || GFC_UNALIGNED_16(field))
508         break;
509       else
510         {
511           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
512                        mask, (GFC_INTEGER_16 *) field);
513           return;
514         }
515 #endif
516     }
517
518   memset (&tmp, 0, sizeof (tmp));
519   tmp.dtype = 0;
520   tmp.data = field;
521   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
522 }
523
524
525 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
526                           const gfc_array_char *, const gfc_array_l1 *,
527                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
528 export_proto(unpack0_char);
529
530 void
531 unpack0_char (gfc_array_char *ret,
532               GFC_INTEGER_4 ret_length __attribute__((unused)),
533               const gfc_array_char *vector, const gfc_array_l1 *mask,
534               char *field, GFC_INTEGER_4 vector_length,
535               GFC_INTEGER_4 field_length __attribute__((unused)))
536 {
537   gfc_array_char tmp;
538
539   memset (&tmp, 0, sizeof (tmp));
540   tmp.dtype = 0;
541   tmp.data = field;
542   unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
543 }
544
545
546 extern void unpack0_char4 (gfc_array_char *, GFC_INTEGER_4,
547                            const gfc_array_char *, const gfc_array_l1 *,
548                            char *, GFC_INTEGER_4, GFC_INTEGER_4);
549 export_proto(unpack0_char4);
550
551 void
552 unpack0_char4 (gfc_array_char *ret,
553                GFC_INTEGER_4 ret_length __attribute__((unused)),
554                const gfc_array_char *vector, const gfc_array_l1 *mask,
555                char *field, GFC_INTEGER_4 vector_length,
556                GFC_INTEGER_4 field_length __attribute__((unused)))
557 {
558   gfc_array_char tmp;
559
560   memset (&tmp, 0, sizeof (tmp));
561   tmp.dtype = 0;
562   tmp.data = field;
563   unpack_internal (ret, vector, mask, &tmp,
564                    vector_length * sizeof (gfc_char4_t), 0);
565 }