Home | History | Annotate | Line # | Download | only in m4 
      1      1.1  mrg `/* Implementation of the FINDLOC intrinsic
      2  1.1.1.5  mrg    Copyright (C) 2018-2024 Free Software Foundation, Inc.
      3      1.1  mrg    Contributed by Thomas Knig <tk (a] tkoenig.net>
      4      1.1  mrg 
      5      1.1  mrg This file is part of the GNU Fortran 95 runtime library (libgfortran).
      6      1.1  mrg 
      7      1.1  mrg Libgfortran is free software; you can redistribute it and/or
      8      1.1  mrg modify it under the terms of the GNU General Public
      9      1.1  mrg License as published by the Free Software Foundation; either
     10      1.1  mrg version 3 of the License, or (at your option) any later version.
     11      1.1  mrg 
     12      1.1  mrg Libgfortran is distributed in the hope that it will be useful,
     13      1.1  mrg but WITHOUT ANY WARRANTY; without even the implied warranty of
     14      1.1  mrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     15      1.1  mrg GNU General Public License for more details.
     16      1.1  mrg 
     17      1.1  mrg Under Section 7 of GPL version 3, you are granted additional
     18      1.1  mrg permissions described in the GCC Runtime Library Exception, version
     19      1.1  mrg 3.1, as published by the Free Software Foundation.
     20      1.1  mrg 
     21      1.1  mrg You should have received a copy of the GNU General Public License and
     22      1.1  mrg a copy of the GCC Runtime Library Exception along with this program;
     23      1.1  mrg see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
     24      1.1  mrg <http://www.gnu.org/licenses/>.  */
     25      1.1  mrg 
     26      1.1  mrg #include "libgfortran.h"
     27      1.1  mrg 
     28      1.1  mrg #ifdef HAVE_'atype_name`'`
     29      1.1  mrg 'header1`'`
     30      1.1  mrg {
     31      1.1  mrg   index_type i;
     32      1.1  mrg   index_type sstride;
     33      1.1  mrg   index_type extent;
     34      1.1  mrg   const 'atype_name`'` * restrict src;
     35      1.1  mrg 
     36      1.1  mrg   extent = GFC_DESCRIPTOR_EXTENT(array,0);
     37      1.1  mrg   if (extent <= 0)
     38      1.1  mrg     return 0;
     39      1.1  mrg 
     40      1.1  mrg   sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`;
     41      1.1  mrg   if (back)
     42      1.1  mrg     {
     43      1.1  mrg       src = array->base_addr + (extent - 1) * sstride;
     44  1.1.1.4  mrg       for (i = extent; i > 0; i--)
     45      1.1  mrg 	{
     46      1.1  mrg 	  if ('comparison`'`)
     47      1.1  mrg 	    return i;
     48      1.1  mrg 	  src -= sstride;
     49      1.1  mrg 	}
     50      1.1  mrg     }
     51      1.1  mrg   else
     52      1.1  mrg     {
     53      1.1  mrg       src = array->base_addr;
     54      1.1  mrg       for (i = 1; i <= extent; i++)
     55      1.1  mrg 	{
     56      1.1  mrg 	  if ('comparison`'`)
     57      1.1  mrg 	    return i;
     58      1.1  mrg 	  src += sstride;
     59      1.1  mrg 	}
     60      1.1  mrg     }
     61      1.1  mrg   return 0;
     62      1.1  mrg }
     63      1.1  mrg 
     64      1.1  mrg 'header2`'`
     65      1.1  mrg {
     66      1.1  mrg   index_type i;
     67      1.1  mrg   index_type sstride;
     68      1.1  mrg   index_type extent;
     69      1.1  mrg   const 'atype_name`'` * restrict src;
     70      1.1  mrg   const GFC_LOGICAL_1 * restrict mbase;
     71      1.1  mrg   int mask_kind;
     72      1.1  mrg   index_type mstride;
     73      1.1  mrg 
     74      1.1  mrg   extent = GFC_DESCRIPTOR_EXTENT(array,0);
     75      1.1  mrg   if (extent <= 0)
     76      1.1  mrg     return 0;
     77      1.1  mrg 
     78      1.1  mrg   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
     79      1.1  mrg   mbase = mask->base_addr;
     80      1.1  mrg 
     81      1.1  mrg   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
     82      1.1  mrg #ifdef HAVE_GFC_LOGICAL_16
     83      1.1  mrg       || mask_kind == 16
     84      1.1  mrg #endif
     85      1.1  mrg       )
     86      1.1  mrg     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
     87      1.1  mrg   else
     88      1.1  mrg     internal_error (NULL, "Funny sized logical array");
     89      1.1  mrg 
     90      1.1  mrg   sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`;
     91      1.1  mrg   mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
     92      1.1  mrg 
     93      1.1  mrg   if (back)
     94      1.1  mrg     {
     95      1.1  mrg       src = array->base_addr + (extent - 1) * sstride;
     96      1.1  mrg       mbase += (extent - 1) * mstride;
     97  1.1.1.4  mrg       for (i = extent; i > 0; i--)
     98      1.1  mrg 	{
     99      1.1  mrg 	  if (*mbase && ('comparison`'`))
    100      1.1  mrg 	    return i;
    101      1.1  mrg 	  src -= sstride;
    102      1.1  mrg 	  mbase -= mstride;
    103      1.1  mrg 	}
    104      1.1  mrg     }
    105      1.1  mrg   else
    106      1.1  mrg     {
    107      1.1  mrg       src = array->base_addr;
    108      1.1  mrg       for (i = 1; i <= extent; i++)
    109      1.1  mrg 	{
    110      1.1  mrg 	  if (*mbase && ('comparison`'`))
    111      1.1  mrg 	    return i;
    112      1.1  mrg 	  src += sstride;
    113      1.1  mrg 	  mbase += mstride;
    114      1.1  mrg 	}
    115      1.1  mrg     }
    116      1.1  mrg   return 0;
    117      1.1  mrg }
    118      1.1  mrg 'header3`'`
    119      1.1  mrg {
    120      1.1  mrg   if (mask == NULL || *mask)
    121      1.1  mrg     {
    122      1.1  mrg       return findloc2_'atype_code` (array, value, back, len_array, len_value);
    123      1.1  mrg     }
    124      1.1  mrg   return 0;
    125      1.1  mrg }
    126      1.1  mrg #endif'
    127