]>
Commit | Line | Data |
---|---|---|
a8b3b0b6 | 1 | /* Implementation of the ISO_C_BINDING library helper functions. |
e3c063ce | 2 | Copyright (C) 2007-2013 Free Software Foundation, Inc. |
a8b3b0b6 CR |
3 | Contributed by Christopher Rickett. |
4 | ||
21d1335b | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
a8b3b0b6 CR |
6 | |
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 | |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
a8b3b0b6 CR |
11 | |
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. | |
16 | ||
748086b7 JJ |
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. | |
20 | ||
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/>. */ | |
a8b3b0b6 CR |
25 | |
26 | ||
27 | /* Implement the functions and subroutines provided by the intrinsic | |
28 | iso_c_binding module. */ | |
29 | ||
a8b3b0b6 CR |
30 | #include "libgfortran.h" |
31 | #include "iso_c_binding.h" | |
32 | ||
36ae8a61 FXC |
33 | #include <stdlib.h> |
34 | ||
a8b3b0b6 CR |
35 | |
36 | /* Set the fields of a Fortran pointer descriptor to point to the | |
37 | given C address. It uses c_f_pointer_u0 for the common | |
38 | fields, and will set up the information necessary if this C address | |
39 | is to an array (i.e., offset, type, element size). The parameter | |
40 | c_ptr_in represents the C address to have Fortran point to. The | |
41 | parameter f_ptr_out is the Fortran pointer to associate with the C | |
42 | address. The parameter shape is a one-dimensional array of integers | |
43 | specifying the upper bound(s) of the array pointed to by the given C | |
44 | address, if applicable. The shape parameter is optional in Fortran, | |
45 | which will cause it to come in here as NULL. The parameter type is | |
46 | the type of the data being pointed to (i.e.,libgfortran.h). The | |
47 | elem_size parameter is the size, in bytes, of the data element being | |
48 | pointed to. If the address is for an array, then the size needs to | |
49 | be the size of a single element (i.e., for an array of doubles, it | |
50 | needs to be the number of bytes for the size of one double). */ | |
51 | ||
52 | void | |
53 | ISO_C_BINDING_PREFIX (c_f_pointer) (void *c_ptr_in, | |
54 | gfc_array_void *f_ptr_out, | |
55 | const array_t *shape, | |
56 | int type, int elemSize) | |
57 | { | |
58 | if (shape != NULL) | |
59 | { | |
60 | f_ptr_out->offset = 0; | |
61 | ||
62 | /* Set the necessary dtype field for all pointers. */ | |
63 | f_ptr_out->dtype = 0; | |
64 | ||
65 | /* Put in the element size. */ | |
66 | f_ptr_out->dtype = f_ptr_out->dtype | (elemSize << GFC_DTYPE_SIZE_SHIFT); | |
67 | ||
a11930ba | 68 | /* Set the data type (e.g., BT_INTEGER). */ |
a8b3b0b6 CR |
69 | f_ptr_out->dtype = f_ptr_out->dtype | (type << GFC_DTYPE_TYPE_SHIFT); |
70 | } | |
71 | ||
72 | /* Use the generic version of c_f_pointer to set common fields. */ | |
73 | ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape); | |
74 | } | |
75 | ||
76 | ||
77 | /* A generic function to set the common fields of all descriptors, no | |
dfb55fdc TK |
78 | matter whether it's to a scalar or an array. Access is via the array |
79 | descrptor macros. Parameter shape is a rank 1 array of integers | |
a8b3b0b6 CR |
80 | containing the upper bound of each dimension of what f_ptr_out |
81 | points to. The length of this array must be EXACTLY the rank of | |
82 | what f_ptr_out points to, as required by the draft (J3/04-007). If | |
83 | f_ptr_out points to a scalar, then this parameter will be NULL. */ | |
84 | ||
85 | void | |
86 | ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in, | |
87 | gfc_array_void *f_ptr_out, | |
88 | const array_t *shape) | |
89 | { | |
90 | int i = 0; | |
91 | int shapeSize = 0; | |
92 | ||
93 | GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in; | |
94 | ||
95 | if (shape != NULL) | |
96 | { | |
23db9913 JB |
97 | index_type source_stride, size; |
98 | index_type str = 1; | |
230fa1fc TK |
99 | char *p; |
100 | ||
23db9913 | 101 | f_ptr_out->offset = str; |
a8b3b0b6 | 102 | shapeSize = 0; |
21d1335b | 103 | p = shape->base_addr; |
230fa1fc TK |
104 | size = GFC_DESCRIPTOR_SIZE(shape); |
105 | ||
dfb55fdc | 106 | source_stride = GFC_DESCRIPTOR_STRIDE_BYTES(shape,0); |
230fa1fc | 107 | |
a8b3b0b6 | 108 | /* shape's length (rank of the output array) */ |
dfb55fdc | 109 | shapeSize = GFC_DESCRIPTOR_EXTENT(shape,0); |
a8b3b0b6 CR |
110 | for (i = 0; i < shapeSize; i++) |
111 | { | |
ee5111a4 | 112 | index_type ub; |
dfb55fdc | 113 | |
6ad5cf72 CR |
114 | /* Have to allow for the SHAPE array to be any valid kind for |
115 | an INTEGER type. */ | |
ffa61a5e TB |
116 | switch (size) |
117 | { | |
6ad5cf72 | 118 | #ifdef HAVE_GFC_INTEGER_1 |
ffa61a5e TB |
119 | case 1: |
120 | ub = *((GFC_INTEGER_1 *) p); | |
121 | break; | |
6ad5cf72 CR |
122 | #endif |
123 | #ifdef HAVE_GFC_INTEGER_2 | |
ffa61a5e TB |
124 | case 2: |
125 | ub = *((GFC_INTEGER_2 *) p); | |
126 | break; | |
6ad5cf72 CR |
127 | #endif |
128 | #ifdef HAVE_GFC_INTEGER_4 | |
ffa61a5e TB |
129 | case 4: |
130 | ub = *((GFC_INTEGER_4 *) p); | |
131 | break; | |
6ad5cf72 CR |
132 | #endif |
133 | #ifdef HAVE_GFC_INTEGER_8 | |
ffa61a5e TB |
134 | case 8: |
135 | ub = *((GFC_INTEGER_8 *) p); | |
136 | break; | |
6ad5cf72 CR |
137 | #endif |
138 | #ifdef HAVE_GFC_INTEGER_16 | |
ffa61a5e TB |
139 | case 16: |
140 | ub = *((GFC_INTEGER_16 *) p); | |
141 | break; | |
230fa1fc | 142 | #endif |
ffa61a5e TB |
143 | default: |
144 | internal_error (NULL, "c_f_pointer_u0: Invalid size"); | |
145 | } | |
230fa1fc TK |
146 | p += source_stride; |
147 | ||
23db9913 | 148 | if (i != 0) |
230fa1fc | 149 | { |
41e5ee68 | 150 | str = str * GFC_DESCRIPTOR_EXTENT(f_ptr_out,i-1); |
dfb55fdc | 151 | f_ptr_out->offset += str; |
230fa1fc | 152 | } |
dfb55fdc TK |
153 | |
154 | /* Lower bound is 1, as specified by the draft. */ | |
155 | GFC_DIMENSION_SET(f_ptr_out->dim[i], 1, ub, str); | |
a8b3b0b6 CR |
156 | } |
157 | ||
158 | f_ptr_out->offset *= -1; | |
159 | ||
160 | /* All we know is the rank, so set it, leaving the rest alone. | |
161 | Make NO assumptions about the state of dtype coming in! If we | |
162 | shift right by TYPE_SHIFT bits we'll throw away the existing | |
163 | rank. Then, shift left by the same number to shift in zeros | |
164 | and or with the new rank. */ | |
165 | f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT) | |
166 | << GFC_DTYPE_TYPE_SHIFT) | shapeSize; | |
167 | } | |
168 | } | |
169 | ||
170 | ||
171 | /* Sets the descriptor fields for a Fortran pointer to a derived type, | |
172 | using c_f_pointer_u0 for the majority of the work. */ | |
173 | ||
174 | void | |
175 | ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in, | |
176 | gfc_array_void *f_ptr_out, | |
177 | const array_t *shape) | |
178 | { | |
179 | /* Set the common fields. */ | |
180 | ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape); | |
181 | ||
182 | /* Preserve the size and rank bits, but reset the type. */ | |
183 | if (shape != NULL) | |
184 | { | |
185 | f_ptr_out->dtype = f_ptr_out->dtype & (~GFC_DTYPE_TYPE_MASK); | |
186 | f_ptr_out->dtype = f_ptr_out->dtype | |
a11930ba | 187 | | (BT_DERIVED << GFC_DTYPE_TYPE_SHIFT); |
a8b3b0b6 CR |
188 | } |
189 | } |