1 /* Specific implementation of the UNPACK intrinsic
2 Copyright (C) 2008-2021 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"
31 #if defined (HAVE_GFC_INTEGER_2)
34 unpack0_i2 (gfc_array_i2
*ret
, const gfc_array_i2
*vector
,
35 const gfc_array_l1
*mask
, const GFC_INTEGER_2
*fptr
)
37 /* r.* indicates the return array. */
38 index_type rstride
[GFC_MAX_DIMENSIONS
];
41 GFC_INTEGER_2
* restrict rptr
;
42 /* v.* indicates the vector array. */
45 /* Value for field, this is constant. */
46 const GFC_INTEGER_2 fval
= *fptr
;
47 /* m.* indicates the mask array. */
48 index_type mstride
[GFC_MAX_DIMENSIONS
];
50 const GFC_LOGICAL_1
*mptr
;
52 index_type count
[GFC_MAX_DIMENSIONS
];
53 index_type extent
[GFC_MAX_DIMENSIONS
];
62 mptr
= mask
->base_addr
;
64 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
65 and using shifting to address size and endian issues. */
67 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
69 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
70 #ifdef HAVE_GFC_LOGICAL_16
75 /* Do not convert a NULL pointer as we use test for NULL below. */
77 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
80 runtime_error ("Funny sized logical array");
82 /* Initialize to avoid -Wmaybe-uninitialized complaints. */
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_INTEGER_2
));
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_i2 (gfc_array_i2
*ret
, const gfc_array_i2
*vector
,
179 const gfc_array_l1
*mask
, const gfc_array_i2
*field
)
181 /* r.* indicates the return array. */
182 index_type rstride
[GFC_MAX_DIMENSIONS
];
185 GFC_INTEGER_2
* restrict rptr
;
186 /* v.* indicates the vector array. */
189 /* f.* indicates the field array. */
190 index_type fstride
[GFC_MAX_DIMENSIONS
];
192 const GFC_INTEGER_2
*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 /* Initialize to avoid -Wmaybe-uninitialized complaints. */
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_INTEGER_2
));
253 dim
= GFC_DESCRIPTOR_RANK (ret
);
254 for (n
= 0; n
< dim
; n
++)
257 extent
[n
] = GFC_DESCRIPTOR_EXTENT(ret
,n
);
258 empty
= empty
|| extent
[n
] <= 0;
259 rstride
[n
] = GFC_DESCRIPTOR_STRIDE(ret
,n
);
260 fstride
[n
] = GFC_DESCRIPTOR_STRIDE(field
,n
);
261 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
275 vstride0
= GFC_DESCRIPTOR_STRIDE(vector
,0);
278 rstride0
= rstride
[0];
279 fstride0
= fstride
[0];
280 mstride0
= mstride
[0];
281 rptr
= ret
->base_addr
;
282 fptr
= field
->base_addr
;
283 vptr
= vector
->base_addr
;
298 /* Advance to the next element. */
304 while (count
[n
] == extent
[n
])
306 /* When we get to the end of a dimension, reset it and increment
307 the next dimension. */
309 /* We could precalculate these products, but this is a less
310 frequently used path so probably not worth it. */
311 rptr
-= rstride
[n
] * extent
[n
];
312 fptr
-= fstride
[n
] * extent
[n
];
313 mptr
-= mstride
[n
] * extent
[n
];
317 /* Break out of the loop. */