OSDN Git Service

2009-08-20 Thomas Koenig <tkoenig@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / intrinsics / iso_c_binding.c
1 /* Implementation of the ISO_C_BINDING library helper functions.
2    Copyright (C) 2007, 2009 Free Software Foundation, Inc.
3    Contributed by Christopher Rickett.
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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
10 version 3 of the License, or (at your option) any later version.
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
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/>.  */
25
26
27 /* Implement the functions and subroutines provided by the intrinsic
28    iso_c_binding module.  */
29
30 #include "libgfortran.h"
31 #include "iso_c_binding.h"
32
33 #include <stdlib.h>
34
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
68       /* Set the data type (e.g., GFC_DTYPE_INTEGER).  */
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
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
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     {
97       index_type source_stride;
98       index_type size;
99       char *p;
100
101       f_ptr_out->offset = 0;
102       shapeSize = 0;
103       p = shape->data;
104       size = GFC_DESCRIPTOR_SIZE(shape);
105
106       source_stride = GFC_DESCRIPTOR_STRIDE_BYTES(shape,0);
107
108       /* shape's length (rank of the output array) */
109       shapeSize = GFC_DESCRIPTOR_EXTENT(shape,0);
110       for (i = 0; i < shapeSize; i++)
111         {
112           index_type str, ub;
113
114           /* Have to allow for the SHAPE array to be any valid kind for
115              an INTEGER type.  */
116           switch (size)
117             {
118 #ifdef HAVE_GFC_INTEGER_1
119               case 1:
120                 ub = *((GFC_INTEGER_1 *) p);
121                 break;
122 #endif
123 #ifdef HAVE_GFC_INTEGER_2
124               case 2:
125                 ub = *((GFC_INTEGER_2 *) p);
126                 break;
127 #endif
128 #ifdef HAVE_GFC_INTEGER_4
129               case 4:
130                 ub = *((GFC_INTEGER_4 *) p);
131                 break;
132 #endif
133 #ifdef HAVE_GFC_INTEGER_8
134               case 8:
135                 ub = *((GFC_INTEGER_8 *) p);
136                 break;
137 #endif
138 #ifdef HAVE_GFC_INTEGER_16
139               case 16:
140                 ub = *((GFC_INTEGER_16 *) p);
141                 break;
142 #endif
143               default:
144                 internal_error (NULL, "c_f_pointer_u0: Invalid size");
145             }
146           p += source_stride;
147
148           if (i == 0)
149             {
150               str = 1;
151               f_ptr_out->offset = str;
152             }
153           else
154             {
155               str = str * GFC_DESCRIPTOR_EXTENT(f_ptr_out,i-1);
156               f_ptr_out->offset += str;
157             }
158
159           /* Lower bound is 1, as specified by the draft.  */
160           GFC_DIMENSION_SET(f_ptr_out->dim[i], 1, ub, str);
161         }
162
163       f_ptr_out->offset *= -1;
164
165       /* All we know is the rank, so set it, leaving the rest alone.
166          Make NO assumptions about the state of dtype coming in!  If we
167          shift right by TYPE_SHIFT bits we'll throw away the existing
168          rank.  Then, shift left by the same number to shift in zeros
169          and or with the new rank.  */
170       f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT)
171                            << GFC_DTYPE_TYPE_SHIFT) | shapeSize;
172     }
173 }
174
175
176 /* Sets the descriptor fields for a Fortran pointer to a derived type,
177    using c_f_pointer_u0 for the majority of the work.  */
178
179 void
180 ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in,
181                                        gfc_array_void *f_ptr_out,
182                                        const array_t *shape)
183 {
184   /* Set the common fields.  */
185   ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape);
186
187   /* Preserve the size and rank bits, but reset the type.  */
188   if (shape != NULL)
189     {
190       f_ptr_out->dtype = f_ptr_out->dtype & (~GFC_DTYPE_TYPE_MASK);
191       f_ptr_out->dtype = f_ptr_out->dtype
192                          | (GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT);
193     }
194 }