diff options
Diffstat (limited to 'libgfortran/m4/iforeach.m4')
| -rw-r--r-- | libgfortran/m4/iforeach.m4 | 73 |
1 files changed, 61 insertions, 12 deletions
diff --git a/libgfortran/m4/iforeach.m4 b/libgfortran/m4/iforeach.m4 index 720a4c05851..a49d33b9311 100644 --- a/libgfortran/m4/iforeach.m4 +++ b/libgfortran/m4/iforeach.m4 @@ -36,11 +36,22 @@ name`'rtype_qual`_'atype_code (rtype * const restrict retarray, } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in u_name intrinsic" + " should be 1, is %d", ret_rank); - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " u_name intrnisic: is %ld, should be %d", + (long int) ret_extent, rank); + } } dstride = retarray->dim[0].stride; @@ -141,11 +152,40 @@ void } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank, mask_rank; + index_type ret_extent; + int n; + index_type array_extent, mask_extent; + + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in u_name intrinsic" + " should be 1, is %d", ret_rank); - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("Incorrect extent in return value of" + " u_name intrnisic: is %ld, should be %d", + (long int) ret_extent, rank); + + mask_rank = GFC_DESCRIPTOR_RANK (mask); + if (rank != mask_rank) + runtime_error ("rank of MASK argument in u_name intrnisic" + "should be %d, is %d", rank, mask_rank); + + for (n=0; n<rank; n++) + { + array_extent = array->dim[n].ubound + 1 - array->dim[n].lbound; + mask_extent = mask->dim[n].ubound + 1 - mask->dim[n].lbound; + if (array_extent != mask_extent) + runtime_error ("Incorrect extent in MASK argument of" + " u_name intrinsic in dimension %d:" + " is %ld, should be %ld", n + 1, + (long int) mask_extent, (long int) array_extent); + } + } } mask_kind = GFC_DESCRIPTOR_SIZE (mask); @@ -270,11 +310,20 @@ void } else { - if (GFC_DESCRIPTOR_RANK (retarray) != 1) - runtime_error ("rank of return array does not equal 1"); + if (compile_options.bounds_check) + { + int ret_rank; + index_type ret_extent; - if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank) - runtime_error ("dimension of return array incorrect"); + ret_rank = GFC_DESCRIPTOR_RANK (retarray); + if (ret_rank != 1) + runtime_error ("rank of return array in u_name intrinsic" + " should be 1, is %d", ret_rank); + + ret_extent = retarray->dim[0].ubound + 1 - retarray->dim[0].lbound; + if (ret_extent != rank) + runtime_error ("dimension of return array incorrect"); + } } dstride = retarray->dim[0].stride; |