[gcc r17-3145] cobol: Refactor COMPUTE using Reverse Polish stack.
Robert Dubner via Gcc-cvs <[email protected]>
| Newsgroups | gmane.comp.gcc.cvs |
|---|---|
| Message-ID | <[email protected]> |
https://gcc.gnu.org/g:131d80fb55d57b4a25ef3d5e62567955df825d7a commit r17-3145-g131d80fb55d57b4a25ef3d5e62567955df825d7a Author: Robert Dubner <[email protected]> Date: Fri Aug 7 16:03:26 2026 -0400 cobol: Refactor COMPUTE using Reverse Polish stack. COBOL provides the COMPUTE statement, which evaluates an expression and assigns the result to one or more target variables. Our former implementation of COMPUTE z = a * b + c * d was profligate with the creation of temporary variables. In that case, temporaries were created for a*b and c*d, and another created for their sum, which then became input to the assignment phase. These changes change that implementation to a version using Reverse Polish Notation. An RPN stack is created and passed to the libgcobol library, where the stack is reduced and a result created. This is computionally somewhat more efficient, and it greatly reduces the computational load on the GCC middle end. Co-authored-by: James K. Lowden <[email protected]> Co-authored-by: Robert Dubner <[email protected]> gcc/cobol/ChangeLog: * genapi.cc (gg_array_of_field_pointers): Modified to return a pointer to the first element of the array. (gg_array_of_uchar_p): Formatting. (parser_sort): Use updated gg_array_of_field_pointers(). (parser_file_sort): Likewise. (parser_file_merge): Likewise. * genapi.h (parser_compute): New declarations. * gengen.h (gg_array_of_field_pointers): Modified declaration. * genmath.cc (parser_compute): New declarations. * genutil.h (gg_array_of_uchar_p): New declaration. * move.cc (mh_binary_to_numdisp): Use new __gg__prohibited() routine. (parser_move): Formatting. (parser_move_multi): Formatting. * parse.y: RPN support. * parse_ante.h (ast_op): Likewise. (ast_relop): Likewise. (struct ast_op_t): Likewise. (struct refer_list_t): Likewise. (struct vargs_t): Likewise. * symbols.h (struct rpn_t): Likewise. (struct expr_t): Likewise. libgcobol/ChangeLog: * gmath.cc (__gg__pow): Use exponentiation_helper(). (exponentiation_helper): New routine. (__gg__process_compute_error): Formatting. (multiply_int128_by_int128): Use new int128 structure. (divide_int128_by_int128): Formatting. (multiply_int256_by_int256): New routine. (divide_int256_by_int256): New routine. (compute_fixed_add): New routine to implement RPN COMPUTE. (compute_fixed_subtract): Likewise. (compute_fixed_multiply): Likewise. (compute_fixed_divide): Likewise. (compute_fixed_negate): Likewise. (compute_float_add): Likewise. (compute_float_subtract): Likewise. (compute_float_multiply): Likewise. (compute_float_divide): Likewise. (compute_float_pow): Likewise. (compute_float_negate): Likewise. (__gg__compute_fixed): Likewise. (__gg__compute_float): Likewise. * libgcobol.cc (__gg__prohibited): New routine tests value and target for ROUNDING MODE PROHIBITED compliance. * libgcobol.h: Formatting. Diff: --- gcc/cobol/genapi.cc | 22 +-- gcc/cobol/genapi.h | 12 ++ gcc/cobol/gengen.h | 2 +- gcc/cobol/genmath.cc | 129 +++++++++++++ gcc/cobol/genutil.h | 1 + gcc/cobol/move.cc | 507 ++++++++++++++++++++++++++----------------------- gcc/cobol/parse.y | 270 +++++++++++++++----------- gcc/cobol/parse_ante.h | 173 ++++++++++++++++- gcc/cobol/symbols.h | 28 +++ libgcobol/gmath.cc | 488 +++++++++++++++++++++++++++++++++++++++++++++-- libgcobol/libgcobol.cc | 53 ++++++ libgcobol/libgcobol.h | 2 +- 12 files changed, 1294 insertions(+), 393 deletions(-) diff --git a/gcc/cobol/genapi.cc b/gcc/cobol/genapi.cc index 418f5ea22f6c..41f46036df98 100644 --- a/gcc/cobol/genapi.cc +++ b/gcc/cobol/genapi.cc @@ -11674,12 +11674,11 @@ gg_array_of_field_pointers( const std::vector<const cbl_field_t *> &fields ) for( size_t i=0; i<N; i++ ) { - gcc_assert( fields[i] != NULL ); - gcc_assert( fields[i]->var_decl_node != NULL_TREE ); + tree field_pointer = fields[i] && fields[i]->var_decl_node + ? gg_get_address_of( fields[i]->var_decl_node) + : null_pointer_node; - tree field_pointer = - gg_cast( cblc_field_p_type_node, - gg_get_address_of( fields[i]->var_decl_node ) ); + field_pointer = gg_cast( cblc_field_p_type_node, field_pointer ); CONSTRUCTOR_APPEND_ELT( elts, bitsize_int( i ), @@ -11693,7 +11692,7 @@ gg_array_of_field_pointers( const std::vector<const cbl_field_t *> &fields ) TREE_READONLY( retval ) = 1; DECL_INITIAL( retval ) = constr; - return retval; + return gg_pointer_to_array(retval); } tree @@ -11723,9 +11722,7 @@ gg_array_of_uchar_p( const std::vector<tree> &uchar_p ) } tree constr = build_constructor( array_type, elts ); - tree retval = gg_define_variable( array_type ); - TREE_READONLY( retval ) = 1; DECL_INITIAL( retval ) = constr; @@ -11788,8 +11785,7 @@ parser_sort(cbl_refer_t tableref, } } - tree all_keys = gg_pointer_to_array( - gg_array_of_field_pointers(flattened_fields_2)); + tree all_keys = gg_array_of_field_pointers(flattened_fields_2); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t(flattened_ascending_2 ); @@ -11911,8 +11907,7 @@ parser_file_sort( cbl_file_t *workfile, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_pointer_to_array( - gg_array_of_field_pointers(flattened_fields_2)); + tree all_keys = gg_array_of_field_pointers(flattened_fields_2); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t(flattened_ascending_2 ); @@ -12246,8 +12241,7 @@ parser_file_merge( cbl_file_t *workfile, } // Create the array of cbl_field_t pointers for the keys - tree all_keys = gg_pointer_to_array( - gg_array_of_field_pointers(flattened_fields_2)); + tree all_keys = gg_array_of_field_pointers(flattened_fields_2); // Create the array of integers that are the flags for ASCENDING: tree ascending = gg_array_of_size_t(flattened_ascending_2 ); diff --git a/gcc/cobol/genapi.h b/gcc/cobol/genapi.h index de3825ac2638..0f20f4dfd337 100644 --- a/gcc/cobol/genapi.h +++ b/gcc/cobol/genapi.h @@ -204,6 +204,18 @@ parser_classify( struct cbl_field_t *tgt, const struct cbl_refer_t &srca, enum classify_t type ); +void +parser_compute( cbl_refer_t *tgt, + const std::deque<rpn_t>& operations, + cbl_label_t *lbl ); + +void +parser_compute( std::vector<cbl_num_result_t>& results, + const std::deque<rpn_t>& operations, + cbl_label_t *on_error, + cbl_label_t *not_error, + cbl_label_t *compute_error); + void parser_op( struct cbl_refer_t cref, struct cbl_refer_t aref, int op, struct cbl_refer_t bref, diff --git a/gcc/cobol/gengen.h b/gcc/cobol/gengen.h index 0f6ba8028592..ea2f2812a3a9 100644 --- a/gcc/cobol/gengen.h +++ b/gcc/cobol/gengen.h @@ -508,7 +508,7 @@ extern void gg_free(tree pointer); extern tree gg_strlen(tree psz); extern size_t gg_sizeof(tree decl_node); -extern tree gg_array_of_field_pointers( const std::vector<cbl_field_t *> &fields ); +extern tree gg_array_of_field_pointers( const std::vector<const cbl_field_t *> &fields ); extern tree gg_array_of_bytes( size_t N, unsigned char *values); extern tree gg_indirect(tree pointer, tree byte_offset = NULL_TREE); extern tree gg_indirect_i(tree pointer, size_t offset=0); diff --git a/gcc/cobol/genmath.cc b/gcc/cobol/genmath.cc index 9aab8e711b19..0715b009d23f 100644 --- a/gcc/cobol/genmath.cc +++ b/gcc/cobol/genmath.cc @@ -2389,6 +2389,135 @@ parser_divide( const cbl_refer_t& cref, NULL ); } +void +parser_compute( cbl_refer_t *tgt, + const std::deque<rpn_t>& operations, + cbl_label_t * compute_error_label ) + { + CHECK_FIELD(tgt->field); + gcc_assert(operations.size()); + + set_up_compute_error_label(compute_error_label); + + gg_assign(var_decl_default_compute_error, integer_zero_node); + tree compute_error = compute_error_label + ? gg_get_address_of( compute_error_label-> + structs.compute_error-> + compute_error_code) + : gg_get_address_of(var_decl_default_compute_error) ; + + SHOW_PARSE + { + SHOW_PARSE_HEADER + SHOW_PARSE_REF(" dest: ", *tgt); + char *psz; + for(auto op : operations) + { + if( op.op ) + { + psz = xasprintf("%c", op.op); + } + else + { + if( !op.term.field ) + { + psz = xasprintf("both op.op and op.term.field are NULL"); + } + else + { + psz = xasprintf("%s", op.term.field->name); + } + } + + SHOW_PARSE_INDENT + SHOW_PARSE_TEXT(psz); + free(psz); + } + SHOW_PARSE_END + } + + std::string opstring; + std::vector<const cbl_field_t *>fields; + std::vector<tree> offsets; + + //bool compute_float = false; + const char *routine = "__gg__compute_fixed"; + for(auto op : operations) + { + if( op.op == '^' + || (op.term.field && op.term.field->type == FldFloat) ) + { + //compute_float = true; + routine = "__gg__compute_float"; + } + opstring += op.op ? op.op : ascii_P; + fields.push_back(op.term.field); + offsets.push_back(refer_offset(op.term)); + } + + // The final element on the stacks is for the destination field: + fields.push_back(tgt->field); + offsets.push_back(refer_offset(*tgt)); + + tree retval = gg_define_variable(INT); + gg_assign(retval, + gg_call_expr( INT, + routine, + gg_string_literal(opstring.c_str()), + gg_array_of_field_pointers(fields), + gg_array_of_uchar_p(offsets), + NULL_TREE)); + gg_assign(gg_indirect(compute_error), retval); + } + +void +parser_compute( std::vector<cbl_num_result_t>& results, + const std::deque<rpn_t>& operations, + cbl_label_t *on_error, + cbl_label_t *not_error, + cbl_label_t *compute_error) + { + bool compute_float = false; + for(auto op : operations) + { + if( op.op == '^' + || (op.term.field && op.term.field->type == FldFloat) ) + { + compute_float = true; + break; + } + } + + cbl_field_t *temp_field; + + if( compute_float ) + { + temp_field = new_temporary(FldFloat, + nullptr, + intermediate_e); + } + else + { + temp_field = new_temporary(FldNumericBin5, + nullptr, + signable_e); + } + cbl_refer_t temp_refer; + temp_refer.field = temp_field; + + parser_compute( &temp_refer, operations, compute_error ); + + if( !results.empty() ) + { + parser_assign(results.size(), + results.data(), + temp_refer, + on_error, + not_error, + compute_error); + } + } + void parser_op( struct cbl_refer_t cref, struct cbl_refer_t aref, diff --git a/gcc/cobol/genutil.h b/gcc/cobol/genutil.h index c01e79723593..8eaa86cc062f 100644 --- a/gcc/cobol/genutil.h +++ b/gcc/cobol/genutil.h @@ -91,6 +91,7 @@ bool process_this_exception(const ec_type_t ec); void rt_error(const char *msg); tree build_array_of_size_t( size_t N, const size_t *values); +tree gg_array_of_uchar_p( const std::vector<tree> &uchar_p ); void parser_display_internal_field(tree file_descriptor, cbl_field_t *field, bool advance=DISPLAY_NO_ADVANCE); diff --git a/gcc/cobol/move.cc b/gcc/cobol/move.cc index 5e49c56c3fd2..bb00cb217155 100644 --- a/gcc/cobol/move.cc +++ b/gcc/cobol/move.cc @@ -1293,234 +1293,257 @@ mh_binary_to_numdisp(const cbl_refer_t &destref, tree value ; get_binary_value(value, sourceref, work_type); - tree negative = gg_define_variable(INT); - gg_assign(negative, integer_zero_node); - - tree sign_location = NULL_TREE; - - if( destref.field->attr & signable_e ) + tree prohibited = gg_define_variable(INT, integer_zero_node); + if( rounded == prohibited_e ) { - sign_location = gg_define_variable(UCHAR_P); - if( (destref.field->attr & separate_e) - && (destref.field->attr & leading_e ) ) - { - // separate and leading - gg_assign(sign_location, dest_location); - gg_increment(dest_location); - } - else if( (destref.field->attr & separate_e) - && !(destref.field->attr & leading_e ) ) - { - // separate and trailing - gg_assign(sign_location, gg_add(dest_location, - build_int_cst_type(SIZE_T, - destref.field->data.capacity()-1))); - } - else if( !(destref.field->attr & separate_e) - && (destref.field->attr & leading_e ) ) - { - // internal and leading - gg_assign(sign_location, dest_location); - } - else - { - // internal and trailing - gg_assign(sign_location, gg_add(dest_location, - build_int_cst_type(SIZE_T, - destref.field->data.capacity()-1))); - } + gg_assign(prohibited, + gg_call_expr(INT, + "__gg__prohibited", + gg_get_address_of(destref.field->var_decl_node), + value, + NULL_TREE)); } - - if( (sourceref.field->attr & signable_e) - && (destref.field->attr & signable_e) ) + IF(prohibited, eq_op, integer_one_node) { - // Both source and dest are signable, which means we have to preserve - // the source sign and apply it, eventually, to the target. - IF( value, lt_op, gg_cast(work_type, integer_zero_node) ) + set_exception_code(ec_size_truncation_e); + if( size_error ) { - gg_assign(negative, integer_one_node); + gg_assign(size_error, integer_one_node); } - ELSE {} ENDIF } + ELSE + { + get_binary_value(value, sourceref, work_type); + tree negative = gg_define_variable(INT); + gg_assign(negative, integer_zero_node); - // At this point we have to align the source and destination value rdigits. + tree sign_location = NULL_TREE; - if( !(sourceref.field->attr & intermediate_e) ) - { - // Because the source is not intermediate, we can work with the compile- - // time values. - int source_rdigits = sourceref.field->data.rdigits; - int dest_rdigits = destref.field->data.rdigits; - int nshift = source_rdigits - dest_rdigits; - if(nshift < 0) + if( destref.field->attr & signable_e ) { - // We need to multiply the source by 10^(-nshift) to line them up. - FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( -nshift ); - gg_assign(value, gg_multiply(value, - wide_int_to_tree(work_type, - power_of_ten))); - } - else if(nshift > 0) - { - // We need to divide the source by 10^(nshift) to line them up. - // This is a potential rounding situation. - FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( nshift ); - tree pot = wide_int_to_tree(work_type, power_of_ten); - gg_assign(negative, - gg_bitwise_and( negative, - round_this_value(value, - pot, - rounded, - size_error))); + sign_location = gg_define_variable(UCHAR_P); + if( (destref.field->attr & separate_e) + && (destref.field->attr & leading_e ) ) + { + // separate and leading + gg_assign(sign_location, dest_location); + gg_increment(dest_location); + } + else if( (destref.field->attr & separate_e) + && !(destref.field->attr & leading_e ) ) + { + // separate and trailing + gg_assign(sign_location, gg_add(dest_location, + build_int_cst_type(SIZE_T, + destref.field->data.capacity()-1))); + } + else if( !(destref.field->attr & separate_e) + && (destref.field->attr & leading_e ) ) + { + // internal and leading + gg_assign(sign_location, dest_location); + } + else + { + // internal and trailing + gg_assign(sign_location, gg_add(dest_location, + build_int_cst_type(SIZE_T, + destref.field->data.capacity()-1))); + } } - } - else - { - // Source is intermediate; we need to use the dynamic source rdigits - // Because the source is not intermediate, we can work with the compile- - // time values. - tree source_rdigits = gg_define_variable(INT); - tree dest_rdigits; - tree nshift = gg_define_variable(INT); - gg_assign(source_rdigits, - gg_cast(INT, - member(sourceref.field->var_decl_node, - "rdigits"))); - dest_rdigits = build_int_cst_type(INT, destref.field->data.rdigits); - gg_assign(nshift, gg_subtract(source_rdigits, dest_rdigits)); - tree power_of_ten = gg_define_variable(work_type); - IF( nshift, lt_op, integer_zero_node ) + if( (sourceref.field->attr & signable_e) + && (destref.field->attr & signable_e) ) { - // We need to multiply the source by 10^(-nshift) to line them up. - gg_assign(power_of_ten, - gg_cast(work_type, - gg_call_expr(INT128, - "__gg__power_of_ten", - gg_negate(nshift), - NULL_TREE))); - gg_assign(value, gg_multiply(value, power_of_ten)); + // Both source and dest are signable, which means we have to preserve + // the source sign and apply it, eventually, to the target. + IF( value, lt_op, gg_cast(work_type, integer_zero_node) ) + { + gg_assign(negative, integer_one_node); + } + ELSE {} ENDIF } - ELSE + + // At this point we have to align the source and destination value rdigits. + + if( !(sourceref.field->attr & intermediate_e) ) { - IF( nshift, gt_op, integer_zero_node ) + // Because the source is not intermediate, we can work with the compile- + // time values. + int source_rdigits = sourceref.field->data.rdigits; + int dest_rdigits = destref.field->data.rdigits; + int nshift = source_rdigits - dest_rdigits; + if(nshift < 0) + { + // We need to multiply the source by 10^(-nshift) to line them up. + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( -nshift ); + gg_assign(value, gg_multiply(value, + wide_int_to_tree(work_type, + power_of_ten))); + } + else if(nshift > 0) { // We need to divide the source by 10^(nshift) to line them up. // This is a potential rounding situation. - gg_assign(power_of_ten, - gg_cast(work_type, - gg_call_expr(INT128, - "__gg__power_of_ten", - nshift, - NULL_TREE))); + FIXED_WIDE_INT(128) power_of_ten = get_power_of_ten( nshift ); + tree pot = wide_int_to_tree(work_type, power_of_ten); gg_assign(negative, gg_bitwise_and( negative, round_this_value(value, - power_of_ten, + pot, rounded, size_error))); } + } + else + { + // Source is intermediate; we need to use the dynamic source rdigits + // Because the source is not intermediate, we can work with the compile- + // time values. + tree source_rdigits = gg_define_variable(INT); + tree dest_rdigits; + tree nshift = gg_define_variable(INT); + + gg_assign(source_rdigits, + gg_cast(INT, + member(sourceref.field->var_decl_node, + "rdigits"))); + dest_rdigits = build_int_cst_type(INT, destref.field->data.rdigits); + gg_assign(nshift, gg_subtract(source_rdigits, dest_rdigits)); + tree power_of_ten = gg_define_variable(work_type); + IF( nshift, lt_op, integer_zero_node ) + { + // We need to multiply the source by 10^(-nshift) to line them up. + gg_assign(power_of_ten, + gg_cast(work_type, + gg_call_expr(INT128, + "__gg__power_of_ten", + gg_negate(nshift), + NULL_TREE))); + gg_assign(value, gg_multiply(value, power_of_ten)); + } ELSE { + IF( nshift, gt_op, integer_zero_node ) + { + // We need to divide the source by 10^(nshift) to line them up. + // This is a potential rounding situation. + gg_assign(power_of_ten, + gg_cast(work_type, + gg_call_expr(INT128, + "__gg__power_of_ten", + nshift, + NULL_TREE))); + gg_assign(negative, + gg_bitwise_and( negative, + round_this_value(value, + power_of_ten, + rounded, + size_error))); + } + ELSE + { + } + ENDIF } ENDIF } - ENDIF - } - // At this point, value is lined up with the destination. + // At this point, value is lined up with the destination. - // Make it positive + // Make it positive - if( !TYPE_UNSIGNED(work_type) ) - { - gg_assign(value, gg_abs(value)); - } + if( !TYPE_UNSIGNED(work_type) ) + { + gg_assign(value, gg_abs(value)); + } - if( size_error ) - { - // We need to see if is too big to fit - FIXED_WIDE_INT(128) power_of_ten = - get_power_of_ten(destref.field->data.digits); - tree pot = wide_int_to_tree(work_type, power_of_ten); - IF( gg_divide(value, pot), - ne_op, - gg_cast(work_type, integer_zero_node) ) - { - // The value is too big; flag it: - gg_assign(size_error, integer_one_node); - } - ELSE - { - } - ENDIF - } + if( size_error ) + { + // We need to see if is too big to fit + FIXED_WIDE_INT(128) power_of_ten = + get_power_of_ten(destref.field->data.digits); + tree pot = wide_int_to_tree(work_type, power_of_ten); + IF( gg_divide(value, pot), + ne_op, + gg_cast(work_type, integer_zero_node) ) + { + // The value is too big; flag it: + gg_assign(size_error, integer_one_node); + } + ELSE + { + } + ENDIF + } - if( charmap_dest->is_like_ebcdic() ) - { - gg_call(INT, - "__gg__binary_to_string_ebcdic", - dest_location, - build_int_cst_type(INT, destref.field->data.digits), - gg_cast(INT128, value), - NULL_TREE); - } - else - { - gg_call(INT, - "__gg__binary_to_string_ascii", - dest_location, - build_int_cst_type(INT, destref.field->data.digits), - gg_cast(INT128, value), - NULL_TREE); - } + if( charmap_dest->is_like_ebcdic() ) + { + gg_call(INT, + "__gg__binary_to_string_ebcdic", + dest_location, + build_int_cst_type(INT, destref.field->data.digits), + gg_cast(INT128, value), + NULL_TREE); + } + else + { + gg_call(INT, + "__gg__binary_to_string_ascii", + dest_location, + build_int_cst_type(INT, destref.field->data.digits), + gg_cast(INT128, value), + NULL_TREE); + } - if( (sourceref.field->attr & signable_e ) - && (destref.field->attr & signable_e ) ) - { - IF( negative, ne_op, integer_zero_node ) + if( (sourceref.field->attr & signable_e ) + && (destref.field->attr & signable_e ) ) { - if( destref.field->attr & separate_e ) - { - // We flag the separate as negative - gg_assign(gg_indirect(sign_location), minus); - } - else + IF( negative, ne_op, integer_zero_node ) { - if( charmap_dest->is_like_ebcdic() ) + if( destref.field->attr & separate_e ) { - gg_assign(gg_indirect(sign_location), - gg_bitwise_and(gg_indirect(sign_location), - build_int_cst_type(UCHAR, 0xDF))); + // We flag the separate as negative + gg_assign(gg_indirect(sign_location), minus); } else { - gg_assign(gg_indirect(sign_location), - gg_bitwise_or(gg_indirect(sign_location), - build_int_cst_type(UCHAR, 0x70))); + if( charmap_dest->is_like_ebcdic() ) + { + gg_assign(gg_indirect(sign_location), + gg_bitwise_and(gg_indirect(sign_location), + build_int_cst_type(UCHAR, 0xDF))); + } + else + { + gg_assign(gg_indirect(sign_location), + gg_bitwise_or(gg_indirect(sign_location), + build_int_cst_type(UCHAR, 0x70))); + } } } - } - ELSE - { - // The result is positive - if( destref.field->attr & separate_e ) + ELSE { - // We flag the separate as negative - gg_assign(gg_indirect(sign_location), plus); + // The result is positive + if( destref.field->attr & separate_e ) + { + // We flag the separate as negative + gg_assign(gg_indirect(sign_location), plus); + } } + ENDIF + } + else if( (destref.field->attr & signable_e ) + && (destref.field->attr & separate_e ) ) + { + // The source is not signed, but the destination is signable and + // separate: + gg_assign(gg_indirect(sign_location), plus); } - ENDIF - } - else if( (destref.field->attr & signable_e ) - && (destref.field->attr & separate_e ) ) - { - // The source is not signed, but the destination is signable and - // separate: - gg_assign(gg_indirect(sign_location), plus); - } - moved = true; + moved = true; + } + ENDIF } return moved; @@ -3768,36 +3791,36 @@ parser_move(cbl_refer_t destref, SHOW_PARSE_REF(" ", sourceref) } SHOW_PARSE_REF(" TO ", destref) - switch(rounded) - { - case away_from_zero_e: - SHOW_PARSE_TEXT(" AWAY_FROM_ZERO") - break; - case nearest_toward_zero_e: - SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO") - break; - case toward_greater_e: - SHOW_PARSE_TEXT(" TOWARD_GREATER") - break; - case toward_lesser_e: - SHOW_PARSE_TEXT(" TOWARD_LESSER") - break; - case nearest_away_from_zero_e: - SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO") - break; - case nearest_even_e: - SHOW_PARSE_TEXT(" NEAREST_EVEN") - break; - case prohibited_e: - SHOW_PARSE_TEXT(" PROHIBITED") - break; - case truncation_e: - SHOW_PARSE_TEXT(" TRUNCATED") - break; - default: - gcc_unreachable(); - break; - } + switch(rounded) + { + case away_from_zero_e: + SHOW_PARSE_TEXT(" AWAY_FROM_ZERO") + break; + case nearest_toward_zero_e: + SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO") + break; + case toward_greater_e: + SHOW_PARSE_TEXT(" TOWARD_GREATER") + break; + case toward_lesser_e: + SHOW_PARSE_TEXT(" TOWARD_LESSER") + break; + case nearest_away_from_zero_e: + SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO") + break; + case nearest_even_e: + SHOW_PARSE_TEXT(" NEAREST_EVEN") + break; + case prohibited_e: + SHOW_PARSE_TEXT(" PROHIBITED") + break; + case truncation_e: + SHOW_PARSE_TEXT(" TRUNCATED") + break; + default: + gcc_unreachable(); + break; + } SHOW_PARSE_END } @@ -3867,36 +3890,36 @@ parser_move_multi(cbl_refer_t destref, SHOW_PARSE_REF(" ", sourceref) } SHOW_PARSE_REF(" TO ", destref) - switch(rounded) - { - case away_from_zero_e: - SHOW_PARSE_TEXT(" AWAY_FROM_ZERO") - break; - case nearest_toward_zero_e: - SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO") - break; - case toward_greater_e: - SHOW_PARSE_TEXT(" TOWARD_GREATER") - break; - case toward_lesser_e: - SHOW_PARSE_TEXT(" TOWARD_LESSER") - break; - case nearest_away_from_zero_e: - SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO") - break; - case nearest_even_e: - SHOW_PARSE_TEXT(" NEAREST_EVEN") - break; - case prohibited_e: - SHOW_PARSE_TEXT(" PROHIBITED") - break; - case truncation_e: - SHOW_PARSE_TEXT(" TRUNCATED") - break; - default: - gcc_unreachable(); - break; - } + switch(rounded) + { + case away_from_zero_e: + SHOW_PARSE_TEXT(" AWAY_FROM_ZERO") + break; + case nearest_toward_zero_e: + SHOW_PARSE_TEXT(" NEAREST_TOWARD_ZERO") + break; + case toward_greater_e: + SHOW_PARSE_TEXT(" TOWARD_GREATER") + break; + case toward_lesser_e: + SHOW_PARSE_TEXT(" TOWARD_LESSER") + break; + case nearest_away_from_zero_e: + SHOW_PARSE_TEXT(" NEAREST_AWAY_FROM_ZERO") + break; + case nearest_even_e: + SHOW_PARSE_TEXT(" NEAREST_EVEN") + break; + case prohibited_e: + SHOW_PARSE_TEXT(" PROHIBITED") + break; + case truncation_e: + SHOW_PARSE_TEXT(" TRUNCATED") + break; + default: + gcc_unreachable(); + break; + } SHOW_PARSE_END } diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index 77eddebc2267..e940e86fae51 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -51,6 +51,8 @@ accept_envar_e, }; + class ast_op_t; + struct coll_alphanat_t { const char *alpha, *national; }; @@ -749,7 +751,6 @@ class locale_tgt_t { %type <refer> alloc_ret %type <field> log_term rel_expr rel_abbr eval_abbr -%type <refer> num_value num_term value factor %type <refer> simple_cond bool_expr until_expr %type <log_expr_t> log_expr rel_abbrs eval_abbrs %type <rel_term_t> rel_term rel_term1 @@ -793,9 +794,13 @@ class locale_tgt_t { %type <refer> alphaval alpha_val numeref scalar scalar88 scalar_any %type <refer> tableref tableish %type <refer> varg varg1 varg1a start_after start_pos -%type <refer> expr expr_term compute_expr free_tgt by_value_arg +%type <refer> cexpr free_tgt by_value_arg %type <refer> move_tgt read_key read_into vary_by -%type <refer> num_operand envar search_expr any_arg +%type <refer> num_operand num_value envar search_expr any_arg + +%type <ast_op> expr expr_term num_term value factor + compute_expr + %type <accept_func> accept_body %type <refers> subscript_exprs subscripts arg_list free_tgts %type <targets> move_tgts set_tgts @@ -972,7 +977,7 @@ class locale_tgt_t { struct { bool tf; cbl_field_t *field; } bool_field; struct { int token; cbl_field_t *cond; } cond_field; struct cbl_refer_t *refer; - + ast_op_t *ast_op; struct rel_term_type { bool invert; cbl_refer_t *term; } rel_term_t; struct log_expr_t *log_expr_t; struct vargs_t* vargs; @@ -992,8 +997,7 @@ class locale_tgt_t { linage_t linage; linage_value_t linage_value; struct arith_t *arith; - struct { size_t ntgt; cbl_num_result_t *tgts; - cbl_refer_t *expr; } compute_body_t; + struct { size_t ntgt; cbl_num_result_t *tgts; ast_op_t *ast_op; } compute_body_t; struct cbl_inspect_t *insp_one; cbl_inspect_opers_t *insp_all; struct cbl_inspect_oper_t *insp_oper; @@ -1079,6 +1083,8 @@ class locale_tgt_t { $$.term? name_of($$.term->field) : "<none>"); } <rel_term_t> %printer { fprintf(yyo, "%s", $$->dbgstr()); } <log_expr_t> +%printer { fprintf(yyo, "%lu args\n", (unsigned long)$$->args.size()); $$->dump(); } <vargs> + %printer { fprintf(yyo, "%s (token %d)", keyword_str($$), $$ ); } relop %printer { fprintf(yyo, "'%s'", $$? $$ : "" ); } NAME <string> %printer { fprintf(yyo, "%s'%.*s'{" HOST_SIZE_T_PRINT_UNSIGNED "} %s", @@ -1566,7 +1572,7 @@ class locale_tgt_t { %locations %token-table %define parse.error verbose // custom -%expect 7 +%expect 6 %require "3.5.1" // 3.8.2 also works, but not 3.8.0 %% @@ -5935,12 +5941,12 @@ accept_body: ACCEPT scalar[r] $$.func = accept_done_e; parser_accept_command_line(*$r, NULL, NULL, NULL ); } - | ACCEPT scalar[r] FROM COMMAND_LINE '(' expr ')' + | ACCEPT scalar[r] FROM COMMAND_LINE '(' cexpr ')' { statement_begin(@1, ACCEPT); $$.func = accept_command_line_e; $$.into = $r; - $$.from = $expr; + $$.from = $cexpr; } | ACCEPT scalar[r] FROM COMMAND_LINE_COUNT { @@ -6232,7 +6238,7 @@ scalar88: name88 subscripts[subs] refmod[ref] } ; -allocate: ALLOCATE expr[size] CHARACTERS initialized RETURNING scalar[returning] +allocate: ALLOCATE cexpr[size] CHARACTERS initialized RETURNING scalar[returning] { statement_begin(@1, ALLOCATE); if( $size->field->type == FldLiteralN ) { @@ -6270,22 +6276,33 @@ alloc_ret: %empty { static cbl_refer_t empty; $$ = ∅ } | RETURNING scalar[name] { $$ = $name; } ; -compute: compute_impl end_compute { current.compute_end(); } - | compute_cond end_compute { current.compute_end(); } +compute: compute_impl end_compute + | compute_cond end_compute ; compute_impl: COMPUTE compute_body[body] { - parser_assign( $body.ntgt, $body.tgts, *$body.expr, - NULL, NULL, current.compute_label() ); + std::vector<cbl_num_result_t> results($body.tgts, + $body.tgts + $body.ntgt); + $body.ast_op->show(results); // always a good idea to show results + $body.ast_op->rpn_sanity_check(); + parser_compute( results, $body.ast_op->as_deque(), + nullptr, nullptr, + current.compute_label() ); + $body.ast_op->reset(); current.declaratives_evaluate(); + current.compute_end(); } ; compute_cond: COMPUTE compute_body[body] arith_errs[err] { - parser_assign( $body.ntgt, $body.tgts, *$body.expr, - $err.on_error, $err.not_error, - current.compute_label() ); + std::vector<cbl_num_result_t> results($body.tgts, + $body.tgts + $body.ntgt); + parser_compute( results, $body.ast_op->as_deque(), + $err.on_error, $err.not_error, + current.compute_label() ); + $body.ast_op->reset(); current.declaratives_evaluate(); + current.compute_end(); } ; end_compute: %empty %prec COMPUTE @@ -6296,16 +6313,15 @@ compute_body: rnames { statement_begin(@$, COMPUTE); } compute_expr[expr] { $$.ntgt = rhs.size(); auto C = new cbl_num_result_t[$$.ntgt]; $$.tgts = use_any(rhs, C); - $$.expr = $expr; + $$.ast_op = $expr; } ; -compute_expr: EQ { +compute_expr: EQ expr { if( $1[0] == 'E' ) { // lexer found EQUALS keyword dialect_ok(@1, IbmEqualAssignE, "EQUAL as assignment operator" ); } current.compute_begin(); - } expr { $$ = $expr; } ; @@ -6571,9 +6587,9 @@ continue_stmt: CONTINUE { statement_begin(@1, CONTINUE); parser_sleep(*cbl_refer_t::empty()); } - | CONTINUE AFTER expr SECONDS { + | CONTINUE AFTER cexpr SECONDS { statement_begin(@1, CONTINUE); - parser_sleep(*$expr); + parser_sleep(*$cexpr); } ; @@ -6700,42 +6716,42 @@ simple_cond: kind_of_name bit_on_op : bit_off_op; parser_bitop($$->cond(), parent, op, value ); } - | expr is CLASS_NAME[domain] + | cexpr is CLASS_NAME[domain] { $$ = new_reference(new_temporary(FldConditional)); // symbol_find does not find FldClass symbols struct symbol_elem_t *e = symbol_field(PROGRAM, 0, $domain); parser_setop($$->cond(), $1->field, is_op, cbl_field_of(e)); } - | expr NOT CLASS_NAME[domain] { + | cexpr NOT CLASS_NAME[domain] { $$ = new_reference(new_temporary(FldConditional)); // symbol_find does not find FldClass symbols struct symbol_elem_t *e = symbol_field(PROGRAM, 0, $domain); parser_setop($$->cond(), $1->field, is_op, cbl_field_of(e)); parser_logop($$->cond(), NULL, not_op, $$->cond()); } - | expr is OMITTED + | cexpr is OMITTED { - auto lhs = cbl_refer_t($expr->field); + auto lhs = cbl_refer_t($cexpr->field); lhs.addr_of = true; auto rhs = cbl_field_of(symbol_field(0,0, "NULLS")); $$ = new_reference(new_temporary(FldConditional)); ast_relop(@$, $$->field, lhs, eq_op, rhs); } - | expr /* IS */ NOT OMITTED + | cexpr /* IS */ NOT OMITTED { // IS captured by lexer - auto lhs = cbl_refer_t($expr->field); + auto lhs = cbl_refer_t($cexpr->field); lhs.addr_of = true; auto rhs = cbl_field_of(symbol_field(0,0, "NULLS")); $$ = new_reference(new_temporary(FldConditional)); ast_relop(@$, $$->field, lhs, ne_op, rhs); } - | expr /* IS */ posneg[op] { + | cexpr /* IS */ posneg[op] { $$ = new_reference(new_temporary(FldConditional)); relop_t op = static_cast<relop_t>($op); cbl_field_t *zero = constant_of(constant_index(ZERO)); if( $1->field->type == FldPointer ) { - error_msg(@expr, "cannot compare %qs (%s) to zero", + error_msg(@cexpr, "cannot compare %qs (%s) to zero", nice_name_of($1->field), cbl_field_type_name($1->field->type)); YYERROR; @@ -6756,7 +6772,7 @@ simple_cond: kind_of_name } ; -kind_of_name: expr might_be variable_type +kind_of_name: cexpr might_be variable_type { $$ = new_temporary(FldConditional); enum classify_t type = classify_of($3); @@ -6953,7 +6969,7 @@ rel_term1: all LITERAL $$.term = new_reference(constant_of(constant_index(ZERO))); $$.term->all = true; } - | expr { + | cexpr { $$.invert = false; $$.term = $1; } @@ -6963,41 +6979,54 @@ rel_term1: all LITERAL } ; +cexpr: expr { + $$ = $expr->compute($expr); + } + ; expr: expr_term ; expr_term: expr_term '+' num_term { - if( ($$ = ast_op(@$, $1, '+', $3)) == NULL ) YYERROR; + if( ! ast_op_t::op_ok(@$, '+', $3) ) YYERROR; + $$ = &$1->push_op('+', *$3); } | expr_term '-' num_term { - if( ($$ = ast_op(@$, $1, '-', $3)) == NULL ) YYERROR; + if( ! ast_op_t::op_ok(@$, '-', $3) ) YYERROR; + $$ = &$1->push_op('-', *$3); } | num_term ; num_term: num_term '*' value { - if( ($$ = ast_op(@$, $1, '*', $3)) == NULL ) YYERROR; + if( ! ast_op_t::op_ok(@$, '*', $3) ) YYERROR; + $$ = &$1->push_op('*', *$3); } | num_term '/' value { - if( ($$ = ast_op(@$, $1, '/', $3)) == NULL ) YYERROR; + if( ! ast_op_t::op_ok(@$, '/', $3) ) YYERROR; + $$ = &$1->push_op('/', *$3); } | value ; value: value POW factor { - if( ($$ = ast_op(@$, $1, '^', $3)) == NULL ) YYERROR; + if( ! ast_op_t::op_ok(@$, '^', $3) ) YYERROR; + $$ = &$1->push_op('^', *$3); } - | '-' value %prec NEG { $$ = negate( $2 );} - | '+' factor %prec NEG { $$ = $2;} - | factor[rhs] + | '-' value[operand] %prec NEG { $$ = &$operand->push_op('!'); } + | '+' factor %prec NEG { $$ = $2;} + | factor ; factor: '(' expr ')' { $$ = $2; } - | num_value { $$ = $num_value; } + | num_value + { + $$ = new ast_op_t; + $$->expr($num_value); + } ; if_stmt: if_impl end_if @@ -7066,7 +7095,7 @@ eval_subject: eval_subject1 { } ; eval_subject1: bool_expr - | expr + | cexpr | true_false { static cbl_field_t *zero = constant_of(constant_index(ZERO)); @@ -7391,14 +7420,14 @@ tableish: name subscripts[subs] refmod[ref] %prec NAME } ; -refmod: LPAREN expr[from] ':' expr[len] ')' %prec NAME +refmod: LPAREN cexpr[from] ':' cexpr[len] ')' %prec NAME { if( ! require_integer(@from, *$from) ) YYERROR; if( ! require_integer(@len, *$len) ) YYERROR; $$.from = $from; $$.len = $len; } - | LPAREN expr[from] ':' ')' %prec NAME + | LPAREN cexpr[from] ':' ')' %prec NAME { if( ! require_integer(@from, *$from) ) YYERROR; $$.from = $from; @@ -8105,19 +8134,19 @@ subscripts: LPAREN subscript_exprs ')' { } } ; -subscript_exprs: expr +subscript_exprs: cexpr { - if( ! require_integer(@expr, *$expr) ) YYERROR; - $$ = new refer_list_t($expr); + if( ! require_integer(@cexpr, *$cexpr) ) YYERROR; + $$ = new refer_list_t(*$cexpr); } - | subscript_exprs expr { + | subscript_exprs cexpr { if( $1->size() == MAXIMUM_TABLE_DIMENSIONS ) { error_msg(@1, "table dimensions limited to %d", MAXIMUM_TABLE_DIMENSIONS); YYERROR; } - if( ! require_integer(@expr, *$expr) ) YYERROR; - $1->push_back($2); $$ = $1; + if( ! require_integer(@cexpr, *$cexpr) ) YYERROR; + $1->push_back(*$2); $$ = $1; } | ALL { auto ref = new_reference(constant_of(constant_index(ZERO))); @@ -8125,10 +8154,10 @@ subscript_exprs: expr } ; -arg_list: any_arg { $$ = new refer_list_t($1); } - | arg_list any_arg { $1->push_back($2); $$ = $1; } +arg_list: any_arg { $$ = new refer_list_t(*$1); } + | arg_list any_arg { $1->push_back(*$2); $$ = $1; } ; -any_arg: expr +any_arg: cexpr | LITERAL {$$ = new_reference(new_literal(@1, $1, quoted_e)); } ; @@ -9210,8 +9239,8 @@ delete_file_body: } ; retry_phrase: %empty - | RETRY expr TIMES - | FOR expr SECONDS + | RETRY cexpr TIMES + | FOR cexpr SECONDS | FOREVER { cbl_unimplemented("DELETE FILE RETRY"); } @@ -9391,12 +9420,12 @@ start_body: filename[file] $$ = file_start_args.init(@file, $file); parser_file_start( $file, relop_of($relop), key, ksize ); } - | filename[file] KEY relop name[key] with LENGTH expr + | filename[file] KEY relop name[key] with LENGTH cexpr { // lexer swallows IS, although relop allows it. statement_begin(@$, START); int key = $file->key_one($key); $$ = file_start_args.init(@file, $file); - parser_file_start( $file, relop_of($relop), key, *$expr ); + parser_file_start( $file, relop_of($relop), key, *$cexpr ); } | filename[file] FIRST { @@ -9845,7 +9874,7 @@ search_term: scalar[key] EQ search_expr[sarg] is_ascending_key(key) ); } ; -search_expr: expr +search_expr: cexpr | LITERAL { $$ = new_reference(new_literal(@1, $1, quoted_e)); } ; @@ -10698,7 +10727,7 @@ ffi_by_ref: scalar_arg[refer] } ; -ffi_by_con: expr +ffi_by_con: cexpr { cbl_refer_t *r = new cbl_refer_t(*$1); $$ = new cbl_ffi_arg_t(by_content_e, r); @@ -10929,7 +10958,6 @@ label_1: qname /* string & unstring */ - string: string_impl end_string | string_cond end_string ; @@ -11332,12 +11360,12 @@ intrinsic: function_udf cbl_unimplemented("BASECONVERT"); if( ! intrinsic_call_3($$, BASECONVERT, $r1, $r2, $r3 )) YYERROR; } - | BIT_OF '(' expr[r1] ')' { + | BIT_OF '(' cexpr[r1] ')' { location_set(@1); $$ = new_alphanumeric("BIT-OF"); if( ! intrinsic_call_1($$, BIT_OF, $r1, @r1)) YYERROR; } - | CHAR '(' expr[r1] ')' { + | CHAR '(' cexpr[r1] ')' { location_set(@1); $$ = new_alphanumeric("CHAR"); if( ! intrinsic_call_1($$, CHAR, $r1, @r1)) YYERROR; @@ -11421,7 +11449,7 @@ intrinsic: function_udf parser_intrinsic_find_string($$, *$r1, *$r2, $after, $last, $anycase); } - | FORMATTED_DATE '(' DATE_FMT[r1] expr[r2] ')' { + | FORMATTED_DATE '(' DATE_FMT[r1] cexpr[r2] ')' { location_set(@1); $$ = new_alphanumeric("FORMATTED-DATE"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); @@ -11430,8 +11458,8 @@ intrinsic: function_udf } - | FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2] - expr[r3] ')' { + | FORMATTED_DATETIME '(' DATETIME_FMT[r1] cexpr[r2] + cexpr[r3] ')' { location_set(@1); $$ = new_alphanumeric("FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); @@ -11440,8 +11468,8 @@ intrinsic: function_udf if( ! intrinsic_call_4($$, FORMATTED_DATETIME, r1, $r2, $r3, &r3) ) YYERROR; } - | FORMATTED_DATETIME '(' DATETIME_FMT[r1] expr[r2] - expr[r3] expr[r4] ')' { + | FORMATTED_DATETIME '(' DATETIME_FMT[r1] cexpr[r2] + cexpr[r3] cexpr[r4] ')' { location_set(@1); $$ = new_alphanumeric("FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); @@ -11452,8 +11480,8 @@ intrinsic: function_udf | FORMATTED_DATETIME '(' error ')' { YYERROR; } - | FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] - expr[r3] ')' { + | FORMATTED_TIME '(' TIME_FMT[r1] cexpr[r2] + cexpr[r3] ')' { location_set(@1); $$ = new_alphanumeric("FORMATTED-DATETIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); @@ -11461,7 +11489,7 @@ intrinsic: function_udf if( ! intrinsic_call_3($$, FORMATTED_TIME, r1, $r2, $r3) ) YYERROR; } - | FORMATTED_TIME '(' TIME_FMT[r1] expr[r2] ')' { + | FORMATTED_TIME '(' TIME_FMT[r1] cexpr[r2] ')' { location_set(@1); $$ = new_alphanumeric("FORMATTED-TIME"); auto r1 = new_reference(new_literal(strlen($r1), $r1, quoted_e)); @@ -11585,7 +11613,7 @@ intrinsic: function_udf $$ = new_tempnumeric_float("RANDOM"); parser_intrinsic_call_0( $$, intrinsic_cname(RANDOM) ); } - | RANDOM_SEED expr[r1] ')' + | RANDOM_SEED cexpr[r1] ')' { // left parenthesis consumed by lexer location_set(@1); $$ = new_tempnumeric_float("RANDOM-SEED"); @@ -11644,7 +11672,7 @@ intrinsic: function_udf * TRIM (arg-1 arg-2a arg-2b) is the same as * TRIM (TRIM (arg-1 arg-2a) arg-2b). */ - | TRIM '(' expr[r1] trim_trailing[how] trim_expr[args2] ')' + | TRIM '(' cexpr[r1] trim_trailing[how] trim_expr[args2] ')' { location_set(@1); switch( $r1->field->type ) { @@ -11671,21 +11699,21 @@ intrinsic: function_udf parser_trim($$, *$r1, $how, args); } - | USUBSTR '(' alpha_val[r1] expr[r2] expr[r3] ')' { + | USUBSTR '(' alpha_val[r1] cexpr[r2] cexpr[r3] ')' { location_set(@1); $$ = new_alphanumeric("USUBSTR"); if( ! intrinsic_call_3($$, FORMATTED_DATETIME, $r1, $r2, $r3) ) YYERROR; } - | intrinsic_I '(' expr[r1] ')' + | intrinsic_I '(' cexpr[r1] ')' { location_set(@1); $$ = new_tempnumeric(keyword_str($1)); if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR; } - | intrinsic_N '(' expr[r1] ')' + | intrinsic_N '(' cexpr[r1] ')' { location_set(@1); $$ = new_tempnumeric_float(keyword_str($1)); @@ -11717,14 +11745,14 @@ intrinsic: function_udf if( ! intrinsic_call_1($$, $1, $r1, @r1)) YYERROR; } - | intrinsic_I2 '(' expr[r1] expr[r2] ')' + | intrinsic_I2 '(' cexpr[r1] cexpr[r2] ')' { location_set(@1); $$ = new_tempnumeric("intrinsic_I2"); if( ! intrinsic_call_2($$, $1, $r1, $r2) ) YYERROR; } - | DATE_TO_YYYYMMDD '(' expr[r1] ')' + | DATE_TO_YYYYMMDD '(' cexpr[r1] ')' { location_set(@1); static auto r2 = new_reference(FldNumericDisplay, "50"); @@ -11741,7 +11769,7 @@ intrinsic: function_udf $r1, r2, r3) ) YYERROR; } - | DATE_TO_YYYYMMDD '(' expr[r1] expr[r2] ')' + | DATE_TO_YYYYMMDD '(' cexpr[r1] cexpr[r2] ')' { location_set(@1); static auto one = new cbl_refer_t( new_constant("1") ); @@ -11757,8 +11785,8 @@ intrinsic: function_udf $r1, $r2, r3) ) YYERROR; } - | DATE_TO_YYYYMMDD '(' expr[r1] - expr[r2] expr[r3] ')' + | DATE_TO_YYYYMMDD '(' cexpr[r1] + cexpr[r2] cexpr[r3] ')' { location_set(@1); $$ = new_tempnumeric("DATE_TO_YYYYMMDD"); @@ -11766,7 +11794,7 @@ intrinsic: function_udf $r1, $r2, $r3) ) YYERROR; } - | DAY_TO_YYYYDDD '(' expr[r1] ')' + | DAY_TO_YYYYDDD '(' cexpr[r1] ')' { location_set(@1); static auto r2 = new_reference(FldNumericDisplay, "50"); @@ -11783,7 +11811,7 @@ intrinsic: function_udf $r1, r2, r3) ) YYERROR; } - | DAY_TO_YYYYDDD '(' expr[r1] expr[r2] ')' + | DAY_TO_YYYYDDD '(' cexpr[r1] cexpr[r2] ')' { location_set(@1); static auto one = new cbl_refer_t( new_constant("1") ); @@ -11799,8 +11827,8 @@ intrinsic: function_udf $r1, $r2, r3) ) YYERROR; } - | DAY_TO_YYYYDDD '(' expr[r1] - expr[r2] expr[r3] ')' + | DAY_TO_YYYYDDD '(' cexpr[r1] + cexpr[r2] cexpr[r3] ')' { location_set(@1); $$ = new_tempnumeric("DAY_TO_YYYYDDD"); @@ -11808,7 +11836,7 @@ intrinsic: function_udf $r1, $r2, $r3) ) YYERROR; } - | YEAR_TO_YYYY '(' expr[r1] ')' + | YEAR_TO_YYYY '(' cexpr[r1] ')' { location_set(@1); static auto r2 = new_reference(new_constant("50")); @@ -11825,7 +11853,7 @@ intrinsic: function_udf $r1, r2, r3) ) YYERROR; } - | YEAR_TO_YYYY '(' expr[r1] expr[r2] ')' + | YEAR_TO_YYYY '(' cexpr[r1] cexpr[r2] ')' { location_set(@1); static auto one = new cbl_refer_t( new_constant("1") ); @@ -11841,8 +11869,8 @@ intrinsic: function_udf $r1, $r2, r3) ) YYERROR; } - | YEAR_TO_YYYY '(' expr[r1] - expr[r2] expr[r3] ')' + | YEAR_TO_YYYY '(' cexpr[r1] + cexpr[r2] cexpr[r3] ')' { location_set(@1); $$ = new_tempnumeric("YEAR_TO_YYYY"); @@ -11850,7 +11878,7 @@ intrinsic: function_udf $r1, $r2, $r3) ) YYERROR; } - | intrinsic_N2 '(' expr[r1] expr[r2] ')' + | intrinsic_N2 '(' cexpr[r1] cexpr[r2] ')' { location_set(@1); switch($1) { @@ -13656,32 +13684,60 @@ cbl_key_t::operator=( const sort_key_t& that ) { return *this; } -static cbl_refer_t * -ast_op( const cbl_loc_t& loc, cbl_refer_t *lhs, char op, cbl_refer_t *rhs ) { - assert(lhs); - assert(rhs); - if( ! (is_numeric(lhs->field) && is_numeric(rhs->field)) ) { - // If one of the fields isn't numeric, allow for index addition. +ast_op_t::choose_intermediate_type& +ast_op_t::choose_intermediate_type::select_highest( const rpn_t& rpn ) { + const cbl_field_t *field = rpn.term.field; + + if( field ) { + if( ! is_numeric(field) ) { output = *field; return *this; } + if( output.type == FldFloat ) return *this; + + if( field->type == FldFloat ) { + output.type = FldFloat; + output.data.capacity(16); + output.attr = intermediate_e; + } + this->operand = field; + return *this; + } + + if( rpn.op == '*' ) { + if( operand ) { + output.data.digits += operand->data.digits; + } + if( output.data.digits > MAX_FIXED_POINT_DIGITS) { + output.type = FldFloat; + output.data.capacity(16); + output.attr = intermediate_e; + } + } + return *this; +} + +bool +ast_op_t::op_ok( const cbl_loc_t& loc, char op, const ast_op_t *rhstack ) +{ + assert(rhstack); + + const rpn_t& rpn(rhstack->top()); + const cbl_refer_t& rhs(rpn.term); + gcc_assert( rhs.field || rpn.op ); + + if( rhs.field && ! is_numeric(rhs.field) ) { + // If the field isn't numeric, allow for index addition. switch(op) { case '+': case '-': // Simple addition OK for table indexes. - if( lhs->field->type == FldIndex || rhs->field->type == FldIndex ) { - goto ok; + if( rhs.field->type == FldIndex ) { + return true; } } - auto f = !is_numeric(lhs->field)? lhs->field : rhs->field; - error_msg(loc, "%qs is not numeric", f->name); - return NULL; - } - ok: - cbl_field_t skel = determine_intermediate_type( *lhs, op, *rhs ); - cbl_refer_t *tgt = new_reference_like(skel); - if( !mode_syntax_only() ) { - parser_op( *tgt, *lhs, op, *rhs, current.compute_label() ); + error_msg(loc, "%qs is not numeric", rhs.field->name); + return false; } - return tgt; + return true; } /* diff --git a/gcc/cobol/parse_ante.h b/gcc/cobol/parse_ante.h index 49eb90b265ab..c2cb3437d0b7 100644 --- a/gcc/cobol/parse_ante.h +++ b/gcc/cobol/parse_ante.h @@ -631,11 +631,156 @@ struct arith_t { } }; -static cbl_refer_t * ast_op( const cbl_loc_t& loc, - cbl_refer_t *lhs, char op, cbl_refer_t *rhs ); +static void +ast_relop( const cbl_loc_t& loc, cbl_field_t *tgt, + cbl_refer_t lhs, relop_t op, cbl_refer_t rhs ); -static void ast_relop( const cbl_loc_t& loc, cbl_field_t *tgt, - cbl_refer_t lhs, relop_t relop, cbl_refer_t rhs ); + +/* + * Collect an RPN stack of operations. The compute() member function calls + * parser_compute to processes the stack to a target. Alternatively, the + * COMPUTE statement calls parser_compute with a list of one or more targets. + */ +struct ast_op_t : private std::stack<rpn_t>{ + cbl_label_t *lbl; // the COMPUTE error label + public: + ast_op_t() : lbl(nullptr) {} + + cbl_refer_t * operator=( cbl_refer_t * term ) { + top() = rpn_t(*term); + return term; + } + + static bool op_ok( const cbl_loc_t& loc, char op, const ast_op_t *rhs ); + + cbl_refer_t * expr( cbl_refer_t * term ) { + dbgmsg("ast_op_t::%s:%d: %s", __func__, __LINE__, field_str(term->field)); + push( rpn_t(*term) ); + return term; + } + + ast_op_t& push_op( char op, const ast_op_t& rhs = ast_op_t() ) { + c.insert( c.end(), rhs.c.begin(), rhs.c.end() ); + push( rpn_t(op) ); + rpn_dump(c); + return *this; + } + + cbl_refer_t * compute( cbl_refer_t *tgt ) { + gcc_assert( ! empty() ); + if( 1 < c.size() ) { + tgt = compute(); + } + return tgt; + } + + cbl_refer_t * compute( ast_op_t *operand ) { + return c.size() == 1 ? &operand->top().term : compute(); + } + + /* + * choose_intermediate_type is a functor that defaults to FldNumericBin5. If + * while iterating over the operands it determines that one is FldFloat, or + * that the required digits exceeds the maximum, it selects FldFloat instead. + */ + class choose_intermediate_type { + cbl_field_t output; + const cbl_field_t *operand; + public: + choose_intermediate_type() : output( FldNumericBin5, + (intermediate_e | signable_e), + {}, 0, "", {} ) + , operand(nullptr) + { + output.data.capacity(16); + output.data.digits = MAX_FIXED_POINT_DIGITS; + } + choose_intermediate_type& select_highest( const rpn_t& rpn ); + choose_intermediate_type& operator()( const rpn_t& rpn ) { + return select_highest(rpn); + } + cbl_field_t field() const { return output; } + }; + + cbl_field_t intermediate_type() const { + const auto& selected = std::for_each( c.rbegin(), c.rend(), + choose_intermediate_type() ); + return selected.field(); + } + + const std::deque<rpn_t>& as_deque() const { return this->c; } + void reset() { c.clear(); } + + void show( std::vector<cbl_num_result_t>& results ) { + if( yydebug ) { + int i=0; + for( const auto& result : results ) { + dbgmsg( "result %u: %s", i++, result.refer.str() ); + } + rpn_dump(c); + } + } + + bool rpn_sanity_check() { + auto n = std::accumulate( c.rbegin(), c.rend(), 0, + []( int n, const rpn_t& rpn ) { + if( rpn.term.field ) return ++n; + switch(rpn.op) { + case '+': case '-': + case '*': case '/': case '^': return --n; + case '!': return n; // unuary minus + } + dbgmsg("rpn_sanity_check: n=%d, neither field nor op", n); + gcc_unreachable(); + } ); + if( n != 1 ) rpn_dump(c); + dbgmsg("rpn_sanity_check: n=%d, %s", n, n == 1? "ok" : "bzzt"); + return n == 1; + } + + protected: + bool valid_size() const { + return 2 < c.size() || top().op == '!'; + } + cbl_refer_t * compute() { + gcc_assert( ! empty() ); + gcc_assert( 1 < c.size() ); + + const cbl_field_t& skel = intermediate_type(); + cbl_refer_t *tgt = new_reference_like(skel); + dbgmsg("ast_op_t::%s:%d: target %s capacity %u", __func__, __LINE__, + cbl_field_type_str(tgt->field->type), tgt->field->data.capacity()); + if( !valid_size() ) { + yydebug = 1; + rpn_dump(c); + } + // We have at least 3 operands, or the first operator is unary negation. + gcc_assert( valid_size() ); + rpn_dump(c); // for now + rpn_sanity_check(); + + parser_compute(tgt, c, lbl); + + this->c.clear(); + dbgmsg("ast_op_t::%s:%d: output %s %s capacity %u", __func__, __LINE__, + cbl_field_type_str(tgt->field->type), nice_name_of(tgt->field), + tgt->field->data.capacity()); + return tgt; + } + + static void rpn_dump( const std::deque<rpn_t>& c ) { + dbgmsg("ast_op_t::%s:%d: %lu members", __func__, __LINE__, (unsigned long)c.size()); + for( const auto& operand : c ) { + auto f = operand.term.field; + if( f ) { + auto type = cbl_field_type_str(f->type); + dbgmsg("ast_op_t::%s:%d: %-20s %s", __func__, __LINE__, type, field_str(f)); + } else { + dbgmsg("ast_op_t::%s:%d: %c", __func__, __LINE__, operand.op); + } + } + } +}; static void ast_add( arith_t *arith ); static bool ast_subtract( arith_t *arith ); @@ -1086,11 +1231,19 @@ struct refer_list_t { delete refer; } } + // the source is not always to be deleted + explicit refer_list_t( const cbl_refer_t& refer ) { + refers.push_back(refer); + } refer_list_t * push_back( cbl_refer_t *refer ) { refers.push_back(*refer); delete refer; return this; } + refer_list_t * push_back( const cbl_refer_t& refer ) { + refers.push_back(refer); + return this; + } inline list<cbl_refer_t>& items() { return refers; } inline list<cbl_refer_t>::iterator begin() { return refers.begin(); } inline list<cbl_refer_t>::iterator end() { return refers.end(); } @@ -1378,9 +1531,15 @@ static list<cbl_refer_t> lhs; struct vargs_t { std::list<cbl_refer_t> args; - vargs_t() {} - explicit vargs_t( struct cbl_refer_t *p ) { args.push_back(*p); delete p; } - void push_back( cbl_refer_t *p ) { args.push_back(*p); delete p; } + vargs_t() {} + explicit vargs_t( struct cbl_refer_t *p ) { args.push_back(*p); delete p; } + void push_back( cbl_refer_t *p ) { args.push_back(*p); delete p; } + void dump() const { + int i=0; + for( auto arg : args ) { + dbgmsg("\t%3d: %s", i++, arg.str()); + } + } }; static const char intermediate[] = ":intermediate"; diff --git a/gcc/cobol/symbols.h b/gcc/cobol/symbols.h index ddbe3176df75..6ab34a5df877 100644 --- a/gcc/cobol/symbols.h +++ b/gcc/cobol/symbols.h @@ -1109,6 +1109,34 @@ struct cbl_refer_t { } }; +/* + * An element in the RPN stack for expression evaluation, either an operation + * or an operand. A NUL operator indicates an operand. + */ +struct rpn_t { + char op; + cbl_refer_t term; + rpn_t( char op ) : op(op) { // cppcheck-suppress noExplicitConstructor + static const char ops[] = "+-*/^!"; + gcc_assert( std::any_of(ops, ops + sizeof(ops), + [op]( char ch ) { return op == ch; }) ); + } + rpn_t( const cbl_refer_t &term ) // cppcheck-suppress noExplicitConstructor + : op('\0'), term(term) + {} +}; + +struct expr_t { + char op; + cbl_refer_t lhs, rhs; + cbl_label_t *lbl; + expr_t( char op, + const cbl_refer_t& lhs, const cbl_refer_t& rhs, + cbl_label_t *lbl ) + : op(op), lhs(lhs), rhs(rhs), lbl(lbl) + {} +}; + struct elem_key_t { size_t program; const char * name; diff --git a/libgcobol/gmath.cc b/libgcobol/gmath.cc index c4670ff10b08..c6570f091a0d 100644 --- a/libgcobol/gmath.cc +++ b/libgcobol/gmath.cc @@ -253,24 +253,9 @@ subtraction_helper_float(GCOB_FP128 a_value, return a_value; } -extern "C" -void -__gg__pow( cbl_arith_format_t, - size_t, - const cblc_referlet_t *A, - size_t, - const cblc_referlet_t *B, - size_t, - const cblc_referlet_t *C, - const cbl_round_t *rounded, - int on_error_flag, - int *compute_error - ) +static GCOB_FP128 +exponentiation_helper(GCOB_FP128 avalue, GCOB_FP128 bvalue, int *compute_error) { - GCOB_FP128 avalue = - __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); - GCOB_FP128 bvalue = - __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); GCOB_FP128 tgt_value; if( avalue == 0 && bvalue == 0 ) @@ -304,6 +289,30 @@ __gg__pow( cbl_arith_format_t, tgt_value = 0; } } + return tgt_value; + } + +extern "C" +void +__gg__pow( cbl_arith_format_t, + size_t, + const cblc_referlet_t *A, + size_t, + const cblc_referlet_t *B, + size_t, + const cblc_referlet_t *C, + const cbl_round_t *rounded, + int on_error_flag, + int *compute_error + ) + { + GCOB_FP128 avalue = + __gg__float128_from_qualified_field(A[0].field, A[0].offset, A[0].size); + GCOB_FP128 bvalue = + __gg__float128_from_qualified_field(B[0].field, B[0].offset, B[0].size); + + GCOB_FP128 tgt_value = exponentiation_helper(avalue, bvalue, compute_error); + if( !(*compute_error & compute_error_exp_minus_by_frac) ) { *compute_error |= conditional_stash(C[0].field, @@ -320,7 +329,7 @@ void __gg__process_compute_error(int compute_error) { // This routine gets called after a series of parser_op operations is - // complete (see parser_assign()) when the source code didn't specify + // complete (see parser_assign()) when the source code didn't specify // an ON SIZE ERROR clause. if( compute_error & compute_error_divide_by_zero) { @@ -357,7 +366,7 @@ typedef struct int256 { uint64_t i64[4]; int rdigits; - }int256; + } int256; static inline uint64_t uint128_lo64(uint128 value) @@ -1325,7 +1334,6 @@ void multiply_int128_by_int128(int256 &ABCD, negate_int256(ABCD); } ABCD.rdigits = ab_value.rdigits + cd_value.rdigits; - } extern "C" @@ -1754,7 +1762,6 @@ divide_int128_by_int128(int256 "ient, } } - extern "C" void __gg__dividef1_phase2(cbl_arith_format_t , @@ -2115,3 +2122,442 @@ __gg__dividef45(cbl_arith_format_t , } } +static int +multiply_int256_by_int256(int256 &left, const int256 &right) + { + int retval = 0; + // The inputs have both been squeezed into 128 bits. + int128 l128; + int128 r128; + + l128.i128 = int256_get_u128(left, 0); + l128.rdigits = left.rdigits; + + r128.i128 = int256_get_u128(right, 0); + r128.rdigits = right.rdigits; + + // We need to make both 128-bit operands positive: + bool negative = false; + if( left.i64[3] & 0x8000000000000000ULL ) + { + negative = !negative; + l128.i128 = ~l128.i128 + 1; + } + if( right.i64[3] & 0x8000000000000000ULL ) + { + negative = !negative; + r128.i128 = ~r128.i128 + 1; + } + + multiply_int128_by_int128(left, l128, r128); + + if( negative ) + { + // This code takes the two's complement of the 256-bit value: + left.i64[0] = ~left.i64[0]; + left.i64[1] = ~left.i64[1]; + left.i64[2] = ~left.i64[2]; + left.i64[3] = ~left.i64[3]; + // I usually eschew code like this. But it's just too precious. + if(++left.i64[0] == 0) + if(++left.i64[1] == 0) + if(++left.i64[2] == 0) + ++left.i64[3]; + } + + return retval; + } + +static int +divide_int256_by_int256(int256 &left, const int256 &right) + { + int retval = 0; + // The inputs have both been squeezed into 128 bits. + int128 l128; + int128 r128; + + l128.i128 = int256_get_u128(left, 0); + l128.rdigits = left.rdigits; + + r128.i128 = int256_get_u128(right, 0); + r128.rdigits = right.rdigits; + + // We need to make both 128-bit operands positive: + bool negative = false; + if( left.i64[3] & 0x8000000000000000ULL ) + { + negative = !negative; + l128.i128 = ~l128.i128 + 1; + } + if( right.i64[3] & 0x8000000000000000ULL ) + { + negative = !negative; + r128.i128 = ~r128.i128 + 1; + } + + divide_int128_by_int128(left, + l128.i128, + l128.rdigits, + r128.i128, + r128.rdigits, + &retval); + + if( negative ) + { + // This code takes the two's complement of the 256-bit value: + left.i64[0] = ~left.i64[0]; + left.i64[1] = ~left.i64[1]; + left.i64[2] = ~left.i64[2]; + left.i64[3] = ~left.i64[3]; + // I usually eschew code like this. But it's just too precious. + if(++left.i64[0] == 0) + if(++left.i64[1] == 0) + if(++left.i64[2] == 0) + ++left.i64[3]; + } + + return retval; + } + +static std::vector<GCOB_FP128> compute_float_stack; +static std::vector<int256> compute_fixed_stack; + +static int +compute_fixed_add() + { + // This is RPN at work, so stack[N-2] += stack[N-1] + int retval = 0; + + size_t level = compute_fixed_stack.size(); + assert( level >= 2 ); + int256 left = compute_fixed_stack[level-2]; + int256 right = compute_fixed_stack[level-1]; + + add_int256_to_int256(left, right); + + compute_fixed_stack[level-2] = left; + compute_fixed_stack.pop_back(); + return retval; + } + +static int +compute_fixed_subtract() + { + int retval = 0; + + size_t level = compute_fixed_stack.size(); + assert( level >= 2 ); + int256 left = compute_fixed_stack[level-2]; + int256 right = compute_fixed_stack[level-1]; + subtract_int256_from_int256(left, right); + compute_fixed_stack[level-2] = left; + compute_fixed_stack.pop_back(); + return retval; + } + +static int +compute_fixed_multiply() + { + int retval = 0; + + size_t level = compute_fixed_stack.size(); + assert( level >= 2 ); + int256 left = compute_fixed_stack[level-2]; + int256 right = compute_fixed_stack[level-1]; + + retval |= squeeze_int256(left); + retval |= squeeze_int256(right); + retval |= multiply_int256_by_int256(left, right); + + compute_fixed_stack[level-2] = left; + compute_fixed_stack.pop_back(); + return retval; + } + +static int +compute_fixed_divide() + { + int retval = 0; + + size_t level = compute_fixed_stack.size(); + assert( level >= 2 ); + int256 left = compute_fixed_stack[level-2]; + int256 right = compute_fixed_stack[level-1]; + + retval |= squeeze_int256(left); + retval |= squeeze_int256(right); + retval |= divide_int256_by_int256(left, right); + + compute_fixed_stack[level-2] = left; + compute_fixed_stack.pop_back(); + return retval; + } + +static int +compute_fixed_negate() + { + int retval = 0; + + assert( !compute_fixed_stack.empty() ); + int256 &left = compute_fixed_stack.back(); + + left.i64[0] = ~left.i64[0]; + left.i64[1] = ~left.i64[1]; + left.i64[2] = ~left.i64[2]; + left.i64[3] = ~left.i64[3]; + // I usually eschew code like this. But it's just too precious. + if(++left.i64[0] == 0) + if(++left.i64[1] == 0) + if(++left.i64[2] == 0) + ++left.i64[3]; + + return retval; + } + +static int +compute_float_add() + { + // This is RPN at work, so stack[N-2] += stack[N-1] + int retval = 0; + + size_t level = compute_float_stack.size(); + assert( level >= 2 ); + GCOB_FP128 left = compute_float_stack[level-2]; + GCOB_FP128 right = compute_float_stack[level-1]; + + left = addition_helper_float(left, right, &retval);; + + compute_float_stack[level-2] = left; + compute_float_stack.pop_back(); + return retval; + } + +static int +compute_float_subtract() + { + int retval = 0; + + size_t level = compute_float_stack.size(); + assert( level >= 2 ); + GCOB_FP128 left = compute_float_stack[level-2]; + GCOB_FP128 right = compute_float_stack[level-1]; + + left = subtraction_helper_float(left, right, &retval);; + + compute_float_stack[level-2] = left; + compute_float_stack.pop_back(); + return retval; + } + +static int +compute_float_multiply() + { + int retval = 0; + + size_t level = compute_float_stack.size(); + assert( level >= 2 ); + GCOB_FP128 left = compute_float_stack[level-2]; + GCOB_FP128 right = compute_float_stack[level-1]; + + left = multiply_helper_float(left, right, &retval); + + compute_float_stack[level-2] = left; + compute_float_stack.pop_back(); + return retval; + } + +static int +compute_float_divide() + { + int retval = 0; + + size_t level = compute_float_stack.size(); + assert( level >= 2 ); + GCOB_FP128 left = compute_float_stack[level-2]; + GCOB_FP128 right = compute_float_stack[level-1]; + + left = divide_helper_float(left, right, &retval); + + compute_float_stack[level-2] = left; + compute_float_stack.pop_back(); + return retval; + } + +static int +compute_float_pow() + { + int retval = 0; + + size_t level = compute_float_stack.size(); + assert( level >= 2 ); + GCOB_FP128 left = compute_float_stack[level-2]; + GCOB_FP128 right = compute_float_stack[level-1]; + + left = exponentiation_helper(left, right, &retval); + + compute_float_stack[level-2] = left; + compute_float_stack.pop_back(); + return retval; + } + +static int +compute_float_negate() + { + int retval = 0; + assert( !compute_float_stack.empty() ); + compute_float_stack.back() = -compute_float_stack.back(); + return retval; + } + +extern "C" +int +__gg__compute_fixed(const char opstring[], + const cblc_field_t *fields[], + const size_t offsets[]) + { + int retval = 0; + size_t noperations = strlen(opstring); + + // We will compute in fixed-point + compute_fixed_stack.clear(); + + for(size_t i=0; i<noperations; i++) + { + char ch = opstring[i]; + switch(ch) + { + case 'P': + { + // We push a value onto the stack: + int256 value; + get_int256_from_qualified_field(value, + fields[i], + offsets[i], + fields[i]->capacity); + compute_fixed_stack.push_back(value); + } + break; + + case '+': + retval |= compute_fixed_add(); + break; + + case '-': + retval |= compute_fixed_subtract(); + break; + + case '*': + retval |= compute_fixed_multiply(); + break; + + case '/': + retval |= compute_fixed_divide(); + break; + + case '!': + retval |= compute_fixed_negate(); + break; + + case '^': + fprintf(stderr, "We shouldn't see an integer a^b compute\n"); + abort(); + break; + } + } + + // The destination was added to the end of the lists + cblc_field_t *target = const_cast<cblc_field_t *>(fields[noperations]); + size_t target_offset = offsets[noperations]; + + assert(compute_fixed_stack.size() == 1); + int256 v256 = compute_fixed_stack.back(); + int overflow = squeeze_int256(v256); + if( overflow ) + { + retval |= compute_error_overflow; + } + + __int128 value; + value = v256.i64[1]; + value <<= 64; + value += v256.i64[0]; + + __gg__int128_to_qualified_field(target, + target_offset, + target->capacity, + value, + v256.rdigits, + truncation_e, + &retval); + return retval; + } + +extern "C" +int +__gg__compute_float(const char opstring[], + const cblc_field_t *fields[], + const size_t offsets[]) + { + int retval = 0; + size_t noperations = strlen(opstring); + + // We will compute in fixed-point + compute_float_stack.clear(); + + for(size_t i=0; i<noperations; i++) + { + char ch = opstring[i]; + switch(ch) + { + case 'P': + { + // We push a value onto the stack: + GCOB_FP128 value = + __gg__float128_from_qualified_field(fields[i], + offsets[i], + fields[i]->capacity); + compute_float_stack.push_back(value); + } + break; + + case '+': + retval |= compute_float_add(); + break; + + case '-': + retval |= compute_float_subtract(); + break; + + case '*': + retval |= compute_float_multiply(); + break; + + case '/': + retval |= compute_float_divide(); + break; + + case '^': + retval |= compute_float_pow(); + break; + + case '!': + retval |= compute_float_negate(); + break; + + } + } + + // The destination was added to the end of the lists + cblc_field_t *target = const_cast<cblc_field_t *>(fields[noperations]); + size_t target_offset = offsets[noperations]; + + assert(compute_float_stack.size() == 1); + GCOB_FP128 value = compute_float_stack.back(); + + __gg__float128_to_qualified_field(target, + target_offset, + value, + truncation_e, + &retval); + return retval; + } diff --git a/libgcobol/libgcobol.cc b/libgcobol/libgcobol.cc index 70f4fdfa6199..a5c9b4b4ad16 100644 --- a/libgcobol/libgcobol.cc +++ b/libgcobol/libgcobol.cc @@ -14137,3 +14137,56 @@ __gg__set_exception_call(const cblc_field_t *field, field->capacity, &nbytes); } + +extern "C" +int +__gg__prohibited(const cblc_field_t *field, __int128 value) + { + // This is the test for ROUNDING MODE PROHIBITED. Returns non-zero when + // value can't fit into field. + int retval; + if(value < 0) + { + value = -value; + } + char ach[128]; + int index = 0; + // Convert value to a stream of "digits", low-order first. + while(value) + { + ach[index++] = value % 10; + value /= 10; + } + if( index <= field->digits ) + { + // We peeled off index digits, and value can hold that many. + retval = 0; + } + else + { + // we know that index is greater than field->digits + + // Count the number of low-order zeroes in ach[]. + int trailing_zeroes = 0; + for(int i=0; i<index; i++) + { + if( ach[i] ) + { + break; + } + trailing_zeroes += 1; + } + // Subtracting trailing zeroes from index gives us the number of non-zero + // digits in ach: + index -= trailing_zeroes; + if( index <= field->digits ) + { + retval = 0; + } + else + { + retval = 1; + } + } + return retval; + } diff --git a/libgcobol/libgcobol.h b/libgcobol/libgcobol.h index 92e8c497c630..a4456bc4cf9e 100644 --- a/libgcobol/libgcobol.h +++ b/libgcobol/libgcobol.h @@ -109,7 +109,7 @@ typedef struct int128 { __int128 i128; int rdigits; - }int128; + } int128; extern "C" void __gg__clock_gettime(struct cbl_timespec *tp);