1 /* Specific implementation of the UNPACK intrinsic
2 Copyright 2008 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 95 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 2 of the License, or (at your option) any later version.
13 In addition to the permissions in the GNU General Public License, the
14 Free Software Foundation gives you unlimited permission to link the
15 compiled version of this file into combinations with other programs,
16 and to distribute those combinations without any restriction coming
17 from the use of this file. (The General Public License restrictions
18 do apply in other respects; for example, they cover modification of
19 the file, and distribution when not linked into a combine
22 Ligbfortran is distributed in the hope that it will be useful,
23 but WITHOUT ANY WARRANTY; without even the implied warranty of
24 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25 GNU General Public License for more details.
27 You should have received a copy of the GNU General Public
28 License along with libgfortran; see the file COPYING. If not,
29 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
30 Boston, MA 02110-1301, USA. */
32 #include "libgfortran.h"
38 #if defined (HAVE_GFC_REAL_4)
41 unpack0_r4 (gfc_array_r4
*ret
, const gfc_array_r4
*vector
,
42 const gfc_array_l1
*mask
, const GFC_REAL_4
*fptr
)
44 /* r.* indicates the return array. */
45 index_type rstride
[GFC_MAX_DIMENSIONS
];
49 /* v.* indicates the vector array. */
52 /* Value for field, this is constant. */
53 const GFC_REAL_4 fval
= *fptr
;
54 /* m.* indicates the mask array. */
55 index_type mstride
[GFC_MAX_DIMENSIONS
];
57 const GFC_LOGICAL_1
*mptr
;
59 index_type count
[GFC_MAX_DIMENSIONS
];
60 index_type extent
[GFC_MAX_DIMENSIONS
];
71 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
72 and using shifting to address size and endian issues. */
74 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
76 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
77 #ifdef HAVE_GFC_LOGICAL_16
82 /* Do not convert a NULL pointer as we use test for NULL below. */
84 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
87 runtime_error ("Funny sized logical array");
89 if (ret
->data
== NULL
)
91 /* The front end has signalled that we need to populate the
92 return array descriptor. */
93 dim
= GFC_DESCRIPTOR_RANK (mask
);
95 for (n
= 0; n
< dim
; n
++)
98 ret
->dim
[n
].stride
= rs
;
99 ret
->dim
[n
].lbound
= 0;
100 ret
->dim
[n
].ubound
= mask
->dim
[n
].ubound
- mask
->dim
[n
].lbound
;
101 extent
[n
] = ret
->dim
[n
].ubound
+ 1;
102 empty
= empty
|| extent
[n
] <= 0;
103 rstride
[n
] = ret
->dim
[n
].stride
;
104 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
108 ret
->data
= internal_malloc_size (rs
* sizeof (GFC_REAL_4
));
112 dim
= GFC_DESCRIPTOR_RANK (ret
);
113 for (n
= 0; n
< dim
; n
++)
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
;
119 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
131 vstride0
= vector
->dim
[0].stride
;
134 rstride0
= rstride
[0];
135 mstride0
= mstride
[0];
152 /* Advance to the next element. */
157 while (count
[n
] == extent
[n
])
159 /* When we get to the end of a dimension, reset it and increment
160 the next dimension. */
162 /* We could precalculate these products, but this is a less
163 frequently used path so probably not worth it. */
164 rptr
-= rstride
[n
] * extent
[n
];
165 mptr
-= mstride
[n
] * extent
[n
];
169 /* Break out of the loop. */
184 unpack1_r4 (gfc_array_r4
*ret
, const gfc_array_r4
*vector
,
185 const gfc_array_l1
*mask
, const gfc_array_r4
*field
)
187 /* r.* indicates the return array. */
188 index_type rstride
[GFC_MAX_DIMENSIONS
];
192 /* v.* indicates the vector array. */
195 /* f.* indicates the field array. */
196 index_type fstride
[GFC_MAX_DIMENSIONS
];
198 const GFC_REAL_4
*fptr
;
199 /* m.* indicates the mask array. */
200 index_type mstride
[GFC_MAX_DIMENSIONS
];
202 const GFC_LOGICAL_1
*mptr
;
204 index_type count
[GFC_MAX_DIMENSIONS
];
205 index_type extent
[GFC_MAX_DIMENSIONS
];
216 /* Use the same loop for all logical types, by using GFC_LOGICAL_1
217 and using shifting to address size and endian issues. */
219 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
221 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
222 #ifdef HAVE_GFC_LOGICAL_16
227 /* Do not convert a NULL pointer as we use test for NULL below. */
229 mptr
= GFOR_POINTER_TO_L1 (mptr
, mask_kind
);
232 runtime_error ("Funny sized logical array");
234 if (ret
->data
== NULL
)
236 /* The front end has signalled that we need to populate the
237 return array descriptor. */
238 dim
= GFC_DESCRIPTOR_RANK (mask
);
240 for (n
= 0; n
< dim
; n
++)
243 ret
->dim
[n
].stride
= rs
;
244 ret
->dim
[n
].lbound
= 0;
245 ret
->dim
[n
].ubound
= mask
->dim
[n
].ubound
- mask
->dim
[n
].lbound
;
246 extent
[n
] = ret
->dim
[n
].ubound
+ 1;
247 empty
= empty
|| extent
[n
] <= 0;
248 rstride
[n
] = ret
->dim
[n
].stride
;
249 fstride
[n
] = field
->dim
[n
].stride
;
250 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
254 ret
->data
= internal_malloc_size (rs
* sizeof (GFC_REAL_4
));
258 dim
= GFC_DESCRIPTOR_RANK (ret
);
259 for (n
= 0; n
< dim
; n
++)
262 extent
[n
] = ret
->dim
[n
].ubound
+ 1 - ret
->dim
[n
].lbound
;
263 empty
= empty
|| extent
[n
] <= 0;
264 rstride
[n
] = ret
->dim
[n
].stride
;
265 fstride
[n
] = field
->dim
[n
].stride
;
266 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
280 vstride0
= vector
->dim
[0].stride
;
283 rstride0
= rstride
[0];
284 fstride0
= fstride
[0];
285 mstride0
= mstride
[0];
303 /* Advance to the next element. */
309 while (count
[n
] == extent
[n
])
311 /* When we get to the end of a dimension, reset it and increment
312 the next dimension. */
314 /* We could precalculate these products, but this is a less
315 frequently used path so probably not worth it. */
316 rptr
-= rstride
[n
] * extent
[n
];
317 fptr
-= fstride
[n
] * extent
[n
];
318 mptr
-= mstride
[n
] * extent
[n
];
322 /* Break out of the loop. */