OSDN Git Service

82607bd58979bfe286ee8100f0a81bbed487b44b
[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 extern void unpack1_char (gfc_array_char *, GFC_INTEGER_4,
339                           const gfc_array_char *, const gfc_array_l1 *,
340                           const gfc_array_char *, GFC_INTEGER_4,
341                           GFC_INTEGER_4);
342 export_proto(unpack1_char);
343
344 void
345 unpack1_char (gfc_array_char *ret,
346               GFC_INTEGER_4 ret_length __attribute__((unused)),
347               const gfc_array_char *vector, const gfc_array_l1 *mask,
348               const gfc_array_char *field, GFC_INTEGER_4 vector_length,
349               GFC_INTEGER_4 field_length)
350 {
351   unpack_internal (ret, vector, mask, field, vector_length, field_length);
352 }
353
354 extern void unpack0 (gfc_array_char *, const gfc_array_char *,
355                      const gfc_array_l1 *, char *);
356 export_proto(unpack0);
357
358 void
359 unpack0 (gfc_array_char *ret, const gfc_array_char *vector,
360          const gfc_array_l1 *mask, char *field)
361 {
362   gfc_array_char tmp;
363
364   index_type type_size;
365   index_type size;
366
367   type_size = GFC_DTYPE_TYPE_SIZE (vector);
368   size = GFC_DESCRIPTOR_SIZE (vector);
369
370   switch(type_size)
371     {
372     case GFC_DTYPE_LOGICAL_1:
373     case GFC_DTYPE_INTEGER_1:
374     case GFC_DTYPE_DERIVED_1:
375       unpack0_i1 ((gfc_array_i1 *) ret, (gfc_array_i1 *) vector,
376                   mask, (GFC_INTEGER_1 *) field);
377       return;
378
379     case GFC_DTYPE_LOGICAL_2:
380     case GFC_DTYPE_INTEGER_2:
381       unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
382                   mask, (GFC_INTEGER_2 *) field);
383       return;
384
385     case GFC_DTYPE_LOGICAL_4:
386     case GFC_DTYPE_INTEGER_4:
387       unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
388                   mask, (GFC_INTEGER_4 *) field);
389       return;
390
391     case GFC_DTYPE_LOGICAL_8:
392     case GFC_DTYPE_INTEGER_8:
393       unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
394                   mask, (GFC_INTEGER_8 *) field);
395       return;
396
397 #ifdef HAVE_GFC_INTEGER_16
398     case GFC_DTYPE_LOGICAL_16:
399     case GFC_DTYPE_INTEGER_16:
400       unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
401                    mask, (GFC_INTEGER_16 *) field);
402       return;
403 #endif
404     case GFC_DTYPE_REAL_4:
405       unpack0_r4 ((gfc_array_r4 *) ret, (gfc_array_r4 *) vector,
406                   mask, (GFC_REAL_4 *) field);
407       return;
408
409     case GFC_DTYPE_REAL_8:
410       unpack0_r8 ((gfc_array_r8 *) ret, (gfc_array_r8*) vector,
411                   mask, (GFC_REAL_8  *) field);
412       return;
413
414 #ifdef HAVE_GFC_REAL_10
415     case GFC_DTYPE_REAL_10:
416       unpack0_r10 ((gfc_array_r10 *) ret, (gfc_array_r10 *) vector,
417                    mask, (GFC_REAL_10 *) field);
418       return;
419 #endif
420
421 #ifdef HAVE_GFC_REAL_16
422     case GFC_DTYPE_REAL_16:
423       unpack0_r16 ((gfc_array_r16 *) ret, (gfc_array_r16 *) vector,
424                    mask, (GFC_REAL_16 *) field);
425       return;
426 #endif
427
428     case GFC_DTYPE_COMPLEX_4:
429       unpack0_c4 ((gfc_array_c4 *) ret, (gfc_array_c4 *) vector,
430                   mask, (GFC_COMPLEX_4 *) field);
431       return;
432
433     case GFC_DTYPE_COMPLEX_8:
434       unpack0_c8 ((gfc_array_c8 *) ret, (gfc_array_c8 *) vector,
435                   mask, (GFC_COMPLEX_8 *) field);
436       return;
437
438 #ifdef HAVE_GFC_COMPLEX_10
439     case GFC_DTYPE_COMPLEX_10:
440       unpack0_c10 ((gfc_array_c10 *) ret, (gfc_array_c10 *) vector,
441                    mask, (GFC_COMPLEX_10 *) field);
442       return;
443 #endif
444
445 #ifdef HAVE_GFC_COMPLEX_16
446     case GFC_DTYPE_COMPLEX_16:
447       unpack0_c16 ((gfc_array_c16 *) ret, (gfc_array_c16 *) vector,
448                    mask, (GFC_COMPLEX_16 *) field);
449       return;
450 #endif
451     case GFC_DTYPE_DERIVED_2:
452       if (GFC_UNALIGNED_2(ret->data) || GFC_UNALIGNED_2(vector->data)
453           || GFC_UNALIGNED_2(field))
454         break;
455       else
456         {
457           unpack0_i2 ((gfc_array_i2 *) ret, (gfc_array_i2 *) vector,
458                       mask, (GFC_INTEGER_2 *) field);
459           return;
460         }
461
462     case GFC_DTYPE_DERIVED_4:
463       if (GFC_UNALIGNED_4(ret->data) || GFC_UNALIGNED_4(vector->data)
464           || GFC_UNALIGNED_4(field))
465         break;
466       else
467         {
468           unpack0_i4 ((gfc_array_i4 *) ret, (gfc_array_i4 *) vector,
469                       mask, (GFC_INTEGER_4 *) field);
470           return;
471         }
472
473     case GFC_DTYPE_DERIVED_8:
474       if (GFC_UNALIGNED_8(ret->data) || GFC_UNALIGNED_8(vector->data)
475           || GFC_UNALIGNED_8(field))
476         break;
477       else
478         {
479           unpack0_i8 ((gfc_array_i8 *) ret, (gfc_array_i8 *) vector,
480                       mask, (GFC_INTEGER_8 *) field);
481           return;
482         }
483 #ifdef HAVE_GFC_INTEGER_16
484     case GFC_DTYPE_DERIVED_16:
485       if (GFC_UNALIGNED_16(ret->data) || GFC_UNALIGNED_16(vector->data)
486           || GFC_UNALIGNED_16(field))
487         break;
488       else
489         {
490           unpack0_i16 ((gfc_array_i16 *) ret, (gfc_array_i16 *) vector,
491                        mask, (GFC_INTEGER_16 *) field);
492           return;
493         }
494 #endif
495     }
496
497   memset (&tmp, 0, sizeof (tmp));
498   tmp.dtype = 0;
499   tmp.data = field;
500   unpack_internal (ret, vector, mask, &tmp, GFC_DESCRIPTOR_SIZE (vector), 0);
501 }
502
503 extern void unpack0_char (gfc_array_char *, GFC_INTEGER_4,
504                           const gfc_array_char *, const gfc_array_l1 *,
505                           char *, GFC_INTEGER_4, GFC_INTEGER_4);
506 export_proto(unpack0_char);
507
508 void
509 unpack0_char (gfc_array_char *ret,
510               GFC_INTEGER_4 ret_length __attribute__((unused)),
511               const gfc_array_char *vector, const gfc_array_l1 *mask,
512               char *field, GFC_INTEGER_4 vector_length,
513               GFC_INTEGER_4 field_length __attribute__((unused)))
514 {
515   gfc_array_char tmp;
516
517   memset (&tmp, 0, sizeof (tmp));
518   tmp.dtype = 0;
519   tmp.data = field;
520   unpack_internal (ret, vector, mask, &tmp, vector_length, 0);
521 }