libgfortran/generated/maxloc1_4_s1.c

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