maxloc2_8_s1.c revision 1.1.1.2 
1/* Implementation of the MAXLOC intrinsic
2   Copyright (C) 2017-2020 Free Software Foundation, Inc.
3   Contributed by Thomas Koenig
4
5This file is part of the GNU Fortran runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Libgfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see 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#include <assert.h>
30
31#if defined (HAVE_GFC_UINTEGER_1) && defined (HAVE_GFC_INTEGER_8)
32
33static inline int
34compare_fcn (const GFC_UINTEGER_1 *a, const GFC_UINTEGER_1 *b, gfc_charlen_type n)
35{
36  if (sizeof (GFC_UINTEGER_1) == 1)
37    return memcmp (a, b, n);
38  else
39    return memcmp_char4 (a, b, n);
40}
41
42extern GFC_INTEGER_8 maxloc2_8_s1 (gfc_array_s1 * const restrict, GFC_LOGICAL_4 back,
43       gfc_charlen_type);
44export_proto(maxloc2_8_s1);
45
46GFC_INTEGER_8
47maxloc2_8_s1 (gfc_array_s1 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
48{
49  index_type ret;
50  index_type sstride;
51  index_type extent;
52  const GFC_UINTEGER_1 *src;
53  const GFC_UINTEGER_1 *maxval;
54  index_type i;
55
56  extent = GFC_DESCRIPTOR_EXTENT(array,0);
57  if (extent <= 0)
58    return 0;
59
60  sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
61
62  ret = 1;
63  src = array->base_addr;
64  maxval = NULL;
65  for (i=1; i<=extent; i++)
66    {
67      if (maxval == NULL || (back ? compare_fcn (src, maxval, len) >= 0 :
68      	 	    	    	    compare_fcn (src, maxval, len) > 0))
69      {
70	 ret = i;
71	 maxval = src;
72      }
73      src += sstride;
74    }
75  return ret;
76}
77
78extern GFC_INTEGER_8 mmaxloc2_8_s1 (gfc_array_s1 * const restrict,
79       		    	gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
80			gfc_charlen_type);
81export_proto(mmaxloc2_8_s1);
82
83GFC_INTEGER_8
84mmaxloc2_8_s1 (gfc_array_s1 * const restrict array,
85				 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
86				 gfc_charlen_type len)
87{
88  index_type ret;
89  index_type sstride;
90  index_type extent;
91  const GFC_UINTEGER_1 *src;
92  const GFC_UINTEGER_1 *maxval;
93  index_type i, j;
94  GFC_LOGICAL_1 *mbase;
95  int mask_kind;
96  index_type mstride;
97
98  extent = GFC_DESCRIPTOR_EXTENT(array,0);
99  if (extent <= 0)
100    return 0;
101
102  sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
103
104  mask_kind = GFC_DESCRIPTOR_SIZE (mask);
105  mbase = mask->base_addr;
106
107  if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
108#ifdef HAVE_GFC_LOGICAL_16
109      || mask_kind == 16
110#endif
111      )
112    mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
113  else
114    internal_error (NULL, "Funny sized logical array");
115
116  mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
117
118  /* Search for the first occurrence of a true element in mask. */
119  for (j=0; j<extent; j++)
120    {
121      if (*mbase)
122        break;
123      mbase += mstride;
124    }
125
126  if (j == extent)
127    return 0;
128
129  ret = j + 1;
130  src = array->base_addr + j * sstride;
131  maxval = src;
132
133  for (i=j+1; i<=extent; i++)
134    {
135      if (*mbase && (back ? compare_fcn (src, maxval, len) >= 0 :
136      	 	    	   compare_fcn (src, maxval, len) > 0))
137      {
138	 ret = i;
139	 maxval = src;
140      }
141      src += sstride;
142      mbase += mstride;
143    }
144  return ret;
145}
146
147extern GFC_INTEGER_8 smaxloc2_8_s1 (gfc_array_s1 * const restrict,
148                               GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type);
149export_proto(smaxloc2_8_s1);
150
151GFC_INTEGER_8
152smaxloc2_8_s1 (gfc_array_s1 * const restrict array,
153				 GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
154{
155  if (mask)
156    return maxloc2_8_s1 (array, len, back);
157  else
158    return 0;
159}
160
161#endif
162