libgfortran/generated/minval1_s1.c

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