Skip to content

Commit 84fed70

Browse files
vehrevehre
committed
Merge branch 'vehre/improve-runtime-error-reporting' into issue-700-enable-multi-allocatable-arrays
2 parents 3a95ece + 7010d60 commit 84fed70

File tree

1 file changed

+59
-30
lines changed

1 file changed

+59
-30
lines changed

‎src/mpi/mpi_caf.c

Lines changed: 59 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -429,6 +429,35 @@ caf_runtime_error (const char *message, ...)
429429
exit(EXIT_FAILURE);
430430
}
431431

432+
/* Error handling is similar everytime. Keep in sync with single.c, too. */
433+
static void
434+
caf_internal_error (const char *msg, int *stat, char *errmsg,
435+
size_t errmsg_len, ...)
436+
{
437+
va_list args;
438+
va_start (args, errmsg_len);
439+
if (stat)
440+
{
441+
*stat = 1;
442+
if (errmsg_len > 0)
443+
{
444+
int len = snprintf (errmsg, errmsg_len, msg, args);
445+
if (len >= 0 && errmsg_len > (size_t) len)
446+
memset (&errmsg[len], ' ', errmsg_len - len);
447+
}
448+
va_end (args);
449+
return;
450+
}
451+
else
452+
{
453+
fprintf(stderr, "Fortran runtime error on image %d: ", caf_this_image);
454+
vfprintf(stderr, msg, args);
455+
fprintf(stderr, "\n");
456+
}
457+
va_end (args);
458+
exit(EXIT_FAILURE);
459+
}
460+
432461
/* Forward declaration of the feature unsupported message for failed images
433462
* functions. */
434463
static void
@@ -4704,7 +4733,7 @@ case kind: \
47044733
KINDCASE(16, __int128);
47054734
#endif
47064735
default:
4707-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
4736+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
47084737
return;
47094738
}
47104739
#undef KINDCASE
@@ -4750,7 +4779,7 @@ case kind: \
47504779
* in a dimension. */
47514780
break;
47524781
default:
4753-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
4782+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
47544783
return;
47554784
}
47564785
dprint("i = %zd, array_ref = %s, delta = %ld, in_array_ref = %d, arr_ext_fixed = %d, realloc_required = %d\n", i,
@@ -4762,7 +4791,7 @@ case kind: \
47624791
if (delta > 1 && dst_rank == 0)
47634792
{
47644793
/* No, an array is required, but not provided. */
4765-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
4794+
caf_internal_error(extentoutofrange, stat, NULL, 0);
47664795
return;
47674796
}
47684797
/* When dst is an array. */
@@ -4772,7 +4801,7 @@ case kind: \
47724801
* only by scalar data. */
47734802
if (dst_cur_dim >= dst_rank && delta != 1)
47744803
{
4775-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
4804+
caf_internal_error(rankoutofrange, stat, NULL, 0);
47764805
return;
47774806
}
47784807
/* Do further checks, when the source is not scalar. */
@@ -4810,7 +4839,7 @@ case kind: \
48104839
}
48114840
else
48124841
{
4813-
caf_runtime_error(doublearrayref, stat, NULL, 0);
4842+
caf_internal_error(doublearrayref, stat, NULL, 0);
48144843
return;
48154844
}
48164845
}
@@ -4825,7 +4854,7 @@ case kind: \
48254854
/* Check whether dst is reallocatable. */
48264855
if (unlikely(!dst_reallocatable))
48274856
{
4828-
caf_runtime_error(nonallocextentmismatch, stat,
4857+
caf_internal_error(nonallocextentmismatch, stat,
48294858
NULL, 0, delta,
48304859
GFC_DESCRIPTOR_EXTENT(dst, dst_cur_dim));
48314860
return;
@@ -4834,7 +4863,7 @@ case kind: \
48344863
* which is not allowed. */
48354864
else if (!dst_reallocatable && extent_mismatch)
48364865
{
4837-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
4866+
caf_internal_error(extentoutofrange, stat, NULL, 0);
48384867
return;
48394868
}
48404869
realloc_needed = true;
@@ -4892,7 +4921,7 @@ case kind: \
48924921
KINDCASE(16, __int128);
48934922
#endif
48944923
default:
4895-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
4924+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
48964925
return;
48974926
}
48984927
#undef KINDCASE
@@ -4923,7 +4952,7 @@ case kind: \
49234952
* not occur here. */
49244953
case CAF_ARR_REF_OPEN_START:
49254954
default:
4926-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
4955+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
49274956
return;
49284957
}
49294958
dprint("i = %zd, array_ref = %s, delta = %ld\n",
@@ -4935,7 +4964,7 @@ case kind: \
49354964
if (delta > 1 && dst_rank == 0)
49364965
{
49374966
/* No, an array is required, but not provided. */
4938-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
4967+
caf_internal_error(extentoutofrange, stat, NULL, 0);
49394968
return;
49404969
}
49414970
/* When dst is an array. */
@@ -4945,7 +4974,7 @@ case kind: \
49454974
* only by scalar data. */
49464975
if (dst_cur_dim >= dst_rank && delta != 1)
49474976
{
4948-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
4977+
caf_internal_error(rankoutofrange, stat, NULL, 0);
49494978
return;
49504979
}
49514980
/* Do further checks, when the source is not scalar. */
@@ -4966,7 +4995,7 @@ case kind: \
49664995
}
49674996
else
49684997
{
4969-
caf_runtime_error(doublearrayref, stat, NULL, 0);
4998+
caf_internal_error(doublearrayref, stat, NULL, 0);
49704999
return;
49715000
}
49725001
}
@@ -4981,7 +5010,7 @@ case kind: \
49815010
/* Check whether dst is reallocatable. */
49825011
if (unlikely(!dst_reallocatable))
49835012
{
4984-
caf_runtime_error(nonallocextentmismatch, stat,
5013+
caf_internal_error(nonallocextentmismatch, stat,
49855014
NULL, 0, delta,
49865015
GFC_DESCRIPTOR_EXTENT(dst, dst_cur_dim));
49875016
return;
@@ -4990,7 +5019,7 @@ case kind: \
49905019
* which is not allowed. */
49915020
else if (!dst_reallocatable && extent_mismatch)
49925021
{
4993-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
5022+
caf_internal_error(extentoutofrange, stat, NULL, 0);
49945023
return;
49955024
}
49965025
realloc_needed = true;
@@ -5024,7 +5053,7 @@ case kind: \
50245053
}
50255054
break;
50265055
default:
5027-
caf_runtime_error(unknownreftype, stat, NULL, 0);
5056+
caf_internal_error(unknownreftype, stat, NULL, 0);
50285057
return;
50295058
}
50305059
src_size = riter->item_size;
@@ -5052,7 +5081,7 @@ case kind: \
50525081
dst->base_addr = malloc(size * GFC_DESCRIPTOR_SIZE(dst));
50535082
if (unlikely(dst->base_addr == NULL))
50545083
{
5055-
caf_runtime_error(cannotallocdst, stat, size * GFC_DESCRIPTOR_SIZE(dst));
5084+
caf_internal_error(cannotallocdst, stat, NULL, 0, size * GFC_DESCRIPTOR_SIZE(dst));
50565085
return;
50575086
}
50585087
}
@@ -5911,7 +5940,7 @@ case kind: \
59115940
KINDCASE(16, __int128);
59125941
#endif
59135942
default:
5914-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
5943+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
59155944
return;
59165945
}
59175946
#undef KINDCASE
@@ -5957,7 +5986,7 @@ case kind: \
59575986
* a dimension. */
59585987
break;
59595988
default:
5960-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
5989+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
59615990
return;
59625991
} // switch
59635992
dprint("i = %zd, array_ref = %s, delta = %ld\n",
@@ -5971,7 +6000,7 @@ case kind: \
59716000
if (delta > 1 && dst_rank == 0)
59726001
{
59736002
/* No, an array is required, but not provided. */
5974-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
6003+
caf_internal_error(extentoutofrange, stat, NULL, 0);
59756004
return;
59766005
}
59776006
/* When dst is an array. */
@@ -5981,7 +6010,7 @@ case kind: \
59816010
* only by scalar data. */
59826011
if (src_cur_dim >= dst_rank && delta != 1)
59836012
{
5984-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
6013+
caf_internal_error(rankoutofrange, stat, NULL, 0);
59856014
return;
59866015
}
59876016
/* Do further checks, when the source is not scalar. */
@@ -5998,7 +6027,7 @@ case kind: \
59986027
/* Check whether dst is reallocatable. */
59996028
if (unlikely(!dst_reallocatable))
60006029
{
6001-
caf_runtime_error(nonallocextentmismatch, stat,
6030+
caf_internal_error(nonallocextentmismatch, stat,
60026031
NULL, 0, delta,
60036032
GFC_DESCRIPTOR_EXTENT(dst, src_cur_dim));
60046033
return;
@@ -6007,7 +6036,7 @@ case kind: \
60076036
* modified, which is not allowed. */
60086037
else if (!dst_reallocatable && extent_mismatch)
60096038
{
6010-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
6039+
caf_internal_error(extentoutofrange, stat, NULL, 0);
60116040
return;
60126041
}
60136042
dprint("extent(dst, %d): %zd != delta: %ld.\n", src_cur_dim,
@@ -6047,7 +6076,7 @@ case kind: \
60476076
KINDCASE(16, __int128);
60486077
#endif
60496078
default:
6050-
caf_runtime_error(vecrefunknownkind, stat, NULL, 0);
6079+
caf_internal_error(vecrefunknownkind, stat, NULL, 0);
60516080
return;
60526081
}
60536082
#undef KINDCASE
@@ -6077,7 +6106,7 @@ case kind: \
60776106
* can not occur here. */
60786107
case CAF_ARR_REF_OPEN_START:
60796108
default:
6080-
caf_runtime_error(unknownarrreftype, stat, NULL, 0);
6109+
caf_internal_error(unknownarrreftype, stat, NULL, 0);
60816110
return;
60826111
} // switch
60836112
dprint("i = %zd, array_ref = %s, delta = %ld\n",
@@ -6091,7 +6120,7 @@ case kind: \
60916120
if (delta > 1 && dst_rank == 0)
60926121
{
60936122
/* No, an array is required, but not provided. */
6094-
caf_runtime_error(extentoutofrange, stat, NULL, 0);
6123+
caf_internal_error(extentoutofrange, stat, NULL, 0);
60956124
return;
60966125
}
60976126
/* When dst is an array. */
@@ -6101,7 +6130,7 @@ case kind: \
61016130
* only by scalar data. */
61026131
if (src_cur_dim >= dst_rank && delta != 1)
61036132
{
6104-
caf_runtime_error(rankoutofrange, stat, NULL, 0);
6133+
caf_internal_error(rankoutofrange, stat, NULL, 0);
61056134
return;
61066135
}
61076136
/* Do further checks, when the source is not scalar. */
@@ -6115,7 +6144,7 @@ case kind: \
61156144
* the extent does not match the needed one. */
61166145
if (realloc_dst || extent_mismatch)
61176146
{
6118-
caf_runtime_error(unabletoallocdst, stat);
6147+
caf_internal_error(unabletoallocdst, stat, NULL, 0);
61196148
return;
61206149
}
61216150
}
@@ -6127,7 +6156,7 @@ case kind: \
61276156
in_array_ref = false;
61286157
break;
61296158
default:
6130-
caf_runtime_error(unknownreftype, stat, NULL, 0);
6159+
caf_internal_error(unknownreftype, stat, NULL, 0);
61316160
return;
61326161
}
61336162
dst_size = riter->item_size;
@@ -6142,7 +6171,7 @@ case kind: \
61426171

61436172
if (realloc_dst)
61446173
{
6145-
caf_runtime_error(unabletoallocdst, stat);
6174+
caf_internal_error(unabletoallocdst, stat, NULL, 0);
61466175
return;
61476176
}
61486177

@@ -6177,7 +6206,7 @@ case kind: \
61776206
temp_src.base.base_addr = malloc(cap);
61786207
if (temp_src.base.base_addr == NULL)
61796208
{
6180-
caf_runtime_error(cannotallocdst, stat, NULL, cap);
6209+
caf_internal_error(cannotallocdst, stat, NULL, cap);
61816210
return;
61826211
}
61836212
}

0 commit comments

Comments
 (0)