1 /* Specific implementation of the UNPACK intrinsic
2 Copyright (C) 2008-2014 Free Software Foundation, Inc.
3 Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
4 unpack_generic.c by Paul Brook <paul@nowt.org>.
6 This file is part of the GNU Fortran runtime library (libgfortran).
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
13 Ligbfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25 <http://www.gnu.org/licenses/>. */
27 #include "libgfortran.h"
33 #if defined (HAVE_GFC_COMPLEX_8)
36 unpack0_c8 (gfc_array_c8
*ret
, const gfc_array_c8
*vector
,
37 const gfc_array_l1
*mask
, const GFC_COMPLEX_8
*fptr
)
39 /* r.* indicates the return array. */
40 index_type rstride
[GFC_MAX_DIMENSIONS
];
43 GFC_COMPLEX_8
* restrict rptr
;
44 /* v.* indicates the vector array. */
47 /* Value for field, this is constant. */
48 const GFC_COMPLEX_8 fval
= *fptr
;
49 /* m.* indicates the mask array. */
50 index_type mstride
[GFC_MAX_DIMENSIONS
];
52 const GFC_LOGICAL_1
*mptr
;
54 index_type count
[GFC_MAX_DIMENSIONS
];
55 index_type extent
[GFC_MAX_DIMENSIONS
];
64 mptr
= mask
->base_addr
;
66 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
67 and using shifting to address size and endian issues. */
69 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
71 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
72 #ifdef HAVE_GFC_LOGICAL_16
77 /* Do not convert a NULL pointer as we use test for NULL below. */
79 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
82 runtime_error ("Funny sized logical array");
84 if (ret
->base_addr
== NULL
)
86 /* The front end has signalled that we need to populate the
87 return array descriptor. */
88 dim
= GFC_DESCRIPTOR_RANK (mask
);
90 for (n
= 0; n
< dim
; n
++)
93 GFC_DIMENSION_SET(ret
->dim
[n
], 0,
94 GFC_DESCRIPTOR_EXTENT(mask
,n
) - 1, rs
);
95 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
96 empty
= empty
|| extent
[n
] <= 0;
97 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
98 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
102 ret
->base_addr
= xmalloc (rs
* sizeof (GFC_COMPLEX_8
));
106 dim
= GFC_DESCRIPTOR_RANK (ret
);
107 for (n
= 0; n
< dim
; n
++)
110 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
111 empty
= empty
|| extent
[n
] <= 0;
112 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
113 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
125 vstride0
= GFC_DESCRIPTOR_STRIDE(vector
,0);
128 rstride0
= rstride
[0];
129 mstride0
= mstride
[0];
130 rptr
= ret
->base_addr
;
131 vptr
= vector
->base_addr
;
146 /* Advance to the next element. */
151 while (count
[n
] == extent
[n
])
153 /* When we get to the end of a dimension, reset it and increment
154 the next dimension. */
156 /* We could precalculate these products, but this is a less
157 frequently used path so probably not worth it. */
158 rptr
-= rstride
[n
] * extent
[n
];
159 mptr
-= mstride
[n
] * extent
[n
];
163 /* Break out of the loop. */
178 unpack1_c8 (gfc_array_c8
*ret
, const gfc_array_c8
*vector
,
179 const gfc_array_l1
*mask
, const gfc_array_c8
*field
)
181 /* r.* indicates the return array. */
182 index_type rstride
[GFC_MAX_DIMENSIONS
];
185 GFC_COMPLEX_8
* restrict rptr
;
186 /* v.* indicates the vector array. */
189 /* f.* indicates the field array. */
190 index_type fstride
[GFC_MAX_DIMENSIONS
];
192 const GFC_COMPLEX_8
*fptr
;
193 /* m.* indicates the mask array. */
194 index_type mstride
[GFC_MAX_DIMENSIONS
];
196 const GFC_LOGICAL_1
*mptr
;
198 index_type count
[GFC_MAX_DIMENSIONS
];
199 index_type extent
[GFC_MAX_DIMENSIONS
];
208 mptr
= mask
->base_addr
;
210 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
211 and using shifting to address size and endian issues. */
213 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
215 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
216 #ifdef HAVE_GFC_LOGICAL_16
221 /* Do not convert a NULL pointer as we use test for NULL below. */
223 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
226 runtime_error ("Funny sized logical array");
228 if (ret
->base_addr
== NULL
)
230 /* The front end has signalled that we need to populate the
231 return array descriptor. */
232 dim
= GFC_DESCRIPTOR_RANK (mask
);
234 for (n
= 0; n
< dim
; n
++)
237 GFC_DIMENSION_SET(ret
->dim
[n
], 0,
238 GFC_DESCRIPTOR_EXTENT(mask
,n
) - 1, rs
);
239 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
240 empty
= empty
|| extent
[n
] <= 0;
241 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
242 fstride
[n
] = GFC_DESCRIPTOR_STRIDE(field
,n
);
243 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
247 ret
->base_addr
= xmalloc (rs
* sizeof (GFC_COMPLEX_8
));
251 dim
= GFC_DESCRIPTOR_RANK (ret
);
252 for (n
= 0; n
< dim
; n
++)
255 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
256 empty
= empty
|| extent
[n
] <= 0;
257 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
258 fstride
[n
] = GFC_DESCRIPTOR_STRIDE(field
,n
);
259 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
273 vstride0
= GFC_DESCRIPTOR_STRIDE(vector
,0);
276 rstride0
= rstride
[0];
277 fstride0
= fstride
[0];
278 mstride0
= mstride
[0];
279 rptr
= ret
->base_addr
;
280 fptr
= field
->base_addr
;
281 vptr
= vector
->base_addr
;
296 /* Advance to the next element. */
302 while (count
[n
] == extent
[n
])
304 /* When we get to the end of a dimension, reset it and increment
305 the next dimension. */
307 /* We could precalculate these products, but this is a less
308 frequently used path so probably not worth it. */
309 rptr
-= rstride
[n
] * extent
[n
];
310 fptr
-= fstride
[n
] * extent
[n
];
311 mptr
-= mstride
[n
] * extent
[n
];
315 /* Break out of the loop. */