libgfortran/generated/findloc2_s1.c

   1 /* Implementation of the FINDLOC intrinsic
   2    Copyright (C) 2018-2020 Free Software Foundation, Inc.
   3    Contributed by Thomas König <tk@tkoenig.net>
   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 #include "libgfortran.h"
  27
  28 #ifdef HAVE_GFC_UINTEGER_1
  29 index_type findloc2_s1 (gfc_array_s1 * const restrict array,
  30                            const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 back,
  31                            gfc_charlen_type len_array, gfc_charlen_type len_value);
  32 export_proto(findloc2_s1);
  33
  34 index_type
  35 findloc2_s1 (gfc_array_s1 * const restrict array, const GFC_UINTEGER_1 * restrict value,
  36                       GFC_LOGICAL_4 back,
  37                       gfc_charlen_type len_array, gfc_charlen_type len_value)
  38 {
  39   index_type i;
  40   index_type sstride;
  41   index_type extent;
  42   const GFC_UINTEGER_1 * restrict src;
  43
  44   extent = GFC_DESCRIPTOR_EXTENT(array,0);
  45   if (extent <= 0)
  46     return 0;
  47
  48   sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
  49   if (back)
  50     {
  51       src = array->base_addr + (extent - 1) * sstride;
  52       for (i = extent; i >= 0; i--)
  53         {
  54           if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
  55             return i;
  56           src -= sstride;
  57         }
  58     }
  59   else
  60     {
  61       src = array->base_addr;
  62       for (i = 1; i <= extent; i++)
  63         {
  64           if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)
  65             return i;
  66           src += sstride;
  67         }
  68     }
  69   return 0;
  70 }
  71
  72 index_type mfindloc2_s1 (gfc_array_s1 * const restrict array,
  73                          const GFC_UINTEGER_1 * restrict value,
  74                          gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
  75                          gfc_charlen_type len_array, gfc_charlen_type len_value);
  76 export_proto(mfindloc2_s1);
  77
  78 index_type
  79 mfindloc2_s1 (gfc_array_s1 * const restrict array,
  80                            const GFC_UINTEGER_1 * restrict value, gfc_array_l1 *const restrict mask,
  81                            GFC_LOGICAL_4 back, gfc_charlen_type len_array,
  82                            gfc_charlen_type len_value)
  83 {
  84   index_type i;
  85   index_type sstride;
  86   index_type extent;
  87   const GFC_UINTEGER_1 * restrict src;
  88   const GFC_LOGICAL_1 * restrict mbase;
  89   int mask_kind;
  90   index_type mstride;
  91
  92   extent = GFC_DESCRIPTOR_EXTENT(array,0);
  93   if (extent <= 0)
  94     return 0;
  95
  96   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
  97   mbase = mask->base_addr;
  98
  99   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 100 #ifdef HAVE_GFC_LOGICAL_16
 101       || mask_kind == 16
 102 #endif
 103       )
 104     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 105   else
 106     internal_error (NULL, "Funny sized logical array");
 107
 108   sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array;
 109   mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
 110
 111   if (back)
 112     {
 113       src = array->base_addr + (extent - 1) * sstride;
 114       mbase += (extent - 1) * mstride;
 115       for (i = extent; i >= 0; i--)
 116         {
 117           if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0))
 118             return i;
 119           src -= sstride;
 120           mbase -= mstride;
 121         }
 122     }
 123   else
 124     {
 125       src = array->base_addr;
 126       for (i = 1; i <= extent; i++)
 127         {
 128           if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0))
 129             return i;
 130           src += sstride;
 131           mbase += mstride;
 132         }
 133     }
 134   return 0;
 135 }
 136 index_type sfindloc2_s1 (gfc_array_s1 * const restrict array,
 137                          const GFC_UINTEGER_1 * restrict value,
 138                          GFC_LOGICAL_4 *const restrict mask, GFC_LOGICAL_4 back,
 139                          gfc_charlen_type len_array, gfc_charlen_type len_value);
 140 export_proto(sfindloc2_s1);
 141
 142 index_type
 143 sfindloc2_s1 (gfc_array_s1 * const restrict array,
 144                            const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 *const restrict mask,
 145                            GFC_LOGICAL_4 back, gfc_charlen_type len_array,
 146                            gfc_charlen_type len_value)
 147 {
 148   if (mask == NULL || *mask)
 149     {
 150       return findloc2_s1 (array, value, back, len_array, len_value);
 151     }
 152   return 0;
 153 }
 154 #endif