Update copyright years.

[thirdparty/gcc.git] / libgfortran / m4 / minloc2s.m4

diff --git a/libgfortran/m4/minloc2s.m4 b/libgfortran/m4/minloc2s.m4
index b9a7fb65fcd3743fabff99c6c70a9cf843d5d5c4..068a58af259ee1ef933a5012810052922e09ac10 100644 (file)
--- a/libgfortran/m4/minloc2s.m4
+++ b/libgfortran/m4/minloc2s.m4
@@ -1,5 +1,5 @@
 `/* Implementation of the MINLOC intrinsic
-   Copyright 2017 Free Software Foundation, Inc.
+   Copyright (C) 2017-2024 Free Software Foundation, Inc.
    Contributed by Thomas Koenig
 
 This file is part of the GNU Fortran runtime library (libgfortran).
@@ -25,7 +25,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 
 #include "libgfortran.h"
 #include <stdlib.h>
-#include <string.h>'
+#include <string.h>
+#include <assert.h>'
 include(iparm.m4)dnl
 
 `#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)
@@ -39,17 +40,19 @@ compare_fcn (const 'atype_name` *a, const 'atype_name` *b, gfc_charlen_type n)
     return memcmp_char4 (a, b, n);
 }
 
-extern 'rtype_name` 'name`'rtype_qual`_'atype_code` ('atype` * const restrict, gfc_charlen_type);
+extern 'rtype_name` 'name`'rtype_qual`_'atype_code` ('atype` * const restrict'back_arg`,
+       gfc_charlen_type);
 export_proto('name`'rtype_qual`_'atype_code`);
 
 'rtype_name`
-'name`'rtype_qual`_'atype_code` ('atype` * const restrict array, gfc_charlen_type len)
+'name`'rtype_qual`_'atype_code` ('atype` * const restrict array'back_arg`,
+                               gfc_charlen_type len)
 {
   index_type ret;
   index_type sstride;
   index_type extent;
   const 'atype_name` *src;
-  const 'atype_name` *maxval;
+  const 'atype_name` *minval;
   index_type i;
 
   extent = GFC_DESCRIPTOR_EXTENT(array,0);
@@ -60,26 +63,29 @@ export_proto('name`'rtype_qual`_'atype_code`);
 
   ret = 1;
   src = array->base_addr;
-  maxval = src;
-  for (i=2; i<=extent; i++)
+  minval = NULL;
+  for (i=1; i<=extent; i++)
     {
-      src += sstride;
-      if (compare_fcn (src, maxval, len) < 0)
+      if (minval == NULL || (back ? compare_fcn (src, minval, len) <= 0 :
+                                   compare_fcn (src, minval, len) < 0))
       {
         ret = i;
-        maxval = src;
+        minval = src;
       }
+      src += sstride;
     }
   return ret;
 }
 
 extern 'rtype_name` m'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
-                    gfc_array_l1 *const restrict mask, gfc_charlen_type);
+                    gfc_array_l1 *const restrict mask'back_arg`,
+                   gfc_charlen_type);
 export_proto(m'name`'rtype_qual`_'atype_code`);
 
 'rtype_name`
 m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
-                                gfc_array_l1 * const restrict mask, gfc_charlen_type len)
+                                gfc_array_l1 * const restrict mask'back_arg`,
+                                gfc_charlen_type len)
 {
   index_type ret;
   index_type sstride;
@@ -128,7 +134,9 @@ m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
 
   for (i=j+1; i<=extent; i++)
     {
-      if (*mbase && compare_fcn (src, maxval, len) < 0)
+
+      if (*mbase && (back ? compare_fcn (src, maxval, len) <= 0 :
+                           compare_fcn (src, maxval, len) < 0))
       {
         ret = i;
         maxval = src;
@@ -140,15 +148,15 @@ m'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
 }
 
 extern 'rtype_name` s'name`'rtype_qual`_'atype_code` ('atype` * const restrict,
-                               GFC_LOGICAL_4 *mask, gfc_charlen_type);
+                               GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type);
 export_proto(s'name`'rtype_qual`_'atype_code`);
 
 'rtype_name`
 s'name`'rtype_qual`_'atype_code` ('atype` * const restrict array,
-                                GFC_LOGICAL_4 *mask, gfc_charlen_type len)
+                                GFC_LOGICAL_4 *mask'back_arg`, gfc_charlen_type len)
 {
   if (mask)
-    return 'name`'rtype_qual`_'atype_code` (array, len);
+    return 'name`'rtype_qual`_'atype_code` (array, len, back);
   else
     return 0;
 }