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 = 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 }