190 lines
6.3 KiB
C
190 lines
6.3 KiB
C
/* Implementation of the ISO_C_BINDING library helper functions.
|
|
Copyright (C) 2007-2016 Free Software Foundation, Inc.
|
|
Contributed by Christopher Rickett.
|
|
|
|
This file is part of the GNU Fortran runtime library (libgfortran).
|
|
|
|
Libgfortran is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU General Public
|
|
License as published by the Free Software Foundation; either
|
|
version 3 of the License, or (at your option) any later version.
|
|
|
|
Libgfortran is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
Under Section 7 of GPL version 3, you are granted additional
|
|
permissions described in the GCC Runtime Library Exception, version
|
|
3.1, as published by the Free Software Foundation.
|
|
|
|
You should have received a copy of the GNU General Public License and
|
|
a copy of the GCC Runtime Library Exception along with this program;
|
|
see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
|
|
<http://www.gnu.org/licenses/>. */
|
|
|
|
|
|
/* Implement the functions and subroutines provided by the intrinsic
|
|
iso_c_binding module. */
|
|
|
|
#include "libgfortran.h"
|
|
#include "iso_c_binding.h"
|
|
|
|
#include <stdlib.h>
|
|
|
|
|
|
/* Set the fields of a Fortran pointer descriptor to point to the
|
|
given C address. It uses c_f_pointer_u0 for the common
|
|
fields, and will set up the information necessary if this C address
|
|
is to an array (i.e., offset, type, element size). The parameter
|
|
c_ptr_in represents the C address to have Fortran point to. The
|
|
parameter f_ptr_out is the Fortran pointer to associate with the C
|
|
address. The parameter shape is a one-dimensional array of integers
|
|
specifying the upper bound(s) of the array pointed to by the given C
|
|
address, if applicable. The shape parameter is optional in Fortran,
|
|
which will cause it to come in here as NULL. The parameter type is
|
|
the type of the data being pointed to (i.e.,libgfortran.h). The
|
|
elem_size parameter is the size, in bytes, of the data element being
|
|
pointed to. If the address is for an array, then the size needs to
|
|
be the size of a single element (i.e., for an array of doubles, it
|
|
needs to be the number of bytes for the size of one double). */
|
|
|
|
void
|
|
ISO_C_BINDING_PREFIX (c_f_pointer) (void *c_ptr_in,
|
|
gfc_array_void *f_ptr_out,
|
|
const array_t *shape,
|
|
int type, int elemSize)
|
|
{
|
|
if (shape != NULL)
|
|
{
|
|
f_ptr_out->offset = 0;
|
|
|
|
/* Set the necessary dtype field for all pointers. */
|
|
f_ptr_out->dtype = 0;
|
|
|
|
/* Put in the element size. */
|
|
f_ptr_out->dtype = f_ptr_out->dtype | (elemSize << GFC_DTYPE_SIZE_SHIFT);
|
|
|
|
/* Set the data type (e.g., BT_INTEGER). */
|
|
f_ptr_out->dtype = f_ptr_out->dtype | (type << GFC_DTYPE_TYPE_SHIFT);
|
|
}
|
|
|
|
/* Use the generic version of c_f_pointer to set common fields. */
|
|
ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape);
|
|
}
|
|
|
|
|
|
/* A generic function to set the common fields of all descriptors, no
|
|
matter whether it's to a scalar or an array. Access is via the array
|
|
descrptor macros. Parameter shape is a rank 1 array of integers
|
|
containing the upper bound of each dimension of what f_ptr_out
|
|
points to. The length of this array must be EXACTLY the rank of
|
|
what f_ptr_out points to, as required by the draft (J3/04-007). If
|
|
f_ptr_out points to a scalar, then this parameter will be NULL. */
|
|
|
|
void
|
|
ISO_C_BINDING_PREFIX (c_f_pointer_u0) (void *c_ptr_in,
|
|
gfc_array_void *f_ptr_out,
|
|
const array_t *shape)
|
|
{
|
|
int i = 0;
|
|
int shapeSize = 0;
|
|
|
|
GFC_DESCRIPTOR_DATA (f_ptr_out) = c_ptr_in;
|
|
|
|
if (shape != NULL)
|
|
{
|
|
index_type source_stride, size;
|
|
index_type str = 1;
|
|
char *p;
|
|
|
|
f_ptr_out->offset = str;
|
|
shapeSize = 0;
|
|
p = shape->base_addr;
|
|
size = GFC_DESCRIPTOR_SIZE(shape);
|
|
|
|
source_stride = GFC_DESCRIPTOR_STRIDE_BYTES(shape,0);
|
|
|
|
/* shape's length (rank of the output array) */
|
|
shapeSize = GFC_DESCRIPTOR_EXTENT(shape,0);
|
|
for (i = 0; i < shapeSize; i++)
|
|
{
|
|
index_type ub;
|
|
|
|
/* Have to allow for the SHAPE array to be any valid kind for
|
|
an INTEGER type. */
|
|
switch (size)
|
|
{
|
|
#ifdef HAVE_GFC_INTEGER_1
|
|
case 1:
|
|
ub = *((GFC_INTEGER_1 *) p);
|
|
break;
|
|
#endif
|
|
#ifdef HAVE_GFC_INTEGER_2
|
|
case 2:
|
|
ub = *((GFC_INTEGER_2 *) p);
|
|
break;
|
|
#endif
|
|
#ifdef HAVE_GFC_INTEGER_4
|
|
case 4:
|
|
ub = *((GFC_INTEGER_4 *) p);
|
|
break;
|
|
#endif
|
|
#ifdef HAVE_GFC_INTEGER_8
|
|
case 8:
|
|
ub = *((GFC_INTEGER_8 *) p);
|
|
break;
|
|
#endif
|
|
#ifdef HAVE_GFC_INTEGER_16
|
|
case 16:
|
|
ub = *((GFC_INTEGER_16 *) p);
|
|
break;
|
|
#endif
|
|
default:
|
|
internal_error (NULL, "c_f_pointer_u0: Invalid size");
|
|
}
|
|
p += source_stride;
|
|
|
|
if (i != 0)
|
|
{
|
|
str = str * GFC_DESCRIPTOR_EXTENT(f_ptr_out,i-1);
|
|
f_ptr_out->offset += str;
|
|
}
|
|
|
|
/* Lower bound is 1, as specified by the draft. */
|
|
GFC_DIMENSION_SET(f_ptr_out->dim[i], 1, ub, str);
|
|
}
|
|
|
|
f_ptr_out->offset *= -1;
|
|
|
|
/* All we know is the rank, so set it, leaving the rest alone.
|
|
Make NO assumptions about the state of dtype coming in! If we
|
|
shift right by TYPE_SHIFT bits we'll throw away the existing
|
|
rank. Then, shift left by the same number to shift in zeros
|
|
and or with the new rank. */
|
|
f_ptr_out->dtype = ((f_ptr_out->dtype >> GFC_DTYPE_TYPE_SHIFT)
|
|
<< GFC_DTYPE_TYPE_SHIFT) | shapeSize;
|
|
}
|
|
}
|
|
|
|
|
|
/* Sets the descriptor fields for a Fortran pointer to a derived type,
|
|
using c_f_pointer_u0 for the majority of the work. */
|
|
|
|
void
|
|
ISO_C_BINDING_PREFIX (c_f_pointer_d0) (void *c_ptr_in,
|
|
gfc_array_void *f_ptr_out,
|
|
const array_t *shape)
|
|
{
|
|
/* Set the common fields. */
|
|
ISO_C_BINDING_PREFIX (c_f_pointer_u0) (c_ptr_in, f_ptr_out, shape);
|
|
|
|
/* Preserve the size and rank bits, but reset the type. */
|
|
if (shape != NULL)
|
|
{
|
|
f_ptr_out->dtype = f_ptr_out->dtype & (~GFC_DTYPE_TYPE_MASK);
|
|
f_ptr_out->dtype = f_ptr_out->dtype
|
|
| (BT_DERIVED << GFC_DTYPE_TYPE_SHIFT);
|
|
}
|
|
}
|