1181254a7Smrg`/* Implementation of the SHAPE intrinsic 2*b1e83836Smrg Copyright (C) 2002-2022 Free Software Foundation, Inc. 3181254a7Smrg Contributed by Paul Brook <paul@nowt.org> 4181254a7Smrg 5181254a7SmrgThis file is part of the GNU Fortran runtime library (libgfortran). 6181254a7Smrg 7181254a7SmrgLibgfortran is free software; you can redistribute it and/or 8181254a7Smrgmodify it under the terms of the GNU General Public 9181254a7SmrgLicense as published by the Free Software Foundation; either 10181254a7Smrgversion 3 of the License, or (at your option) any later version. 11181254a7Smrg 12181254a7SmrgLibgfortran is distributed in the hope that it will be useful, 13181254a7Smrgbut WITHOUT ANY WARRANTY; without even the implied warranty of 14181254a7SmrgMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15181254a7SmrgGNU General Public License for more details. 16181254a7Smrg 17181254a7SmrgUnder Section 7 of GPL version 3, you are granted additional 18181254a7Smrgpermissions described in the GCC Runtime Library Exception, version 19181254a7Smrg3.1, as published by the Free Software Foundation. 20181254a7Smrg 21181254a7SmrgYou should have received a copy of the GNU General Public License and 22181254a7Smrga copy of the GCC Runtime Library Exception along with this program; 23181254a7Smrgsee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24181254a7Smrg<http://www.gnu.org/licenses/>. */ 25181254a7Smrg 26181254a7Smrg#include "libgfortran.h"' 27181254a7Smrg 28181254a7Smrginclude(iparm.m4)dnl 29181254a7Smrg 30181254a7Smrg`#if defined (HAVE_'rtype_name`) 31181254a7Smrg 32181254a7Smrgextern void shape_'rtype_kind` ('rtype` * const restrict ret, 33181254a7Smrg const array_t * const restrict array); 34181254a7Smrgexport_proto(shape_'rtype_kind`); 35181254a7Smrg 36181254a7Smrgvoid 37181254a7Smrgshape_'rtype_kind` ('rtype` * const restrict ret, 38181254a7Smrg const array_t * const restrict array) 39181254a7Smrg{ 40181254a7Smrg index_type stride; 41181254a7Smrg index_type extent; 42181254a7Smrg 43181254a7Smrg int rank = GFC_DESCRIPTOR_RANK (array); 44181254a7Smrg 45181254a7Smrg if (ret->base_addr == NULL) 46181254a7Smrg { 47181254a7Smrg GFC_DIMENSION_SET(ret->dim[0], 0, rank - 1, 1); 48181254a7Smrg ret->offset = 0; 49181254a7Smrg ret->base_addr = xmallocarray (rank, sizeof ('rtype_name`)); 50181254a7Smrg } 51181254a7Smrg 52181254a7Smrg stride = GFC_DESCRIPTOR_STRIDE(ret,0); 53181254a7Smrg 54181254a7Smrg if (GFC_DESCRIPTOR_EXTENT(ret,0) < 1) 55181254a7Smrg return; 56181254a7Smrg 57181254a7Smrg for (index_type n = 0; n < rank; n++) 58181254a7Smrg { 59181254a7Smrg extent = GFC_DESCRIPTOR_EXTENT(array,n); 60181254a7Smrg ret->base_addr[n * stride] = extent > 0 ? extent : 0 ; 61181254a7Smrg } 62181254a7Smrg} 63181254a7Smrg 64181254a7Smrg#endif' 65