/* Implementation of the ISO_C_BINDING library helper functions.
- Copyright (C) 2007 Free Software Foundation, Inc.
+ Copyright (C) 2007, 2009 Free Software Foundation, Inc.
Contributed by Christopher Rickett.
This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.
-
-In addition to the permissions in the GNU General Public License, the
-Free Software Foundation gives you unlimited permission to link the
-compiled version of this file into combinations with other programs,
-and to distribute those combinations without any restriction coming
-from the use of this file. (The General Public License restrictions
-do apply in other respects; for example, they cover modification of
-the file, and distribution when not linked into a combine
-executable.)
+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.
-You should have received a copy of the GNU General Public
-License along with libgfortran; see the file COPYING. If not,
-write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-Boston, MA 02110-1301, USA. */
+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
/* A generic function to set the common fields of all descriptors, no
- matter whether it's to a scalar or an array. Fields set are: data,
- and if appropriate, rank, offset, dim[*].lbound, dim[*].ubound, and
- dim[*].stride. Parameter shape is a rank 1 array of integers
+ 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
if (shape != NULL)
{
+ index_type source_stride;
+ index_type size;
+ char *p;
+
f_ptr_out->offset = 0;
shapeSize = 0;
-
+ p = shape->data;
+ size = GFC_DESCRIPTOR_SIZE(shape);
+
+ source_stride = GFC_DESCRIPTOR_STRIDE_BYTES(shape,0);
+
/* shape's length (rank of the output array) */
- shapeSize = shape->dim[0].ubound + 1 - shape->dim[0].lbound;
+ shapeSize = GFC_DESCRIPTOR_EXTENT(shape,0);
for (i = 0; i < shapeSize; i++)
{
- /* Lower bound is 1, as specified by the draft. */
- f_ptr_out->dim[i].lbound = 1;
+ index_type str, ub;
+
/* Have to allow for the SHAPE array to be any valid kind for
an INTEGER type. */
+ switch (size)
+ {
#ifdef HAVE_GFC_INTEGER_1
- if (GFC_DESCRIPTOR_SIZE (shape) == 1)
- f_ptr_out->dim[i].ubound = ((GFC_INTEGER_1 *) (shape->data))[i];
+ case 1:
+ ub = *((GFC_INTEGER_1 *) p);
+ break;
#endif
#ifdef HAVE_GFC_INTEGER_2
- if (GFC_DESCRIPTOR_SIZE (shape) == 2)
- f_ptr_out->dim[i].ubound = ((GFC_INTEGER_2 *) (shape->data))[i];
+ case 2:
+ ub = *((GFC_INTEGER_2 *) p);
+ break;
#endif
#ifdef HAVE_GFC_INTEGER_4
- if (GFC_DESCRIPTOR_SIZE (shape) == 4)
- f_ptr_out->dim[i].ubound = ((GFC_INTEGER_4 *) (shape->data))[i];
+ case 4:
+ ub = *((GFC_INTEGER_4 *) p);
+ break;
#endif
#ifdef HAVE_GFC_INTEGER_8
- if (GFC_DESCRIPTOR_SIZE (shape) == 8)
- f_ptr_out->dim[i].ubound = ((GFC_INTEGER_8 *) (shape->data))[i];
+ case 8:
+ ub = *((GFC_INTEGER_8 *) p);
+ break;
#endif
#ifdef HAVE_GFC_INTEGER_16
- if (GFC_DESCRIPTOR_SIZE (shape) == 16)
- f_ptr_out->dim[i].ubound = ((GFC_INTEGER_16 *) (shape->data))[i];
-#endif
- }
+ 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 = 1;
+ f_ptr_out->offset = str;
+ }
+ else
+ {
+ str = str * GFC_DESCRIPTOR_EXTENT(f_ptr_out,i-1);
+ f_ptr_out->offset += str;
+ }
- /* Set the offset and strides.
- offset is (sum of (dim[i].lbound * dim[i].stride) for all
- dims) the -1 means we'll back the data pointer up that much
- perhaps we could just realign the data pointer and not change
- the offset? */
- f_ptr_out->dim[0].stride = 1;
- f_ptr_out->offset = f_ptr_out->dim[0].lbound * f_ptr_out->dim[0].stride;
- for (i = 1; i < shapeSize; i++)
- {
- f_ptr_out->dim[i].stride = (f_ptr_out->dim[i-1].ubound + 1)
- - f_ptr_out->dim[i-1].lbound;
- f_ptr_out->offset += f_ptr_out->dim[i].lbound
- * f_ptr_out->dim[i].stride;
+ /* 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;
| (GFC_DTYPE_DERIVED << GFC_DTYPE_TYPE_SHIFT);
}
}
-
-
-/* This function will change, once there is an actual f90 type for the
- procedure pointer. */
-
-void
-ISO_C_BINDING_PREFIX (c_f_procpointer) (void *c_ptr_in,
- gfc_array_void *f_ptr_out)
-{
- GFC_DESCRIPTOR_DATA(f_ptr_out) = c_ptr_in;
-}
-
-
-/* Test if the given c_ptr is associated or not. This function is
- called if the user only supplied one c_ptr parameter to the
- c_associated function. The second argument is optional, and the
- Fortran compiler will resolve the function to this version if only
- one arg was given. Associated here simply means whether or not the
- c_ptr is NULL or not. */
-
-GFC_LOGICAL_4
-ISO_C_BINDING_PREFIX (c_associated_1) (void *c_ptr_in_1)
-{
- if (c_ptr_in_1 != NULL)
- return 1;
- else
- return 0;
-}
-
-
-/* Test if the two c_ptr arguments are associated with one another.
- This version of the c_associated function is called if the user
- supplied two c_ptr args in the Fortran source. According to the
- draft standard (J3/04-007), if c_ptr_in_1 is NULL, the two pointers
- are NOT associated. If c_ptr_in_1 is non-NULL and it is not equal
- to c_ptr_in_2, then either c_ptr_in_2 is NULL or is associated with
- another address; either way, the two pointers are not associated
- with each other then. */
-
-GFC_LOGICAL_4
-ISO_C_BINDING_PREFIX (c_associated_2) (void *c_ptr_in_1, void *c_ptr_in_2)
-{
- /* Since we have the second arg, if it doesn't equal the first,
- return false; true otherwise. However, if the first one is null,
- then return false; otherwise compare the two ptrs for equality. */
- if (c_ptr_in_1 == NULL)
- return 0;
- else if (c_ptr_in_1 != c_ptr_in_2)
- return 0;
- else
- return 1;
-}
OSDN Git Service
