libgfortran/generated/minloc2_4_s1.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright 2017 Free Software Foundation, Inc.
   3    Contributed by Thomas Koenig
   4
   5 This file is part of the GNU Fortran 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 #include "libgfortran.h"
  27 #include <stdlib.h>
  28 #include <string.h>
  29
  30 #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
  31
  32 static inline int
  33 compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
  34 {
  35   if (sizeof (GFC_INTEGER_1) == 1)
  36     return memcmp (a, b, n);
  37   else
  38     return memcmp_char4 (a, b, n);
  39 }
  40
  41 extern GFC_INTEGER_4 minloc2_4_s1 (gfc_array_s1 * const restrict, gfc_charlen_type);
  42 export_proto(minloc2_4_s1);
  43
  44 GFC_INTEGER_4
  45 minloc2_4_s1 (gfc_array_s1 * const restrict array, gfc_charlen_type len)
  46 {
  47   index_type ret;
  48   index_type sstride;
  49   index_type extent;
  50   const GFC_INTEGER_1 *src;
  51   const GFC_INTEGER_1 *maxval;
  52   index_type i;
  53
  54   extent = GFC_DESCRIPTOR_EXTENT(array,0);
  55   if (extent <= 0)
  56     return 0;
  57
  58   sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
  59
  60   ret = 1;
  61   src = array->base_addr;
  62   maxval = src;
  63   for (i=2; i<=extent; i++)
  64     {
  65       src += sstride;
  66       if (compare_fcn (src, maxval, len) < 0)
  67       {
  68          ret = i;
  69          maxval = src;
  70       }
  71     }
  72   return ret;
  73 }
  74
  75 extern GFC_INTEGER_4 mminloc2_4_s1 (gfc_array_s1 * const restrict,
  76                     gfc_array_l1 *const restrict mask, gfc_charlen_type);
  77 export_proto(mminloc2_4_s1);
  78
  79 GFC_INTEGER_4
  80 mminloc2_4_s1 (gfc_array_s1 * const restrict array,
  81                                  gfc_array_l1 * const restrict mask, gfc_charlen_type len)
  82 {
  83   index_type ret;
  84   index_type sstride;
  85   index_type extent;
  86   const GFC_INTEGER_1 *src;
  87   const GFC_INTEGER_1 *maxval;
  88   index_type i, j;
  89   GFC_LOGICAL_1 *mbase;
  90   int mask_kind;
  91   index_type mstride;
  92
  93   extent = GFC_DESCRIPTOR_EXTENT(array,0);
  94   if (extent <= 0)
  95     return 0;
  96
  97   sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
  98
  99   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 100   mbase = mask->base_addr;
 101
 102   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 103 #ifdef HAVE_GFC_LOGICAL_16
 104       || mask_kind == 16
 105 #endif
 106       )
 107     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 108   else
 109     internal_error (NULL, "Funny sized logical array");
 110
 111   mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
 112
 113   /* Search for the first occurrence of a true element in mask. */
 114   for (j=0; j<extent; j++)
 115     {
 116       if (*mbase)
 117         break;
 118       mbase += mstride;
 119     }
 120
 121   if (j == extent)
 122     return 0;
 123
 124   ret = j + 1;
 125   src = array->base_addr + j * sstride;
 126   maxval = src;
 127
 128   for (i=j+1; i<=extent; i++)
 129     {
 130       if (*mbase && compare_fcn (src, maxval, len) < 0)
 131       {
 132          ret = i;
 133          maxval = src;
 134       }
 135       src += sstride;
 136       mbase += mstride;
 137     }
 138   return ret;
 139 }
 140
 141 extern GFC_INTEGER_4 sminloc2_4_s1 (gfc_array_s1 * const restrict,
 142                         GFC_LOGICAL_4 *mask, gfc_charlen_type);
 143 export_proto(sminloc2_4_s1);
 144
 145 GFC_INTEGER_4
 146 sminloc2_4_s1 (gfc_array_s1 * const restrict array,
 147                                  GFC_LOGICAL_4 *mask, gfc_charlen_type len)
 148 {
 149   if (mask)
 150     return minloc2_4_s1 (array, len);
 151   else
 152     return 0;
 153 }
 154
 155 #endif