| /* Implementation of the ISO_C_BINDING library helper functions. |
| Copyright (C) 2007-2013 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); |
| } |
| } |