libgfortran/generated/minloc1_4_s1.c

   1 /* Implementation of the MINLOC intrinsic
   2    Copyright (C) 2017-2018 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
  28
  29 #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
  30
  31 #include <string.h>
  32
  33 static inline int
  34 compare_fcn (const GFC_INTEGER_1 *a, const GFC_INTEGER_1 *b, gfc_charlen_type n)
  35 {
  36   if (sizeof (GFC_INTEGER_1) == 1)
  37     return memcmp (a, b, n);
  38   else
  39     return memcmp_char4 (a, b, n);
  40 }
  41
  42 extern void minloc1_4_s1 (gfc_array_i4 * const restrict,
  43         gfc_array_s1 * const restrict, const index_type * const restrict,
  44         gfc_charlen_type);
  45 export_proto(minloc1_4_s1);
  46
  47 void
  48 minloc1_4_s1 (gfc_array_i4 * const restrict retarray,
  49         gfc_array_s1 * const restrict array,
  50         const index_type * const restrict pdim, gfc_charlen_type string_len)
  51 {
  52   index_type count[GFC_MAX_DIMENSIONS];
  53   index_type extent[GFC_MAX_DIMENSIONS];
  54   index_type sstride[GFC_MAX_DIMENSIONS];
  55   index_type dstride[GFC_MAX_DIMENSIONS];
  56   const GFC_INTEGER_1 * restrict base;
  57   GFC_INTEGER_4 * restrict dest;
  58   index_type rank;
  59   index_type n;
  60   index_type len;
  61   index_type delta;
  62   index_type dim;
  63   int continue_loop;
  64
  65   /* Make dim zero based to avoid confusion.  */
  66   rank = GFC_DESCRIPTOR_RANK (array) - 1;
  67   dim = (*pdim) - 1;
  68
  69   if (unlikely (dim < 0 || dim > rank))
  70     {
  71       runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
  72                      "is %ld, should be between 1 and %ld",
  73                      (long int) dim + 1, (long int) rank + 1);
  74     }
  75
  76   len = GFC_DESCRIPTOR_EXTENT(array,dim);
  77   if (len < 0)
  78     len = 0;
  79   delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
  80
  81   for (n = 0; n < dim; n++)
  82     {
  83       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
  84       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
  85
  86       if (extent[n] < 0)
  87         extent[n] = 0;
  88     }
  89   for (n = dim; n < rank; n++)
  90     {
  91       sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len;
  92       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
  93
  94       if (extent[n] < 0)
  95         extent[n] = 0;
  96     }
  97
  98   if (retarray->base_addr == NULL)
  99     {
 100       size_t alloc_size, str;
 101
 102       for (n = 0; n < rank; n++)
 103         {
 104           if (n == 0)
 105             str = 1;
 106           else
 107             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 108
 109           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 110
 111         }
 112
 113       retarray->offset = 0;
 114       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 115
 116       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 117
 118       retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 119       if (alloc_size == 0)
 120         {
 121           /* Make sure we have a zero-sized array.  */
 122           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 123           return;
 124
 125         }
 126     }
 127   else
 128     {
 129       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 130         runtime_error ("rank of return array incorrect in"
 131                        " MINLOC intrinsic: is %ld, should be %ld",
 132                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 133                        (long int) rank);
 134
 135       if (unlikely (compile_options.bounds_check))
 136         bounds_ifunction_return ((array_t *) retarray, extent,
 137                                  "return value", "MINLOC");
 138     }
 139
 140   for (n = 0; n < rank; n++)
 141     {
 142       count[n] = 0;
 143       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 144       if (extent[n] <= 0)
 145         return;
 146     }
 147
 148   base = array->base_addr;
 149   dest = retarray->base_addr;
 150
 151   continue_loop = 1;
 152   while (continue_loop)
 153     {
 154       const GFC_INTEGER_1 * restrict src;
 155       GFC_INTEGER_4 result;
 156       src = base;
 157       {
 158
 159         const GFC_INTEGER_1 *minval;
 160         minval = base;
 161         result = 1;
 162         if (len <= 0)
 163           *dest = 0;
 164         else
 165           {
 166             for (n = 0; n < len; n++, src += delta)
 167               {
 168
 169                 if (compare_fcn (src, minval, string_len) < 0)
 170                   {
 171                     minval = src;
 172                     result = (GFC_INTEGER_4)n + 1;
 173                   }
 174               }
 175
 176             *dest = result;
 177           }
 178       }
 179       /* Advance to the next element.  */
 180       count[0]++;
 181       base += sstride[0];
 182       dest += dstride[0];
 183       n = 0;
 184       while (count[n] == extent[n])
 185         {
 186           /* When we get to the end of a dimension, reset it and increment
 187              the next dimension.  */
 188           count[n] = 0;
 189           /* We could precalculate these products, but this is a less
 190              frequently used path so probably not worth it.  */
 191           base -= sstride[n] * extent[n];
 192           dest -= dstride[n] * extent[n];
 193           n++;
 194           if (n >= rank)
 195             {
 196               /* Break out of the loop.  */
 197               continue_loop = 0;
 198               break;
 199             }
 200           else
 201             {
 202               count[n]++;
 203               base += sstride[n];
 204               dest += dstride[n];
 205             }
 206         }
 207     }
 208 }
 209
 210
 211 extern void mminloc1_4_s1 (gfc_array_i4 * const restrict,
 212         gfc_array_s1 * const restrict, const index_type * const restrict,
 213         gfc_array_l1 * const restrict, gfc_charlen_type);
 214 export_proto(mminloc1_4_s1);
 215
 216 void
 217 mminloc1_4_s1 (gfc_array_i4 * const restrict retarray,
 218         gfc_array_s1 * const restrict array,
 219         const index_type * const restrict pdim,
 220         gfc_array_l1 * const restrict mask, gfc_charlen_type string_len)
 221 {
 222   index_type count[GFC_MAX_DIMENSIONS];
 223   index_type extent[GFC_MAX_DIMENSIONS];
 224   index_type sstride[GFC_MAX_DIMENSIONS];
 225   index_type dstride[GFC_MAX_DIMENSIONS];
 226   index_type mstride[GFC_MAX_DIMENSIONS];
 227   GFC_INTEGER_4 * restrict dest;
 228   const GFC_INTEGER_1 * restrict base;
 229   const GFC_LOGICAL_1 * restrict mbase;
 230   index_type rank;
 231   index_type dim;
 232   index_type n;
 233   index_type len;
 234   index_type delta;
 235   index_type mdelta;
 236   int mask_kind;
 237
 238   dim = (*pdim) - 1;
 239   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 240
 241
 242   if (unlikely (dim < 0 || dim > rank))
 243     {
 244       runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
 245                      "is %ld, should be between 1 and %ld",
 246                      (long int) dim + 1, (long int) rank + 1);
 247     }
 248
 249   len = GFC_DESCRIPTOR_EXTENT(array,dim);
 250   if (len <= 0)
 251     return;
 252
 253   mbase = mask->base_addr;
 254
 255   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
 256
 257   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
 258 #ifdef HAVE_GFC_LOGICAL_16
 259       || mask_kind == 16
 260 #endif
 261       )
 262     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
 263   else
 264     runtime_error ("Funny sized logical array");
 265
 266   delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len;
 267   mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
 268
 269   for (n = 0; n < dim; n++)
 270     {
 271       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len;
 272       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
 273       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
 274
 275       if (extent[n] < 0)
 276         extent[n] = 0;
 277
 278     }
 279   for (n = dim; n < rank; n++)
 280     {
 281       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len;
 282       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
 283       extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
 284
 285       if (extent[n] < 0)
 286         extent[n] = 0;
 287     }
 288
 289   if (retarray->base_addr == NULL)
 290     {
 291       size_t alloc_size, str;
 292
 293       for (n = 0; n < rank; n++)
 294         {
 295           if (n == 0)
 296             str = 1;
 297           else
 298             str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 299
 300           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 301
 302         }
 303
 304       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 305
 306       retarray->offset = 0;
 307       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 308
 309       if (alloc_size == 0)
 310         {
 311           /* Make sure we have a zero-sized array.  */
 312           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 313           return;
 314         }
 315       else
 316         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 317
 318     }
 319   else
 320     {
 321       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 322         runtime_error ("rank of return array incorrect in MINLOC intrinsic");
 323
 324       if (unlikely (compile_options.bounds_check))
 325         {
 326           bounds_ifunction_return ((array_t *) retarray, extent,
 327                                    "return value", "MINLOC");
 328           bounds_equal_extents ((array_t *) mask, (array_t *) array,
 329                                 "MASK argument", "MINLOC");
 330         }
 331     }
 332
 333   for (n = 0; n < rank; n++)
 334     {
 335       count[n] = 0;
 336       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 337       if (extent[n] <= 0)
 338         return;
 339     }
 340
 341   dest = retarray->base_addr;
 342   base = array->base_addr;
 343
 344   while (base)
 345     {
 346       const GFC_INTEGER_1 * restrict src;
 347       const GFC_LOGICAL_1 * restrict msrc;
 348       GFC_INTEGER_4 result;
 349       src = base;
 350       msrc = mbase;
 351       {
 352
 353         const GFC_INTEGER_1 *minval;
 354         minval = base;
 355         result = 0;
 356         for (n = 0; n < len; n++, src += delta, msrc += mdelta)
 357           {
 358
 359                 if (*msrc)
 360                       {
 361                         minval = src;
 362                         result = (GFC_INTEGER_4)n + 1;
 363                         break;
 364                       }
 365             }
 366             for (; n < len; n++, src += delta, msrc += mdelta)
 367               {
 368                 if (*msrc && compare_fcn (src, minval, string_len) < 0)
 369                   {
 370                     minval = src;
 371                     result = (GFC_INTEGER_4)n + 1;
 372                   }
 373
 374           }
 375         *dest = result;
 376       }
 377       /* Advance to the next element.  */
 378       count[0]++;
 379       base += sstride[0];
 380       mbase += mstride[0];
 381       dest += dstride[0];
 382       n = 0;
 383       while (count[n] == extent[n])
 384         {
 385           /* When we get to the end of a dimension, reset it and increment
 386              the next dimension.  */
 387           count[n] = 0;
 388           /* We could precalculate these products, but this is a less
 389              frequently used path so probably not worth it.  */
 390           base -= sstride[n] * extent[n];
 391           mbase -= mstride[n] * extent[n];
 392           dest -= dstride[n] * extent[n];
 393           n++;
 394           if (n >= rank)
 395             {
 396               /* Break out of the loop.  */
 397               base = NULL;
 398               break;
 399             }
 400           else
 401             {
 402               count[n]++;
 403               base += sstride[n];
 404               mbase += mstride[n];
 405               dest += dstride[n];
 406             }
 407         }
 408     }
 409 }
 410
 411
 412 extern void sminloc1_4_s1 (gfc_array_i4 * const restrict,
 413         gfc_array_s1 * const restrict, const index_type * const restrict,
 414         GFC_LOGICAL_4 *, gfc_charlen_type);
 415 export_proto(sminloc1_4_s1);
 416
 417 void
 418 sminloc1_4_s1 (gfc_array_i4 * const restrict retarray,
 419         gfc_array_s1 * const restrict array,
 420         const index_type * const restrict pdim,
 421         GFC_LOGICAL_4 * mask, gfc_charlen_type string_len)
 422 {
 423   index_type count[GFC_MAX_DIMENSIONS];
 424   index_type extent[GFC_MAX_DIMENSIONS];
 425   index_type dstride[GFC_MAX_DIMENSIONS];
 426   GFC_INTEGER_4 * restrict dest;
 427   index_type rank;
 428   index_type n;
 429   index_type dim;
 430
 431
 432   if (*mask)
 433     {
 434       minloc1_4_s1 (retarray, array, pdim, string_len);
 435       return;
 436     }
 437   /* Make dim zero based to avoid confusion.  */
 438   dim = (*pdim) - 1;
 439   rank = GFC_DESCRIPTOR_RANK (array) - 1;
 440
 441   if (unlikely (dim < 0 || dim > rank))
 442     {
 443       runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
 444                      "is %ld, should be between 1 and %ld",
 445                      (long int) dim + 1, (long int) rank + 1);
 446     }
 447
 448   for (n = 0; n < dim; n++)
 449     {
 450       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n) * string_len;
 451
 452       if (extent[n] <= 0)
 453         extent[n] = 0;
 454     }
 455
 456   for (n = dim; n < rank; n++)
 457     {
 458       extent[n] =
 459         GFC_DESCRIPTOR_EXTENT(array,n + 1) * string_len;
 460
 461       if (extent[n] <= 0)
 462         extent[n] = 0;
 463     }
 464
 465   if (retarray->base_addr == NULL)
 466     {
 467       size_t alloc_size, str;
 468
 469       for (n = 0; n < rank; n++)
 470         {
 471           if (n == 0)
 472             str = 1;
 473           else
 474             str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
 475
 476           GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
 477
 478         }
 479
 480       retarray->offset = 0;
 481       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
 482
 483       alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
 484
 485       if (alloc_size == 0)
 486         {
 487           /* Make sure we have a zero-sized array.  */
 488           GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
 489           return;
 490         }
 491       else
 492         retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
 493     }
 494   else
 495     {
 496       if (rank != GFC_DESCRIPTOR_RANK (retarray))
 497         runtime_error ("rank of return array incorrect in"
 498                        " MINLOC intrinsic: is %ld, should be %ld",
 499                        (long int) (GFC_DESCRIPTOR_RANK (retarray)),
 500                        (long int) rank);
 501
 502       if (unlikely (compile_options.bounds_check))
 503         {
 504           for (n=0; n < rank; n++)
 505             {
 506               index_type ret_extent;
 507
 508               ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
 509               if (extent[n] != ret_extent)
 510                 runtime_error ("Incorrect extent in return value of"
 511                                " MINLOC intrinsic in dimension %ld:"
 512                                " is %ld, should be %ld", (long int) n + 1,
 513                                (long int) ret_extent, (long int) extent[n]);
 514             }
 515         }
 516     }
 517
 518   for (n = 0; n < rank; n++)
 519     {
 520       count[n] = 0;
 521       dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
 522     }
 523
 524   dest = retarray->base_addr;
 525
 526   while(1)
 527     {
 528       *dest = 0;
 529       count[0]++;
 530       dest += dstride[0];
 531       n = 0;
 532       while (count[n] == extent[n])
 533         {
 534           /* When we get to the end of a dimension, reset it and increment
 535              the next dimension.  */
 536           count[n] = 0;
 537           /* We could precalculate these products, but this is a less
 538              frequently used path so probably not worth it.  */
 539           dest -= dstride[n] * extent[n];
 540           n++;
 541           if (n >= rank)
 542             return;
 543           else
 544             {
 545               count[n]++;
 546               dest += dstride[n];
 547             }
 548         }
 549     }
 550 }
 551
 552 #endif