aboutsummaryrefslogtreecommitdiff
path: root/libgcobol/libgcobol.cc
diff options
context:
space:
mode:
Diffstat (limited to 'libgcobol/libgcobol.cc')
-rw-r--r--libgcobol/libgcobol.cc287
1 files changed, 146 insertions, 141 deletions
diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc
index c163e2c..1d4cdf8 100644
--- a/libgcobol/libgcobol.cc
+++ b/libgcobol/libgcobol.cc
@@ -50,6 +50,7 @@
#include <sys/resource.h>
#include "config.h"
+#include "libgcobol-fp.h"
#include "ec.h"
#include "common-defs.h"
@@ -92,6 +93,20 @@ strfromf64 (char *s, size_t n, const char *f, double v)
# endif
#endif
+#if !defined (HAVE_STRFROMF128)
+# if !USE_QUADMATH
+# error "no available float 128 to string"
+# endif
+#endif
+
+#if !defined (HAVE_STRTOF128)
+# if USE_QUADMATH
+# define strtof128 strtoflt128
+# else
+# error "no available string to float 128"
+# endif
+#endif
+
// This couldn't be defined in symbols.h because it conflicts with a LEVEL66
// in parse.h
#define LEVEL66 (66)
@@ -216,12 +231,16 @@ local_ec_type_descr( ec_type_t type ) {
return p;
}
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wunused-function"
+// Keep this debugging function around for when it is needed
static const char *
local_ec_type_str( ec_type_t type ) {
if( type == ec_none_e ) return "EC-NONE";
auto p = local_ec_type_descr(type);
return p->name;
}
+#pragma GCC diagnostic pop
ec_status_t& ec_status_t::update() {
handled = ec_type_t(__gg__exception_handled);
@@ -233,13 +252,6 @@ ec_status_t& ec_status_t::update() {
snprintf(statement, sizeof(statement), "%s", __gg__exception_statement);
}
- if( type != ec_none_e && getenv("match_declarative") ) {
- warnx( "ec_status_t::update:%d: EC %s by %s handled %02X " , __LINE__,
- local_ec_type_str(type),
- __gg__exception_statement? statement : "<none>",
- handled ); // might be file-status, not ec_type_t
- }
-
return *this;
}
@@ -881,10 +893,12 @@ int128_to_int128_rounded( cbl_round_t rounded,
int *compute_error)
{
// value is signed, and is scaled to the target
- _Float128 fpart = _Float128(remainder) / _Float128(factor);
+ GCOB_FP128 fpart = ((GCOB_FP128)remainder) / ((GCOB_FP128)factor);
__int128 retval = value;
- if(rounded == nearest_even_e && fpart != -0.5Q && fpart != 0.5Q )
+ if(rounded == nearest_even_e
+ && fpart != GCOB_FP128_LITERAL (-0.5)
+ && fpart != GCOB_FP128_LITERAL (0.5))
{
// "bankers rounding" has been requested.
//
@@ -905,14 +919,14 @@ int128_to_int128_rounded( cbl_round_t rounded,
// 0.5 through 0.9 becomes 1
if( value < 0 )
{
- if( fpart <= -0.5Q )
+ if( fpart <= GCOB_FP128_LITERAL(-0.5) )
{
retval -= 1;
}
}
else
{
- if( fpart >= 0.5Q )
+ if( fpart >= GCOB_FP128_LITERAL(0.5) )
{
retval += 1;
}
@@ -946,14 +960,14 @@ int128_to_int128_rounded( cbl_round_t rounded,
// 0.6 through 0.9 becomes 1
if( value < 0 )
{
- if( fpart < -0.5Q )
+ if( fpart < GCOB_FP128_LITERAL(-0.5) )
{
retval -= 1;
}
}
else
{
- if( fpart > 0.5Q )
+ if( fpart > GCOB_FP128_LITERAL(0.5) )
{
retval += 1;
}
@@ -1035,15 +1049,17 @@ int128_to_int128_rounded( cbl_round_t rounded,
static __int128
f128_to_i128_rounded( cbl_round_t rounded,
- _Float128 value,
+ GCOB_FP128 value,
int *compute_error)
{
// value is signed, and is scaled to the target
- _Float128 ipart;
- _Float128 fpart = modff128(value, &ipart);
+ GCOB_FP128 ipart;
+ GCOB_FP128 fpart = FP128_FUNC(modf)(value, &ipart);
__int128 retval = (__int128)ipart;
- if(rounded == nearest_even_e && fpart != -0.5Q && fpart != 0.5Q )
+ if(rounded == nearest_even_e
+ && fpart != GCOB_FP128_LITERAL (-0.5)
+ && fpart != GCOB_FP128_LITERAL (0.5))
{
// "bankers rounding" has been requested.
//
@@ -1064,14 +1080,14 @@ f128_to_i128_rounded( cbl_round_t rounded,
// 0.5 through 0.9 becomes 1
if( value < 0 )
{
- if( fpart <= -0.5Q )
+ if( fpart <= GCOB_FP128_LITERAL (-0.5) )
{
retval -= 1;
}
}
else
{
- if( fpart >= 0.5Q )
+ if( fpart >= GCOB_FP128_LITERAL (0.5) )
{
retval += 1;
}
@@ -1105,14 +1121,14 @@ f128_to_i128_rounded( cbl_round_t rounded,
// 0.6 through 0.9 becomes 1
if( value < 0 )
{
- if( fpart < -0.5Q )
+ if( fpart < GCOB_FP128_LITERAL (-0.5) )
{
retval -= 1;
}
}
else
{
- if( fpart > 0.5Q )
+ if( fpart > GCOB_FP128_LITERAL (0.5) )
{
retval += 1;
}
@@ -1276,8 +1292,8 @@ int128_to_field(cblc_field_t *var,
{
value = -value;
}
- _Float128 tvalue = (_Float128 )value;
- tvalue /= (_Float128 )__gg__power_of_ten(source_rdigits);
+ GCOB_FP128 tvalue = (GCOB_FP128 )value;
+ tvalue /= (GCOB_FP128 )__gg__power_of_ten(source_rdigits);
// *(_Float128 *)location = tvalue;
// memcpy because *(_Float128 *) requires a 16-byte boundary.
memcpy(location, &tvalue, 16);
@@ -2202,7 +2218,7 @@ extern "C"
void
__gg__clock_gettime(clockid_t clk_id, struct timespec *tp)
{
- const char *p = getenv("COB_CURRENT_DATE");
+ const char *p = getenv("GCOBOL_CURRENT_DATE");
if( p )
{
@@ -2573,7 +2589,7 @@ __gg__dirty_to_binary_internal( const char *dirty,
}
extern "C"
-_Float128
+GCOB_FP128
__gg__dirty_to_float( const char *dirty,
int length)
{
@@ -2589,7 +2605,7 @@ __gg__dirty_to_float( const char *dirty,
// It also can handle 12345E-2 notation.
- _Float128 retval = 0;
+ GCOB_FP128 retval = 0;
int rdigits = 0;
int hyphen = 0;
@@ -3244,9 +3260,13 @@ format_for_display_internal(char **dest,
// We can't use *(_Float64 *)actual_location;
// That uses the SSE registers, which won't work if the source isn't
// on a 16-bit boundary.
- _Float128 floatval;
+ GCOB_FP128 floatval;
memcpy(&floatval, actual_location, 16);
+#if !defined (HAVE_STRFROMF128) && USE_QUADMATH
+ quadmath_snprintf(ach, sizeof(ach), "%.36QE", floatval);
+#else
strfromf128(ach, sizeof(ach), "%.36E", floatval);
+#endif
char *p = strchr(ach, 'E');
if( !p )
{
@@ -3268,8 +3288,13 @@ format_for_display_internal(char **dest,
int precision = 36 - exp;
char achFormat[24];
+#if !defined (HAVE_STRFROMF128) && USE_QUADMATH
+ sprintf(achFormat, "%%.%dQf", precision);
+ quadmath_snprintf(ach, sizeof(ach), achFormat, floatval);
+#else
sprintf(achFormat, "%%.%df", precision);
strfromf128(ach, sizeof(ach), achFormat, floatval);
+#endif
}
__gg__remove_trailing_zeroes(ach);
__gg__realloc_if_necessary(dest, dest_size, strlen(ach)+1);
@@ -3481,11 +3506,11 @@ compare_88( const char *list,
return cmpval;
}
-static _Float128
+static GCOB_FP128
get_float128( cblc_field_t *field,
unsigned char *location )
{
- _Float128 retval=0;
+ GCOB_FP128 retval=0;
if(field->type == FldFloat )
{
switch( field->capacity )
@@ -3710,7 +3735,7 @@ compare_field_class(cblc_field_t *conditional,
case FldFloat:
{
- _Float128 value = get_float128(conditional, conditional_location) ;
+ GCOB_FP128 value = get_float128(conditional, conditional_location) ;
char *walker = list->initial;
while(*walker)
{
@@ -3734,7 +3759,7 @@ compare_field_class(cblc_field_t *conditional,
walker = right + right_len;
- _Float128 left_value;
+ GCOB_FP128 left_value;
if( left_flag == 'F' && left[0] == 'Z' )
{
left_value = 0;
@@ -3745,7 +3770,7 @@ compare_field_class(cblc_field_t *conditional,
left_len);
}
- _Float128 right_value;
+ GCOB_FP128 right_value;
if( right_flag == 'F' && right[0] == 'Z' )
{
right_value = 0;
@@ -3919,23 +3944,17 @@ __gg__compare_2(cblc_field_t *left_side,
unsigned char *left_location,
size_t left_length,
int left_attr,
- bool left_all,
- bool left_address_of,
+ int left_flags,
cblc_field_t *right_side,
unsigned char *right_location,
size_t right_length,
int right_attr,
- bool right_all,
- bool right_address_of,
+ int right_flags,
int second_time_through)
{
// First order of business: If right_side is a FldClass, pass that off
// to the speciality squad:
- // static size_t converted_initial_size = MINIMUM_ALLOCATION_SIZE;
- // static unsigned char *converted_initial =
- // (unsigned char *)malloc(converted_initial_size);
-
if( right_side->type == FldClass )
{
return compare_field_class( left_side,
@@ -3945,8 +3964,17 @@ __gg__compare_2(cblc_field_t *left_side,
}
// Serene in our conviction that the left_side isn't a FldClass, we
- // move on:
+ // move on.
+
+ // Extract the individual flags from the flag words:
+ bool left_all = !!(left_flags & REFER_T_MOVE_ALL );
+ bool left_address_of = !!(left_flags & REFER_T_ADDRESS_OF);
+ bool right_all = !!(right_flags & REFER_T_MOVE_ALL );
+ bool right_address_of = !!(right_flags & REFER_T_ADDRESS_OF);
+//bool left_refmod = !!(left_flags & REFER_T_REFMOD );
+ bool right_refmod = !!(right_flags & REFER_T_REFMOD );
+ // Figure out if we have any figurative constants
cbl_figconst_t left_figconst = (cbl_figconst_t)(left_attr & FIGCONST_MASK);
cbl_figconst_t right_figconst = (cbl_figconst_t)(right_attr & FIGCONST_MASK);
@@ -4097,7 +4125,7 @@ __gg__compare_2(cblc_field_t *left_side,
case FldFloat:
{
- _Float128 value = __gg__float128_from_location(left_side,
+ GCOB_FP128 value = __gg__float128_from_location(left_side,
left_location);
retval = 0;
retval = value < 0 ? -1 : retval;
@@ -4154,8 +4182,8 @@ __gg__compare_2(cblc_field_t *left_side,
if( left_side->type == FldFloat && right_side->type == FldFloat )
{
// One or the other of the numerics is a FldFloat
- _Float128 left_value = __gg__float128_from_location(left_side, left_location);
- _Float128 right_value = __gg__float128_from_location(right_side, right_location);
+ GCOB_FP128 left_value = __gg__float128_from_location(left_side, left_location);
+ GCOB_FP128 right_value = __gg__float128_from_location(right_side, right_location);
retval = 0;
retval = left_value < right_value ? -1 : retval;
retval = left_value > right_value ? 1 : retval;
@@ -4167,8 +4195,8 @@ __gg__compare_2(cblc_field_t *left_side,
{
// The left side is a FldFloat; the other is another type of numeric:
int rdecimals;
- _Float128 left_value;
- _Float128 right_value;
+ GCOB_FP128 left_value;
+ GCOB_FP128 right_value;
if( right_side->type == FldLiteralN)
{
@@ -4200,7 +4228,7 @@ __gg__compare_2(cblc_field_t *left_side,
case 4:
{
_Float32 left_value = *(_Float32 *)left_location;
- _Float32 right_value = strtof32(buffer, NULL);
+ _Float32 right_value = strtof(buffer, NULL);
retval = 0;
retval = left_value < right_value ? -1 : retval;
retval = left_value > right_value ? 1 : retval;
@@ -4209,7 +4237,7 @@ __gg__compare_2(cblc_field_t *left_side,
case 8:
{
_Float64 left_value = *(_Float64 *)left_location;
- _Float64 right_value = strtof64(buffer, NULL);
+ _Float64 right_value = strtod(buffer, NULL);
retval = 0;
retval = left_value < right_value ? -1 : retval;
retval = left_value > right_value ? 1 : retval;
@@ -4218,9 +4246,9 @@ __gg__compare_2(cblc_field_t *left_side,
case 16:
{
//_Float128 left_value = *(_Float128 *)left_location;
- _Float128 left_value;
+ GCOB_FP128 left_value;
memcpy(&left_value, left_location, 16);
- _Float128 right_value = strtof128(buffer, NULL);
+ GCOB_FP128 right_value = strtof128(buffer, NULL);
retval = 0;
retval = left_value < right_value ? -1 : retval;
retval = left_value > right_value ? 1 : retval;
@@ -4302,6 +4330,23 @@ __gg__compare_2(cblc_field_t *left_side,
{
// We are comparing an alphanumeric to a numeric.
+ // The right side is numeric. Sometimes people write code where they
+ // take the refmod of a numeric displays. If somebody did that here,
+ // just do a complete straight-up character by character comparison:
+
+ if( right_refmod )
+ {
+ retval = compare_strings( (char *)left_location,
+ left_length,
+ left_all,
+ (char *)right_location,
+ right_length,
+ right_all);
+ compare = true;
+ goto fixup_retval;
+ }
+
+
// The trick here is to convert the numeric to its display form,
// and compare that to the alphanumeric. For example, when comparing
// a VAL5 PIC X(3) VALUE 5 to literals,
@@ -4310,7 +4355,6 @@ __gg__compare_2(cblc_field_t *left_side,
// VAL5 EQUAL 005 is TRUE
// VAL5 EQUAL "5" is FALSE
// VAL5 EQUAL "005" is TRUE
-
if( left_side->type == FldLiteralA )
{
left_location = (unsigned char *)left_side->data;
@@ -4373,14 +4417,12 @@ fixup_retval:
right_location,
right_length,
right_attr,
- right_all,
- right_address_of,
+ right_flags,
left_side,
left_location,
left_length,
left_attr,
- left_all,
- left_address_of,
+ left_flags,
1);
// And reverse the sense of the return value:
compare = true;
@@ -4428,14 +4470,12 @@ __gg__compare(struct cblc_field_t *left,
left->data + left_offset,
left_length,
left->attr,
- !!(left_flags & REFER_T_MOVE_ALL),
- !!(left_flags & REFER_T_ADDRESS_OF),
+ left_flags,
right,
right->data + right_offset,
right_length,
right->attr,
- !!(right_flags & REFER_T_MOVE_ALL),
- !!(right_flags & REFER_T_ADDRESS_OF),
+ right_flags,
second_time_through);
return retval;
}
@@ -5710,7 +5750,7 @@ __gg__move( cblc_field_t *fdest,
case 16:
{
//_Float128 val = *(_Float128 *)(fsource->data+source_offset);
- _Float128 val;
+ GCOB_FP128 val;
memcpy(&val, fsource->data+source_offset, 16);
if(val < 0)
{
@@ -5798,7 +5838,7 @@ __gg__move( cblc_field_t *fdest,
// We are converted a floating-point value fixed-point
rdigits = get_scaled_rdigits(fdest);
- _Float128 value=0;
+ GCOB_FP128 value=0;
switch(fsource->capacity)
{
case 4:
@@ -5948,18 +5988,18 @@ __gg__move( cblc_field_t *fdest,
{
case 4:
{
- *(float *)(fdest->data+dest_offset) = strtof32(ach, NULL);
+ *(float *)(fdest->data+dest_offset) = strtof(ach, NULL);
break;
}
case 8:
{
- *(double *)(fdest->data+dest_offset) = strtof64(ach, NULL);
+ *(double *)(fdest->data+dest_offset) = strtod(ach, NULL);
break;
}
case 16:
{
//*(_Float128 *)(fdest->data+dest_offset) = strtof128(ach, NULL);
- _Float128 t = strtof128(ach, NULL);
+ GCOB_FP128 t = strtof128(ach, NULL);
memcpy(fdest->data+dest_offset, &t, 16);
break;
}
@@ -6118,17 +6158,17 @@ __gg__move_literala(cblc_field_t *field,
{
case 4:
{
- *(float *)(field->data+field_offset) = strtof32(ach, NULL);
+ *(float *)(field->data+field_offset) = strtof(ach, NULL);
break;
}
case 8:
{
- *(double *)(field->data+field_offset) = strtof64(ach, NULL);
+ *(double *)(field->data+field_offset) = strtod(ach, NULL);
break;
}
case 16:
{
- _Float128 t = strtof128(ach, NULL);
+ GCOB_FP128 t = strtof128(ach, NULL);
memcpy(field->data+field_offset, &t, 16);
break;
}
@@ -9112,10 +9152,10 @@ __gg__binary_value_from_qualified_field(int *rdigits,
}
extern "C"
-_Float128
+GCOB_FP128
__gg__float128_from_field( cblc_field_t *field )
{
- _Float128 retval=0;
+ GCOB_FP128 retval=0;
if( field->type == FldFloat || field->type == FldLiteralN )
{
retval = get_float128(field, field->data);
@@ -9123,20 +9163,20 @@ __gg__float128_from_field( cblc_field_t *field )
else
{
int rdigits;
- retval = (_Float128)__gg__binary_value_from_field(&rdigits, field);
+ retval = (GCOB_FP128)__gg__binary_value_from_field(&rdigits, field);
if( rdigits )
{
- retval /= (_Float128)__gg__power_of_ten(rdigits);
+ retval /= (GCOB_FP128)__gg__power_of_ten(rdigits);
}
}
return retval;
}
extern "C"
-_Float128
+GCOB_FP128
__gg__float128_from_qualified_field( cblc_field_t *field, size_t offset, size_t size)
{
- _Float128 retval=0;
+ GCOB_FP128 retval=0;
if( field->type == FldFloat || field->type == FldLiteralN )
{
retval = get_float128(field, field->data+offset);
@@ -9144,10 +9184,10 @@ __gg__float128_from_qualified_field( cblc_field_t *field, size_t offset, size_t
else
{
int rdigits;
- retval = (_Float128)__gg__binary_value_from_qualified_field(&rdigits, field, offset, size);
+ retval = (GCOB_FP128)__gg__binary_value_from_qualified_field(&rdigits, field, offset, size);
if( rdigits )
{
- retval /= (_Float128)__gg__power_of_ten(rdigits);
+ retval /= (GCOB_FP128)__gg__power_of_ten(rdigits);
}
}
return retval;
@@ -9213,7 +9253,7 @@ __gg__int128_to_qualified_field(cblc_field_t *tgt,
static __int128
float128_to_int128( int *rdigits,
cblc_field_t *field,
- _Float128 value,
+ GCOB_FP128 value,
cbl_round_t rounded,
int *compute_error)
{
@@ -9238,7 +9278,7 @@ float128_to_int128( int *rdigits,
// get away with.
// Calculate the number of digits to the left of the decimal point:
- int digits = (int)(floorf128(logf128(fabsf128(value)))+1);
+ int digits = (int)(FP128_FUNC(floor)(FP128_FUNC(log)(FP128_FUNC(fabs)(value)))+1);
// Make sure it is not a negative number
digits = std::max(0, digits);
@@ -9255,12 +9295,12 @@ float128_to_int128( int *rdigits,
// We now multiply our value by 10**rdigits, in order to make the
// floating-point value have the same magnitude as our target __int128
- value *= powf128(10.0Q, (_Float128)(*rdigits));
+ value *= FP128_FUNC(pow)(GCOB_FP128_LITERAL (10.0), (GCOB_FP128)(*rdigits));
// We are ready to cast value to an __int128. But this value could be
// too large to fit, which is an error condition we want to flag:
- if( fabsf128(value) >= 1.0E38Q )
+ if( FP128_FUNC(fabs)(value) >= GCOB_FP128_LITERAL (1.0E38) )
{
*compute_error = compute_error_overflow;
}
@@ -9277,7 +9317,7 @@ static void
float128_to_location( cblc_field_t *tgt,
unsigned char *data,
size_t size,
- _Float128 value,
+ GCOB_FP128 value,
enum cbl_round_t rounded,
int *compute_error)
{
@@ -9288,8 +9328,8 @@ float128_to_location( cblc_field_t *tgt,
switch(tgt->capacity)
{
case 4:
- if( fabsf128(value) == (_Float128)INFINITY
- || fabsf128(value) > 3.4028235E38Q )
+ if( FP128_FUNC(fabs)(value) == (GCOB_FP128)INFINITY
+ || FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
if( compute_error )
{
@@ -9311,8 +9351,8 @@ float128_to_location( cblc_field_t *tgt,
break;
case 8:
- if( fabsf128(value) == (_Float128)INFINITY
- || fabsf128(value) > 1.7976931348623157E308Q )
+ if( FP128_FUNC(fabs)(value) == (GCOB_FP128)INFINITY
+ || FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (1.7976931348623157E308) )
{
if( compute_error )
{
@@ -9334,7 +9374,7 @@ float128_to_location( cblc_field_t *tgt,
break;
case 16:
- if( fabsf128(value) == (_Float128)INFINITY )
+ if( FP128_FUNC(fabs)(value) == (GCOB_FP128)INFINITY )
{
if( compute_error )
{
@@ -9363,7 +9403,7 @@ float128_to_location( cblc_field_t *tgt,
digits = tgt->digits;
}
- _Float128 maximum;
+ GCOB_FP128 maximum;
if( digits )
{
@@ -9372,7 +9412,7 @@ float128_to_location( cblc_field_t *tgt,
// When digits is zero, this is a binary value without a PICTURE string.
// we don't truncate in that case
- if( digits && fabsf128(value) >= maximum )
+ if( digits && FP128_FUNC(fabs)(value) >= maximum )
{
*compute_error |= compute_error_truncate;
}
@@ -9400,7 +9440,7 @@ float128_to_location( cblc_field_t *tgt,
extern "C"
void
__gg__float128_to_field(cblc_field_t *tgt,
- _Float128 value,
+ GCOB_FP128 value,
enum cbl_round_t rounded,
int *compute_error)
{
@@ -9416,7 +9456,7 @@ extern "C"
void
__gg__float128_to_qualified_field(cblc_field_t *tgt,
size_t tgt_offset,
- _Float128 value,
+ GCOB_FP128 value,
enum cbl_round_t rounded,
int *compute_error)
{
@@ -10394,7 +10434,7 @@ __gg__fetch_call_by_value_value(cblc_field_t *field,
case 16:
// *(_Float128 *)(&retval) = double(*(_Float128 *)data);
- _Float128 t;
+ GCOB_FP128 t;
memcpy(&t, data, 16);
memcpy(&retval, &t, 16);
break;
@@ -10455,7 +10495,7 @@ __gg__assign_value_from_stack(cblc_field_t *dest, __int128 parameter)
case 16:
// *(_Float128 *)(dest->data) = *(_Float128 *)&parameter;
- _Float128 t;
+ GCOB_FP128 t;
memcpy(&t, &parameter, 16);
memcpy(dest->data, &t, 16);
break;
@@ -10968,13 +11008,6 @@ class match_file_declarative {
bool operator()( const cbl_declarative_t& dcl ) {
- if( getenv("match_declarative") && oops.type) {
- warnx("match_file_declarative: checking: oops %s dcl %s (handled %s) ",
- local_ec_type_str(oops.type),
- local_ec_type_str(dcl.type),
- local_ec_type_str(handled_type));
- }
-
// Declarative is for the raised exception and not handled by the statement.
if( handled() ) return false;
bool matches = enabled_ECs.match(dcl.type);
@@ -10988,13 +11021,6 @@ class match_file_declarative {
}
}
- if( matches && getenv("match_declarative") ) {
- warnx(" matches exception %s (file %zu mode %s)",
- local_ec_type_str(oops.type),
- oops.file,
- cbl_file_mode_str(oops.mode));
- }
-
return matches;
}
};
@@ -11194,25 +11220,12 @@ __gg__match_exception( cblc_field_t *index,
p = std::find_if( dcls + 1, eodcls, [ec] (const cbl_declarative_t& dcl) {
if( ! enabled_ECs.match(dcl.type) ) return false;
if( ! ec_cmp(ec, dcl.type) ) return false;
-
- if( getenv("match_declarative") ) {
- warnx("__gg__match_exception:%d: matched "
- "%s against mask %s for section #%zu",
- __LINE__,
- local_ec_type_str(ec), local_ec_type_str(dcl.type),
- dcl.section);
- }
return true;
} );
if( p == eodcls ) {
default_exception_handler(ec);
}
} else { // not enabled
- if( getenv("match_declarative") ) {
- warnx("__gg__match_exception:%d: raised exception "
- "%s is disabled (%zu enabled)", __LINE__,
- local_ec_type_str(ec), enabled_ECs.nec);
- }
}
}
@@ -11291,10 +11304,10 @@ __gg__pseudo_return_flush()
}
extern "C"
-_Float128
+GCOB_FP128
__gg__float128_from_location(cblc_field_t *var, unsigned char *location)
{
- _Float128 retval = 0;
+ GCOB_FP128 retval = 0;
switch( var->capacity )
{
case 4:
@@ -11323,9 +11336,9 @@ extern "C"
__int128
__gg__integer_from_float128(cblc_field_t *field)
{
- _Float128 fvalue = __gg__float128_from_location(field, field->data);
+ GCOB_FP128 fvalue = __gg__float128_from_location(field, field->data);
// we round() to take care of the possible 2.99999999999... problem.
- fvalue = roundf128(fvalue);
+ fvalue = FP128_FUNC(round)(fvalue);
return (__int128)fvalue;
}
@@ -11444,10 +11457,6 @@ extern "C"
void
__gg__set_exception_file(cblc_file_t *file)
{
- if( getenv("match_declarative") )
- {
- warnx("%s: %s", __func__, file->name);
- }
recent_file = file;
ec_type_t ec = local_ec_type_of( file->io_status );
if( ec )
@@ -11504,10 +11513,6 @@ extern "C"
void
__gg__set_exception_code(ec_type_t ec, int from_raise_statement)
{
- if( getenv("match_declarative") )
- {
- warnx("%s: raised %02x", __func__, ec);
- }
sv_from_raise_statement = from_raise_statement;
__gg__exception_code = ec;
@@ -11551,13 +11556,13 @@ __gg__float32_from_int128(cblc_field_t *destination,
int *size_error)
{
int rdigits;
- _Float128 value = get_binary_value_local( &rdigits,
+ GCOB_FP128 value = get_binary_value_local( &rdigits,
source,
source->data + source_offset,
source->capacity);
value /= __gg__power_of_ten(rdigits);
- if( fabsf128(value) > 3.4028235E38Q )
+ if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
if(size_error)
{
@@ -11592,7 +11597,7 @@ __gg__float64_from_int128(cblc_field_t *destination,
*size_error = 0;
}
int rdigits;
- _Float128 value = get_binary_value_local( &rdigits,
+ GCOB_FP128 value = get_binary_value_local( &rdigits,
source,
source->data + source_offset,
source->capacity);
@@ -11615,7 +11620,7 @@ __gg__float128_from_int128(cblc_field_t *destination,
{
if(size_error) *size_error = 0;
int rdigits;
- _Float128 value = get_binary_value_local( &rdigits,
+ GCOB_FP128 value = get_binary_value_local( &rdigits,
source,
source->data + source_offset,
source->capacity);
@@ -11642,7 +11647,7 @@ __gg__is_float_infinite(cblc_field_t *source, size_t offset)
break;
case 16:
// retval = *(_Float128*)(source->data+offset) == INFINITY;
- _Float128 t;
+ GCOB_FP128 t;
memcpy(&t, source->data+offset, 16);
retval = t == INFINITY;
break;
@@ -11659,9 +11664,9 @@ __gg__float32_from_128( cblc_field_t *dest,
{
int retval = 0;
//_Float128 value = *(_Float128*)(source->data+source_offset);
- _Float128 value;
+ GCOB_FP128 value;
memcpy(&value, source->data+source_offset, 16);
- if( fabsf128(value) > 3.4028235E38Q )
+ if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
retval = 1;
}
@@ -11681,7 +11686,7 @@ __gg__float32_from_64( cblc_field_t *dest,
{
int retval = 0;
_Float64 value = *(_Float64*)(source->data+source_offset);
- if( fabsf128(value) > 3.4028235E38Q )
+ if( FP128_FUNC(fabs)(value) > GCOB_FP128_LITERAL (3.4028235E38) )
{
retval = 1;
}
@@ -11701,9 +11706,9 @@ __gg__float64_from_128( cblc_field_t *dest,
{
int retval = 0;
// _Float128 value = *(_Float128*)(source->data+source_offset);
- _Float128 value;
+ GCOB_FP128 value;
memcpy(&value, source->data+source_offset, 16);
- if( fabsf128(value) > 1.7976931348623157E308 )
+ if( FP128_FUNC(fabs)(value) > 1.7976931348623157E308 )
{
retval = 1;
}
@@ -11955,7 +11960,7 @@ __gg__function_handle_from_cobpath( char *unmangled_name, char *mangled_name)
}
if( !retval )
{
- const char *COBPATH = getenv("COBPATH");
+ const char *COBPATH = getenv("GCOBOL_LIBRARY_PATH");
retval = find_in_dirs(COBPATH, unmangled_name, mangled_name);
}
if( !retval )
generated by cgit v1.1 at 2025-04-13 06:08:02 +0000