1 /* Specific implementation of the UNPACK intrinsic
2 Copyright (C) 2008-2015 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
= xmallocarray (rs
, sizeof (GFC_COMPLEX_8
));
106 dim
= GFC_DESCRIPTOR_RANK (ret
);
107 /* Initialize to avoid -Wmaybe-uninitialized complaints. */
109 for (n
= 0; n
< dim
; n
++)
112 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
113 empty
= empty
|| extent
[n
] <= 0;
114 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
115 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
127 vstride0
= GFC_DESCRIPTOR_STRIDE(vector
,0);
130 rstride0
= rstride
[0];
131 mstride0
= mstride
[0];
132 rptr
= ret
->base_addr
;
133 vptr
= vector
->base_addr
;
148 /* Advance to the next element. */
153 while (count
[n
] == extent
[n
])
155 /* When we get to the end of a dimension, reset it and increment
156 the next dimension. */
158 /* We could precalculate these products, but this is a less
159 frequently used path so probably not worth it. */
160 rptr
-= rstride
[n
] * extent
[n
];
161 mptr
-= mstride
[n
] * extent
[n
];
165 /* Break out of the loop. */
180 unpack1_c8 (gfc_array_c8
*ret
, const gfc_array_c8
*vector
,
181 const gfc_array_l1
*mask
, const gfc_array_c8
*field
)
183 /* r.* indicates the return array. */
184 index_type rstride
[GFC_MAX_DIMENSIONS
];
187 GFC_COMPLEX_8
* restrict rptr
;
188 /* v.* indicates the vector array. */
191 /* f.* indicates the field array. */
192 index_type fstride
[GFC_MAX_DIMENSIONS
];
194 const GFC_COMPLEX_8
*fptr
;
195 /* m.* indicates the mask array. */
196 index_type mstride
[GFC_MAX_DIMENSIONS
];
198 const GFC_LOGICAL_1
*mptr
;
200 index_type count
[GFC_MAX_DIMENSIONS
];
201 index_type extent
[GFC_MAX_DIMENSIONS
];
210 mptr
= mask
->base_addr
;
212 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
213 and using shifting to address size and endian issues. */
215 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
217 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
218 #ifdef HAVE_GFC_LOGICAL_16
223 /* Do not convert a NULL pointer as we use test for NULL below. */
225 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
228 runtime_error ("Funny sized logical array");
230 if (ret
->base_addr
== NULL
)
232 /* The front end has signalled that we need to populate the
233 return array descriptor. */
234 dim
= GFC_DESCRIPTOR_RANK (mask
);
236 for (n
= 0; n
< dim
; n
++)
239 GFC_DIMENSION_SET(ret
->dim
[n
], 0,
240 GFC_DESCRIPTOR_EXTENT(mask
,n
) - 1, rs
);
241 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
242 empty
= empty
|| extent
[n
] <= 0;
243 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
244 fstride
[n
] = GFC_DESCRIPTOR_STRIDE(field
,n
);
245 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
249 ret
->base_addr
= xmallocarray (rs
, sizeof (GFC_COMPLEX_8
));
253 dim
= GFC_DESCRIPTOR_RANK (ret
);
254 /* Initialize to avoid -Wmaybe-uninitialized complaints. */
256 for (n
= 0; n
< dim
; n
++)
259 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
260 empty
= empty
|| extent
[n
] <= 0;
261 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
262 fstride
[n
] = GFC_DESCRIPTOR_STRIDE(field
,n
);
263 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
277 vstride0
= GFC_DESCRIPTOR_STRIDE(vector
,0);
280 rstride0
= rstride
[0];
281 fstride0
= fstride
[0];
282 mstride0
= mstride
[0];
283 rptr
= ret
->base_addr
;
284 fptr
= field
->base_addr
;
285 vptr
= vector
->base_addr
;
300 /* Advance to the next element. */
306 while (count
[n
] == extent
[n
])
308 /* When we get to the end of a dimension, reset it and increment
309 the next dimension. */
311 /* We could precalculate these products, but this is a less
312 frequently used path so probably not worth it. */
313 rptr
-= rstride
[n
] * extent
[n
];
314 fptr
-= fstride
[n
] * extent
[n
];
315 mptr
-= mstride
[n
] * extent
[n
];
319 /* Break out of the loop. */