]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/runtime/in_pack_generic.c
1 /* Generic helper function for repacking arrays.
2 Copyright 2003, 2004, 2005, 2007, 2009 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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 3 of the License, or (at your option) any later version.
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 #include "libgfortran.h"
31 extern void *internal_pack (gfc_array_char
*);
32 export_proto(internal_pack
);
35 internal_pack (gfc_array_char
* source
)
37 index_type count
[GFC_MAX_DIMENSIONS
];
38 index_type extent
[GFC_MAX_DIMENSIONS
];
39 index_type stride
[GFC_MAX_DIMENSIONS
];
51 if (source
->dim
[0].stride
== 0)
53 source
->dim
[0].stride
= 1;
57 type_size
= GFC_DTYPE_TYPE_SIZE(source
);
58 size
= GFC_DESCRIPTOR_SIZE (source
);
61 case GFC_DTYPE_INTEGER_1
:
62 case GFC_DTYPE_LOGICAL_1
:
63 case GFC_DTYPE_DERIVED_1
:
64 return internal_pack_1 ((gfc_array_i1
*) source
);
66 case GFC_DTYPE_INTEGER_2
:
67 case GFC_DTYPE_LOGICAL_2
:
68 return internal_pack_2 ((gfc_array_i2
*) source
);
70 case GFC_DTYPE_INTEGER_4
:
71 case GFC_DTYPE_LOGICAL_4
:
72 return internal_pack_4 ((gfc_array_i4
*) source
);
74 case GFC_DTYPE_INTEGER_8
:
75 case GFC_DTYPE_LOGICAL_8
:
76 return internal_pack_8 ((gfc_array_i8
*) source
);
78 #if defined(HAVE_GFC_INTEGER_16)
79 case GFC_DTYPE_INTEGER_16
:
80 case GFC_DTYPE_LOGICAL_16
:
81 return internal_pack_16 ((gfc_array_i16
*) source
);
83 case GFC_DTYPE_REAL_4
:
84 return internal_pack_r4 ((gfc_array_r4
*) source
);
86 case GFC_DTYPE_REAL_8
:
87 return internal_pack_r8 ((gfc_array_r8
*) source
);
89 #if defined (HAVE_GFC_REAL_10)
90 case GFC_DTYPE_REAL_10
:
91 return internal_pack_r10 ((gfc_array_r10
*) source
);
94 #if defined (HAVE_GFC_REAL_16)
95 case GFC_DTYPE_REAL_16
:
96 return internal_pack_r16 ((gfc_array_r16
*) source
);
98 case GFC_DTYPE_COMPLEX_4
:
99 return internal_pack_c4 ((gfc_array_c4
*) source
);
101 case GFC_DTYPE_COMPLEX_8
:
102 return internal_pack_c8 ((gfc_array_c8
*) source
);
104 #if defined (HAVE_GFC_COMPLEX_10)
105 case GFC_DTYPE_COMPLEX_10
:
106 return internal_pack_c10 ((gfc_array_c10
*) source
);
109 #if defined (HAVE_GFC_COMPLEX_16)
110 case GFC_DTYPE_COMPLEX_16
:
111 return internal_pack_c16 ((gfc_array_c16
*) source
);
114 case GFC_DTYPE_DERIVED_2
:
115 if (GFC_UNALIGNED_2(source
->data
))
118 return internal_pack_2 ((gfc_array_i2
*) source
);
120 case GFC_DTYPE_DERIVED_4
:
121 if (GFC_UNALIGNED_4(source
->data
))
124 return internal_pack_4 ((gfc_array_i4
*) source
);
126 case GFC_DTYPE_DERIVED_8
:
127 if (GFC_UNALIGNED_8(source
->data
))
130 return internal_pack_8 ((gfc_array_i8
*) source
);
132 #ifdef HAVE_GFC_INTEGER_16
133 case GFC_DTYPE_DERIVED_16
:
134 if (GFC_UNALIGNED_16(source
->data
))
137 return internal_pack_16 ((gfc_array_i16
*) source
);
144 dim
= GFC_DESCRIPTOR_RANK (source
);
147 for (n
= 0; n
< dim
; n
++)
150 stride
[n
] = source
->dim
[n
].stride
;
151 extent
[n
] = source
->dim
[n
].ubound
+ 1 - source
->dim
[n
].lbound
;
159 if (ssize
!= stride
[n
])
168 /* Allocate storage for the destination. */
169 destptr
= internal_malloc_size (ssize
* size
);
170 dest
= (char *)destptr
;
172 stride0
= stride
[0] * size
;
177 memcpy(dest
, src
, size
);
178 /* Advance to the next element. */
182 /* Advance to the next source element. */
184 while (count
[n
] == extent
[n
])
186 /* When we get to the end of a dimension, reset it and increment
187 the next dimension. */
189 /* We could precalculate these products, but this is a less
190 frequently used path so probably not worth it. */
191 src
-= stride
[n
] * extent
[n
] * size
;
201 src
+= stride
[n
] * size
;