diff options
164 files changed, 3553 insertions, 39 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 33d10ef..f7ffd4d 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,35 @@ +2025-05-11 Jan Hubicka <hubicka@ucw.cz> + + * config/i386/i386.cc (ix86_widen_mult_cost): Use sse_op to cost + SSE integer addition. + (ix86_multiplication_cost): Use COSTS_N_INSNS (...)/2 to cost sse + loads. + (ix86_shift_rotate_cost): Likewise. + (ix86_vector_costs::add_stmt_cost): Likewise. + +2025-05-11 Takayuki 'January June' Suwa <jjsuwa_sys3175@yahoo.co.jp> + + * config/xtensa/xtensa.cc (xtensa_register_move_cost): + Add appropriate move costs between AR_REGS and FP_REGS. + +2025-05-11 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120211 + * tree-vect-stmts.cc (vect_stmt_relevant_p): Only add PHIs + from the loop header to LOOP_VINFO_EARLY_BREAKS_LIVE_IVS. + +2025-05-11 Jiawei <jiawei@iscas.ac.cn> + + * common/config/riscv/riscv-common.cc: New profile. + +2025-05-11 Jiawei <jiawei@iscas.ac.cn> + + * common/config/riscv/riscv-common.cc (struct riscv_profiles): New struct. + (riscv_subset_list::parse_profiles): New parser. + (riscv_subset_list::parse_base_ext): Ditto. + * config/riscv/riscv-subset.h: New def. + * doc/invoke.texi: New option descriptions. + 2025-05-10 H.J. Lu <hjl.tools@gmail.com> PR target/92080 diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index b11e7ca..823f45b 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20250511 +20250512 diff --git a/gcc/config/i386/i386-features.cc b/gcc/config/i386/i386-features.cc index 13e6c2a..cc8313b 100644 --- a/gcc/config/i386/i386-features.cc +++ b/gcc/config/i386/i386-features.cc @@ -3095,13 +3095,10 @@ ix86_place_single_vector_set (rtx dest, rtx src, bitmap bbs) insn = NEXT_INSN (insn); } - rtx_insn *set_insn; if (insn == BB_HEAD (bb)) - set_insn = emit_insn_before (set, insn); + emit_insn_before (set, insn); else - set_insn = emit_insn_after (set, - insn ? PREV_INSN (insn) : BB_END (bb)); - df_insn_rescan (set_insn); + emit_insn_after (set, insn ? PREV_INSN (insn) : BB_END (bb)); } /* At entry of the nearest common dominator for basic blocks with @@ -3225,7 +3222,6 @@ remove_partial_avx_dependency (void) /* Generate an XMM vector SET. */ set = gen_rtx_SET (vec, src); set_insn = emit_insn_before (set, insn); - df_insn_rescan (set_insn); if (cfun->can_throw_non_call_exceptions) { @@ -3396,8 +3392,7 @@ replace_vector_const (machine_mode vector_mode, rtx vector_const, vreg = gen_reg_rtx (vmode); rtx vsubreg = gen_rtx_SUBREG (vmode, vector_const, 0); rtx pat = gen_rtx_SET (vreg, vsubreg); - rtx_insn *vinsn = emit_insn_before (pat, insn); - df_insn_rescan (vinsn); + emit_insn_before (pat, insn); } replace = gen_rtx_SUBREG (mode, vreg, 0); } diff --git a/gcc/config/i386/i386.cc b/gcc/config/i386/i386.cc index 9c24a92..3d629b0 100644 --- a/gcc/config/i386/i386.cc +++ b/gcc/config/i386/i386.cc @@ -21753,7 +21753,7 @@ ix86_widen_mult_cost (const struct processor_costs *cost, /* pmuludq under sse2, pmuldq under sse4.1, for sign_extend, require extra 4 mul, 4 add, 4 cmp and 2 shift. */ if (!TARGET_SSE4_1 && !uns_p) - extra_cost = (cost->mulss + cost->addss + cost->sse_op) * 4 + extra_cost = (cost->mulss + cost->sse_op + cost->sse_op) * 4 + cost->sse_op * 2; /* Fallthru. */ case V4DImode: @@ -21803,11 +21803,11 @@ ix86_multiplication_cost (const struct processor_costs *cost, else if (TARGET_AVX2) nops += 2; else if (TARGET_XOP) - extra += cost->sse_load[2]; + extra += COSTS_N_INSNS (cost->sse_load[2]) / 2; else { nops += 1; - extra += cost->sse_load[2]; + extra += COSTS_N_INSNS (cost->sse_load[2]) / 2; } goto do_qimode; @@ -21826,13 +21826,13 @@ ix86_multiplication_cost (const struct processor_costs *cost, { nmults += 1; nops += 2; - extra += cost->sse_load[2]; + extra += COSTS_N_INSNS (cost->sse_load[2]) / 2; } else { nmults += 1; nops += 4; - extra += cost->sse_load[2]; + extra += COSTS_N_INSNS (cost->sse_load[2]) / 2; } goto do_qimode; @@ -21845,14 +21845,16 @@ ix86_multiplication_cost (const struct processor_costs *cost, { nmults += 1; nops += 4; - extra += cost->sse_load[3] * 2; + /* 2 loads, so no division by 2. */ + extra += COSTS_N_INSNS (cost->sse_load[3]); } goto do_qimode; case V64QImode: nmults = 2; nops = 9; - extra = cost->sse_load[3] * 2 + cost->sse_load[4] * 2; + /* 2 loads of each size, so no division by 2. */ + extra = COSTS_N_INSNS (cost->sse_load[3] + cost->sse_load[4]); do_qimode: return ix86_vec_cost (mode, cost->mulss * nmults @@ -21945,7 +21947,7 @@ ix86_shift_rotate_cost (const struct processor_costs *cost, /* Use vpbroadcast. */ extra = cost->sse_op; else - extra = cost->sse_load[2]; + extra = COSTS_N_INSNS (cost->sse_load[2]) / 2; if (constant_op1) { @@ -21976,7 +21978,7 @@ ix86_shift_rotate_cost (const struct processor_costs *cost, shift with one insn set the cost to prefer paddb. */ if (constant_op1) { - extra = cost->sse_load[2]; + extra = COSTS_N_INSNS (cost->sse_load[2]) / 2; return ix86_vec_cost (mode, cost->sse_op) + extra; } else @@ -21991,7 +21993,9 @@ ix86_shift_rotate_cost (const struct processor_costs *cost, /* Use vpbroadcast. */ extra = cost->sse_op; else - extra = (mode == V16QImode) ? cost->sse_load[2] : cost->sse_load[3]; + extra = COSTS_N_INSNS (mode == V16QImode + ? cost->sse_load[2] + : cost->sse_load[3]) / 2; if (constant_op1) { @@ -26060,7 +26064,7 @@ ix86_vector_costs::add_stmt_cost (int count, vect_cost_for_stmt kind, else { m_num_gpr_needed[where]++; - stmt_cost += ix86_cost->sse_to_integer; + stmt_cost += COSTS_N_INSNS (ix86_cost->integer_to_sse) / 2; } } } diff --git a/gcc/config/xtensa/xtensa.cc b/gcc/config/xtensa/xtensa.cc index 53db06e..621fb0a 100644 --- a/gcc/config/xtensa/xtensa.cc +++ b/gcc/config/xtensa/xtensa.cc @@ -4430,17 +4430,27 @@ static int xtensa_register_move_cost (machine_mode mode ATTRIBUTE_UNUSED, reg_class_t from, reg_class_t to) { - if (from == to && from != BR_REGS && to != BR_REGS) + /* If both are equal (except for BR_REGS) or belong to AR_REGS, + the cost is 2 (the default value). */ + if ((from == to && from != BR_REGS && to != BR_REGS) + || (reg_class_subset_p (from, AR_REGS) + && reg_class_subset_p (to, AR_REGS))) return 2; - else if (reg_class_subset_p (from, AR_REGS) - && reg_class_subset_p (to, AR_REGS)) - return 2; - else if (reg_class_subset_p (from, AR_REGS) && to == ACC_REG) - return 3; - else if (from == ACC_REG && reg_class_subset_p (to, AR_REGS)) + + /* The cost between AR_REGS and FR_REGS must be <= 8 (2x the default + MEMORY_MOVE_COST) to avoid unwanted spills, and > 4 (2x the above + case) to avoid excessive register-to-register moves. */ + if ((reg_class_subset_p (from, AR_REGS) && to == FP_REGS) + || (from == FP_REGS && reg_class_subset_p (to, AR_REGS))) + return 5; + + if ((reg_class_subset_p (from, AR_REGS) && to == ACC_REG) + || (from == ACC_REG && reg_class_subset_p (to, AR_REGS))) return 3; - else - return 10; + + /* Otherwise, spills to stack (because greater than 2x the default + MEMORY_MOVE_COST). */ + return 10; } /* Compute a (partial) cost for rtx X. Return true if the complete diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b3f63e0..aa6d6cb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2025-05-11 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120163 + * gfortran.h: Add formal_resolved to gfc_symbol. + * resolve.cc (gfc_resolve_formal_arglist): Set it. + (resolve_function): Do not call gfc_get_formal_from_actual_arglist + if we already resolved a formal arglist. + (resolve_call): Likewise. + 2025-05-10 Harald Anlauf <anlauf@gmx.de> PR fortran/102891 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 46310a0..4740c36 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2028,6 +2028,9 @@ typedef struct gfc_symbol This is legal in Fortran, but can cause problems with autogenerated C prototypes for C23. */ unsigned ext_dummy_arglist_mismatch:1; + /* Set if the formal arglist has already been resolved, to avoid + trying to generate it again from actual arguments. */ + unsigned formal_resolved:1; /* Reference counter, used for memory management. diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 1e62e94..bf1aa70 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -533,7 +533,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc) } } } - + if (sym) + sym->formal_resolved = 1; gfc_current_ns = orig_current_ns; } @@ -3472,7 +3473,7 @@ resolve_function (gfc_expr *expr) &expr->where, &sym->formal_at); } } - else + else if (!sym->formal_resolved) { gfc_get_formal_from_actual_arglist (sym, expr->value.function.actual); sym->formal_at = expr->where; @@ -4033,7 +4034,7 @@ resolve_call (gfc_code *c) &c->loc, &csym->formal_at); } } - else + else if (!csym->formal_resolved) { gfc_get_formal_from_actual_arglist (csym, c->ext.actual); csym->formal_at = c->loc; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5a6b911..b9e39f2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,189 @@ +2025-05-11 Jan Hubicka <hubicka@ucw.cz> + + * gcc.target/i386/pr91446.c: xfail. + * gcc.target/i386/pr99881.c: remove xfail. + +2025-05-11 Max Filippov <jcmvbkbc@gmail.com> + + * lib/target-supports.exp + (check_effective_target_xtensa_atomic): New function. + (check_effective_target_sync_int_long) + (check_effective_target_sync_char_short): Add test for xtensa. + +2025-05-11 Robert Dubner <rdubner@symas.com> + + * cobol.dg/group2/258_Nested_PERFORM.cob: New testcase. + * cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.cob: Likewise. + * cobol.dg/group2/338_Default_Arithmetic__1_.cob: Likewise. + * cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob: Likewise. + * cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.cob: Likewise. + * cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__1_.cob: Likewise. + * cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__2_.cob: Likewise. + * cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob: Likewise. + * cobol.dg/group2/Alphanumeric_and_binary_numeric.cob: Likewise. + * cobol.dg/group2/Alphanumeric_MOVE_with_truncation.cob: Likewise. + * cobol.dg/group2/ANY_LENGTH__1_.cob: Likewise. + * cobol.dg/group2/ANY_LENGTH__2_.cob: Likewise. + * cobol.dg/group2/ANY_LENGTH__3_.cob: Likewise. + * cobol.dg/group2/ANY_LENGTH__4_.cob: Likewise. + * cobol.dg/group2/ANY_LENGTH__5_.cob: Likewise. + * cobol.dg/group2/CALL_with_OMITTED_parameter.cob: Likewise. + * cobol.dg/group2/Class_check_with_reference_modification.cob: Likewise. + * cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.cob: Likewise. + * cobol.dg/group2/Complex_IF.cob: Likewise. + * cobol.dg/group2/Concatenation_operator.cob: Likewise. + * cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.cob: Likewise. + * cobol.dg/group2/CURRENCY_SIGN.cob: Likewise. + * cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.cob: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.cob: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.cob: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.cob: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.cob: Likewise. + * cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.cob: Likewise. + * cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.cob: Likewise. + * cobol.dg/group2/EXIT_PARAGRAPH.cob: Likewise. + * cobol.dg/group2/EXIT_PERFORM.cob: Likewise. + * cobol.dg/group2/EXIT_PERFORM_CYCLE.cob: Likewise. + * cobol.dg/group2/EXIT_SECTION.cob: Likewise. + * cobol.dg/group2/Fixed_continuation_indicator.cob: Likewise. + * cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.cob: Likewise. + * cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.cob: Likewise. + * cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.cob: Likewise. + * cobol.dg/group2/Index_and_parenthesized_expression.cob: Likewise. + * cobol.dg/group2/LENGTH_OF_omnibus.cob: Likewise. + * cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.cob: Likewise. + * cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.cob: Likewise. + * cobol.dg/group2/MOVE_indexes.cob: Likewise. + * cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.cob: Likewise. + * cobol.dg/group2/MOVE_to_edited_item__1_.cob: Likewise. + * cobol.dg/group2/MOVE_to_edited_item__2_.cob: Likewise. + * cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.cob: Likewise. + * cobol.dg/group2/MOVE_to_itself.cob: Likewise. + * cobol.dg/group2/MOVE_to_JUSTIFIED_item.cob: Likewise. + * cobol.dg/group2/MOVE_with_group_refmod.cob: Likewise. + * cobol.dg/group2/MOVE_with_refmod.cob: Likewise. + * cobol.dg/group2/MOVE_with_refmod__variable_.cob: Likewise. + * cobol.dg/group2/MOVE_Z_literal_.cob: Likewise. + * cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob: Likewise. + * cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.cob: Likewise. + * cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob: Likewise. + * cobol.dg/group2/Non-overflow_after_overflow.cob: Likewise. + * cobol.dg/group2/OCCURS_clause_with_1_entry.cob: Likewise. + * cobol.dg/group2/OSVS_Arithmetic_Test__2_.cob: Likewise. + * cobol.dg/group2/PERFORM_..._CONTINUE.cob: Likewise. + * cobol.dg/group2/PERFORM_inline__1_.cob: Likewise. + * cobol.dg/group2/PERFORM_inline__2_.cob: Likewise. + * cobol.dg/group2/PERFORM_type_OSVS.cob: Likewise. + * cobol.dg/group2/PIC_ZZZ-__ZZZ_.cob: Likewise. + * cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.cob: Likewise. + * cobol.dg/group2/Quote_marks_in_comment_paragraphs.cob: Likewise. + * cobol.dg/group2/Recursive_PERFORM_paragraph.cob: Likewise. + * cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.cob: Likewise. + * cobol.dg/group2/SORT__EBCDIC_table_sort__1_.cob: Likewise. + * cobol.dg/group2/SORT__EBCDIC_table_sort__2_.cob: Likewise. + * cobol.dg/group2/SORT__table_sort__2_.cob: Likewise. + * cobol.dg/group2/SORT__table_sort__3A_.cob: Likewise. + * cobol.dg/group2/SORT__table_sort__3B_.cob: Likewise. + * cobol.dg/group2/SORT__table_sort.cob: Likewise. + * cobol.dg/group2/SOURCE_FIXED_FREE_directives.cob: Likewise. + * cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.cob: Likewise. + * cobol.dg/group2/_-static__compilation.cob: Likewise. + * cobol.dg/group2/STOP_RUN_WITH_ERROR_STATUS.cob: Likewise. + * cobol.dg/group2/STOP_RUN_WITH_NORMAL_STATUS.cob: Likewise. + * cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.cob: Likewise. + * cobol.dg/group2/STRING_with_subscript_reference.cob: Likewise. + * cobol.dg/group2/UNSTRING_DELIMITED_ALL_LOW-VALUE.cob: Likewise. + * cobol.dg/group2/UNSTRING_DELIMITED_ALL_SPACE-2.cob: Likewise. + * cobol.dg/group2/UNSTRING_DELIMITED_POINTER.cob: Likewise. + * cobol.dg/group2/UNSTRING_DELIMITER_IN.cob: Likewise. + * cobol.dg/group2/UNSTRING_with_FUNCTION___literal.cob: Likewise. + * cobol.dg/group2/258_Nested_PERFORM.out: Known-good results file. + * cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.out: Likewise. + * cobol.dg/group2/338_Default_Arithmetic__1_.out: Likewise. + * cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out: Likewise. + * cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.out: Likewise. + * cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out: Likewise. + * cobol.dg/group2/Alphanumeric_MOVE_with_truncation.out: Likewise. + * cobol.dg/group2/ANY_LENGTH__1_.out: Likewise. + * cobol.dg/group2/ANY_LENGTH__2_.out: Likewise. + * cobol.dg/group2/ANY_LENGTH__3_.out: Likewise. + * cobol.dg/group2/ANY_LENGTH__5_.out: Likewise. + * cobol.dg/group2/CALL_with_OMITTED_parameter.out: Likewise. + * cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.out: Likewise. + * cobol.dg/group2/Complex_IF.out: Likewise. + * cobol.dg/group2/Concatenation_operator.out: Likewise. + * cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.out: Likewise. + * cobol.dg/group2/CURRENCY_SIGN.out: Likewise. + * cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.out: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.out: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.out: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.out: Likewise. + * cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.out: Likewise. + * cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out: Likewise. + * cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out: Likewise. + * cobol.dg/group2/EXIT_PERFORM_CYCLE.out: Likewise. + * cobol.dg/group2/EXIT_PERFORM.out: Likewise. + * cobol.dg/group2/Fixed_continuation_indicator.out: Likewise. + * cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.out: Likewise. + * cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out: Likewise. + * cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.out: Likewise. + * cobol.dg/group2/Index_and_parenthesized_expression.out: Likewise. + * cobol.dg/group2/LENGTH_OF_omnibus.out: Likewise. + * cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out: Likewise. + * cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out: Likewise. + * cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.out: Likewise. + * cobol.dg/group2/MOVE_to_edited_item__1_.out: Likewise. + * cobol.dg/group2/MOVE_to_edited_item__2_.out: Likewise. + * cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.out: Likewise. + * cobol.dg/group2/MOVE_to_JUSTIFIED_item.out: Likewise. + * cobol.dg/group2/MOVE_Z_literal_.out: Likewise. + * cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.out: Likewise. + * cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.out: Likewise. + * cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out: Likewise. + * cobol.dg/group2/OSVS_Arithmetic_Test__2_.out: Likewise. + * cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.out: Likewise. + * cobol.dg/group2/Quote_marks_in_comment_paragraphs.out: Likewise. + * cobol.dg/group2/Recursive_PERFORM_paragraph.out: Likewise. + * cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out: Likewise. + * cobol.dg/group2/SORT__table_sort__2_.out: Likewise. + * cobol.dg/group2/SORT__table_sort__3A_.out: Likewise. + * cobol.dg/group2/SORT__table_sort__3B_.out: Likewise. + * cobol.dg/group2/SOURCE_FIXED_FREE_directives.out: Likewise. + * cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out: Likewise. + * cobol.dg/group2/_-static__compilation.out: Likewise. + * cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out: Likewise. + * cobol.dg/group2/UNSTRING_with_FUNCTION___literal.out: Likewise. + +2025-05-11 Richard Biener <rguenther@suse.de> + + PR tree-optimization/120211 + * gcc.dg/vect/vect-early-break_135-pr120211.c: New testcase. + * gcc.dg/torture/pr120211-1.c: Likewise. + +2025-05-11 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/120163 + * gfortran.dg/interface_61.f90: New test. + +2025-05-11 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-53.c: New test. + * gcc.target/riscv/arch-54.c: New test. + +2025-05-11 Jiawei <jiawei@iscas.ac.cn> + + * gcc.target/riscv/arch-49.c: New test. + * gcc.target/riscv/arch-50.c: New test. + * gcc.target/riscv/arch-51.c: New test. + * gcc.target/riscv/arch-52.c: New test. + +2025-05-11 Andrew Pinski <quic_apinski@quicinc.com> + + PR testsuite/119909 + * gcc.dg/torture/pr119131-1.c: Add -Wno-psabi. + 2025-05-10 Robert Dubner <rdubner@symas.com> * cobol.dg/group1/simple-if.cob: Make explicitly >>SOURCE FREE diff --git a/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.cob b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.cob new file mode 100644 index 0000000..383cd0a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/258_Nested_PERFORM.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + DISPLAY "X" NO ADVANCING + END-DISPLAY + PERFORM 2 TIMES + DISPLAY "Y" NO ADVANCING + END-DISPLAY + END-PERFORM + END-PERFORM. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.out b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.out new file mode 100644 index 0000000..3c3d159 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/258_Nested_PERFORM.out @@ -0,0 +1 @@ +XYYXYY diff --git a/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.cob b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.cob new file mode 100644 index 0000000..295caf5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/259_PERFORM_VARYING_BY_-0.2.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 X PIC 9v9. + PROCEDURE DIVISION. + PERFORM VARYING X FROM 0.8 BY -0.2 + UNTIL X < 0.4 + DISPLAY "X" NO ADVANCING + END-DISPLAY + END-PERFORM. + IF X NOT = 0.2 + DISPLAY "WRONG X: " X END-DISPLAY + END-IF + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.out b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.out new file mode 100644 index 0000000..dd6d86a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/259_PERFORM_VARYING_BY_-0.2.out @@ -0,0 +1 @@ +XXX diff --git a/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.cob b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.cob new file mode 100644 index 0000000..5405dba --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.cob @@ -0,0 +1,75 @@ + *> { dg-do run } + *> { dg-output-file "group2/338_Default_Arithmetic__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 NUM-A PIC 9(3) VALUE 399. + 01 NUM-B PIC 9(3) VALUE 211. + 01 NUM-C PIC 9(3)V99 VALUE 212.34. + 01 NUMV1 PIC 9(3)V9. + 01 PICX PIC X VALUE 'A'. + 01 RSLT PIC 9(3). + 01 RSLTV1 PIC 9(3).9. + 01 RSLTV2 PIC 9(3).99. + * + PROCEDURE DIVISION. + MAIN. + COMPUTE RSLT = NUM-A + 1.1. + DISPLAY 'Simple Compute RSLT IS ' RSLT + COMPUTE RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Single Variable RSLT IS ' RSLT + COMPUTE RSLTV2, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Compute RSLT IS ' RSLT + DISPLAY 'Compute RSLTv99 IS ' RSLTV2 + COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Compute RSLT IS ' RSLT + DISPLAY 'Compute RSLTv9 IS ' RSLTV1 + MOVE 0 TO RSLT + ADD NUM-C TO RSLT. + DISPLAY 'Add RSLT IS ' RSLT. + MOVE 0 TO RSLT + ADD NUM-A NUM-C 10 TO RSLT. + DISPLAY 'Add RSLT IS ' RSLT. + SUBTRACT NUM-C FROM RSLT. + DISPLAY 'Subtract RSLT IS ' RSLT. + SUBTRACT NUM-A -10 FROM RSLT. + DISPLAY 'Subtract RSLT IS ' RSLT. + MOVE 0 TO RSLT + ADD NUM-A NUM-C TO RSLT GIVING RSLTV1. + DISPLAY 'Add RSLTv9 IS ' RSLTV1 + MULTIPLY NUM-A BY NUM-C GIVING RSLT. + DISPLAY 'Multiply RSLT IS ' RSLT. + MULTIPLY RSLT BY NUM-C. + DISPLAY 'Multiply RSLT IS ' RSLT. + DIVIDE NUM-A BY 10 GIVING RSLT. + DISPLAY 'Divide RSLT IS ' RSLT. + DIVIDE RSLT BY 4 GIVING RSLTV1. + DISPLAY 'Divide RSLTv9 IS ' RSLTV1. + DIVIDE RSLT BY 4 GIVING RSLT. + DISPLAY 'Divide RSLT IS ' RSLT. + + COMPUTE RSLTV1, RSLT = ((NUM-A / 100) - (NUM-B / 100)) * 100 + DISPLAY 'Simple RSLT IS ' RSLT + ' RSLTv9 IS ' RSLTV1. + + COMPUTE RSLTV1, RSLT = ((NUM-A / (100.55 + -0.550)) + - (NUM-B / (10.11 * 10 - 1.1))) + * (220 / 2.2) + DISPLAY 'Complex RSLT IS ' RSLT + ' RSLTv9 IS ' RSLTV1. + + COMPUTE RSLTV1, RSLT = ((NUM-A / (101 - 1)) + - (NUM-B / (10 * 10))) * (200 / 2) + DISPLAY 'Reduced RSLT IS ' RSLT + ' RSLTv9 IS ' RSLTV1. + MOVE NUM-A TO NUMV1. + IF ((NUMV1 / (101 - 1)) + - (NUM-B / (10 * 10))) * (200 / 2) EQUAL 188 + DISPLAY "Not Using ARITHMETIC-OSVS" + ELSE + DISPLAY "Using ARITHMETIC-OSVS" + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.out b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.out new file mode 100644 index 0000000..3137fc4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/338_Default_Arithmetic__1_.out @@ -0,0 +1,21 @@ +Simple Compute RSLT IS 400 +Single Variable RSLT IS 188 +Compute RSLT IS 188 +Compute RSLTv99 IS 188.00 +Compute RSLT IS 188 +Compute RSLTv9 IS 188.0 +Add RSLT IS 212 +Add RSLT IS 621 +Subtract RSLT IS 408 +Subtract RSLT IS 019 +Add RSLTv9 IS 611.3 +Multiply RSLT IS 723 +Multiply RSLT IS 723 +Divide RSLT IS 039 +Divide RSLTv9 IS 009.7 +Divide RSLT IS 009 +Simple RSLT IS 188 RSLTv9 IS 188.0 +Complex RSLT IS 188 RSLTv9 IS 188.0 +Reduced RSLT IS 188 RSLTv9 IS 188.0 +Not Using ARITHMETIC-OSVS + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob new file mode 100644 index 0000000..6fab992 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.cob @@ -0,0 +1,113 @@ + *> { dg-do run } + *> { dg-output-file "group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out" } + + identification division. + program-id. prog. + procedure division. + display "initialize zeroes" + call "prog-zeroes" + display "initialize low-value" + call "prog-low" + display "initialize spaces" + call "prog-space" + display "initialize high-value" + call "prog-high" + continue. + end program prog. + + identification division. + program-id. prog-space. + options. initialize working-storage spaces. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + call "reporter" using based-var + free allocated-pointer + goback. + end program prog-space. + + identification division. + program-id. prog-low. + options. initialize working-storage low-values. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + call "reporter" using based-var + free allocated-pointer + goback. + end program prog-low. + + identification division. + program-id. prog-zeroes. + options. initialize working-storage binary zeroes. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + call "reporter" using based-var + free allocated-pointer + goback. + end program prog-zeroes. + + identification division. + program-id. prog-high. + options. initialize working-storage high-values. + data division. + working-storage section. + 01 based-var based. + 02 based-x pic x(24) value "I am I, Don Quixote". + 02 based-9 pic 999 value 123. + 02 based-p pointer value NULL. + 01 allocated-pointer pointer. + procedure division. + display "allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero)" + allocate 35 characters returning allocated-pointer + set address of based-var to allocated-pointer + call "reporter" using based-var + free allocated-pointer + goback. + end program prog-high. + + identification division. + program-id. reporter. + data division. + linkage section. + 01 based-var based. + 02 based-x pic x(24). + 02 based-9 pic 999 . + 02 based-p pointer . + procedure division using based-var. + reportt. + display " (1) as allocated" + perform reportt2 + goback. + reportt2. + display " " """" based-x """" with no advancing + display space """" based-9 """" with no advancing + display space based-p. + continue. + end program reporter. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out new file mode 100644 index 0000000..c141fdf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE_Rule_8_OPTION_INITIALIZE_with_figconst.out @@ -0,0 +1,17 @@ +initialize zeroes +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) + (1) as allocated + "" "" 0x0000000000000000 +initialize low-value +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) + (1) as allocated + "" "" 0x0000000000000000 +initialize spaces +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) + (1) as allocated + " " " " 0x2020202020202020 +initialize high-value +allocate characters (ISO 2023 Rule 8: OPT_INIT if specified, otherwise defaultbyte, otherwise zero) + (1) as allocated + "ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ" "¿¿¿" 0xffffffffffffffff + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.cob new file mode 100644 index 0000000..abcba96 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.cob @@ -0,0 +1,73 @@ + *> { dg-do run } + *> { dg-output-file "group2/ALLOCATE___FREE_basic_default_versions.out" } + + program-id. prog. + data division. + working-storage section. + 01 based-var pic x(100) based. + 01 mem-pointer pointer. + 01 mem-size pic 999 value 100. + 01 counter pic 99 value zero. + procedure division. + allocate 100 characters returning mem-pointer. + if mem-pointer equal NULL + display "allocate 100 should not be NULL (1)" + else + add 1 to counter. + free mem-pointer + if mem-pointer not equal NULL + display "mem-pointer should be NULL again (1)" + else + add 1 to counter. + + allocate mem-size characters returning mem-pointer. + if mem-pointer equal null + display "allocate mem-size should not be NULL (2)" + else + add 1 to counter. + free mem-pointer + if mem-pointer not equal null + display "mem-pointer should be NULL again (2)" + else + add 1 to counter. + + allocate based-var + if address of based-var equal NULL + display "address of based-var should not be NULL (1)" + else + add 1 to counter + free based-var + if address of based-var not equal NULL + display "address of based-var be NULL (1)" + else + add 1 to counter. + + allocate based-var + if address of based-var equal NULL + display "address of based-var should not be NULL (2)" + else + add 1 to counter. + free address of based-var + if address of based-var not equal NULL + display "address of based-var be NULL (2)" + else + add 1 to counter. + + allocate based-var returning mem-pointer. + if address of based-var equal NULL + display "address of based-var should not be NULL (3)" + else + add 1 to counter. + if mem-pointer equal NULL + display "address of mem-pointer should not be NULL (3)" + else + add 1 to counter. + if address of based-var not equal mem-pointer + display "address of mem-pointer should be equal to mem-pointer (3)" + else + add 1 to counter. + + display "There were " counter " successful tests; should be 11." + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.out b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.out new file mode 100644 index 0000000..ab96696b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_basic_default_versions.out @@ -0,0 +1,2 @@ +There were 11 successful tests; should be 11. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__1_.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__1_.cob new file mode 100644 index 0000000..b4929b8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__1_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + LINKAGE SECTION. + 01 MYFLD PIC X(6) BASED VALUE "ABCDEF". + PROCEDURE DIVISION. + ASTART SECTION. + A01. + ALLOCATE MYFLD INITIALIZED. + IF MYFLD NOT = "ABCDEF" + DISPLAY MYFLD + END-DISPLAY + END-IF. + FREE ADDRESS OF MYFLD. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__2_.cob b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__2_.cob new file mode 100644 index 0000000..9820784 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ALLOCATE___FREE_with_BASED_item__2_.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 MYFLD BASED. + 03 MYFLDX PIC X. + 03 MYFLD9 PIC 9. + PROCEDURE DIVISION. + IF ADDRESS OF MYFLD NOT = NULL + DISPLAY "BASED ITEM WITH ADDRESS ON START" + END-DISPLAY + END-IF. + FREE MYFLD. + ALLOCATE MYFLD. + IF ADDRESS OF MYFLD = NULL + DISPLAY "BASED ITEM WITHOUT ADDRESS AFTER ALLOCATE" + END-DISPLAY + END-IF. + INITIALIZE MYFLD. + IF MYFLD NOT = " 0" + DISPLAY "BASED ITEM INITIALIZED WRONG: " + WITH NO ADVANCING + END-DISPLAY + DISPLAY MYFLD + END-DISPLAY + END-IF. + + FREE ADDRESS OF MYFLD. + IF ADDRESS OF MYFLD NOT = NULL + DISPLAY "BASED ITEM WITH ADDRESS AFTER FREE" + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.cob new file mode 100644 index 0000000..a4dc2e5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P1 PIC X(6) VALUE "OKOKOK". + PROCEDURE DIVISION. + CALL "callee" USING P1 + END-CALL. + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P2 PIC 99. + LINKAGE SECTION. + 01 P1 PIC X ANY LENGTH. + PROCEDURE DIVISION USING P1. + MOVE FUNCTION LENGTH (P1) TO P2. + DISPLAY "The incoming ANY LENGTH is " P2 + DISPLAY "The incoming ANY LENGTH variable is " """" P1 """" + EXIT PROGRAM. + END PROGRAM callee. + END PROGRAM caller. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.out new file mode 100644 index 0000000..f35acf2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__1_.out @@ -0,0 +1,3 @@ +The incoming ANY LENGTH is 06 +The incoming ANY LENGTH variable is "OKOKOK" + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.cob new file mode 100644 index 0000000..8f152eb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P1 PIC X(2) VALUE "OK". + PROCEDURE DIVISION. + CALL "callee" USING P1 + END-CALL. + DISPLAY "On return, P1 is " """" P1 """" + STOP RUN. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P2 PIC XXX. + LINKAGE SECTION. + 01 P1 PIC X ANY LENGTH. + PROCEDURE DIVISION USING P1. + MOVE P1 TO P2. + DISPLAY "P1 is " """" P1 """" + DISPLAY "P2 is " """" P2 """" + IF P2 NOT = "OK " + DISPLAY P2 + END-DISPLAY + END-IF. + MOVE SPACE TO P1. + EXIT PROGRAM. + END PROGRAM callee. + END PROGRAM caller. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.out new file mode 100644 index 0000000..e2bc284 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__2_.out @@ -0,0 +1,4 @@ +P1 is "OK" +P2 is "OK " +On return, P1 is " " + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.cob new file mode 100644 index 0000000..6603559 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.cob @@ -0,0 +1,25 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__3_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(20) VALUE ALL "X". + PROCEDURE DIVISION. + CALL "subprog" USING str. + IDENTIFICATION DIVISION. + PROGRAM-ID. subprog. + DATA DIVISION. + LINKAGE SECTION. + 01 str PIC X ANY LENGTH. + PROCEDURE DIVISION USING str. + MOVE "abcd" TO str + DISPLAY FUNCTION TRIM (str) + MOVE "abcd" TO str (5:) + DISPLAY FUNCTION TRIM (str) + MOVE ALL "a" TO str + DISPLAY FUNCTION TRIM (str). + END PROGRAM subprog. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.out new file mode 100644 index 0000000..7e58e05 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__3_.out @@ -0,0 +1,4 @@ +abcd +abcdabcd +aaaaaaaaaaaaaaaaaaaa + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__4_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__4_.cob new file mode 100644 index 0000000..b4dcddc --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__4_.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 str PIC X(20) VALUE ALL "X". + + PROCEDURE DIVISION. + CALL "subprog" USING str + move ' 45' to str + CALL "subprog" USING str + . + + IDENTIFICATION DIVISION. + PROGRAM-ID. subprog. + + DATA DIVISION. + LINKAGE SECTION. + 01 str PIC X ANY LENGTH. + + PROCEDURE DIVISION USING str. + IF str = 'X' + DISPLAY 'X is X' + END-IF + IF str = space + DISPLAY 'X is space' + END-IF + . + END PROGRAM subprog. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.cob b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.cob new file mode 100644 index 0000000..fb8dfa9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + *> { dg-output-file "group2/ANY_LENGTH__5_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + CALL "subprog" + GOBACK. + IDENTIFICATION DIVISION. + PROGRAM-ID. subprog. + DATA DIVISION. + LINKAGE SECTION. + 01 str1 PIC X ANY LENGTH. + 01 str2 PIC X ANY LENGTH. + PROCEDURE DIVISION USING optional str1 optional str2. + DISPLAY 'IN' WITH NO ADVANCING. + END PROGRAM subprog. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.out b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.out new file mode 100644 index 0000000..2c9e08f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/ANY_LENGTH__5_.out @@ -0,0 +1 @@ +IN diff --git a/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.cob b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.cob new file mode 100644 index 0000000..76b1fb4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.cob @@ -0,0 +1,45 @@ + *> { dg-do run } + *> { dg-options "-Wno-truncate" } + *> { dg-output-file "group2/Alphanumeric_MOVE_with_truncation.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x-left PIC X(03). + 01 x-right PIC X(03) JUSTIFIED RIGHT. + PROCEDURE DIVISION. + MOVE '1234' TO x-left, x-right + DISPLAY """" x-left """" space """" x-right """" + IF x-left not = '123' + OR x-right not = '234' + DISPLAY 'error with "1234":' + END-DISPLAY + DISPLAY x-left + END-DISPLAY + DISPLAY x-right + END-DISPLAY + END-IF + MOVE ' 3' TO x-left, x-right + DISPLAY """" x-left """" space """" x-right """" + IF x-left not = spaces + OR x-right not = ' 3' + DISPLAY 'error with " 3":' + END-DISPLAY + DISPLAY x-left + END-DISPLAY + DISPLAY x-right + END-DISPLAY + END-IF + MOVE '3 ' TO x-left, x-right + DISPLAY """" x-left """" space """" x-right """" + IF x-left not = '3' + OR x-right not = spaces + DISPLAY 'error with "3 ":' + END-DISPLAY + DISPLAY x-left + END-DISPLAY + DISPLAY x-right + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.out b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.out new file mode 100644 index 0000000..1bddffb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Alphanumeric_MOVE_with_truncation.out @@ -0,0 +1,4 @@ +"123" "234" +" " " 3" +"3 " " " + diff --git a/gcc/testsuite/cobol.dg/group2/Alphanumeric_and_binary_numeric.cob b/gcc/testsuite/cobol.dg/group2/Alphanumeric_and_binary_numeric.cob new file mode 100644 index 0000000..8ce12ee --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Alphanumeric_and_binary_numeric.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-X PIC XXXX VALUE "0001". + 01 X-9 PIC 9999 COMP VALUE 1. + PROCEDURE DIVISION. + IF X-X = X-9 + STOP RUN + END-IF. + DISPLAY "NG" NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.cob b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.cob new file mode 100644 index 0000000..0c5647c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/CALL_with_OMITTED_parameter.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 P1 PIC X VALUE "A". + 01 P2 PIC X VALUE "B". + PROCEDURE DIVISION. + DISPLAY "Should see AB" + CALL "callee" USING P1 P2 + DISPLAY "Should see A" + CALL "callee" USING P1 + END-CALL. + DISPLAY "Should see A" + CALL "callee" USING P1 OMITTED + END-CALL. + STOP RUN. + END PROGRAM caller. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + LINKAGE SECTION. + 01 P1 PIC X. + 01 P2 PIC X. + PROCEDURE DIVISION USING P1 OPTIONAL P2. + DISPLAY """" P1 WITH NO ADVANCING + IF P2 NOT OMITTED + DISPLAY P2 """" + END-DISPLAY + ELSE + DISPLAY """" + END-DISPLAY + END-IF. + EXIT PROGRAM. + END PROGRAM callee. + diff --git a/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.out b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.out new file mode 100644 index 0000000..1a77e2c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CALL_with_OMITTED_parameter.out @@ -0,0 +1,7 @@ +Should see AB +"AB" +Should see A +"A" +Should see A +"A" + diff --git a/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.cob b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.cob new file mode 100644 index 0000000..0c4e115 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + *> { dg-output-file "group2/CONTINUE_AFTER_1_SECONDS.out" } + + program-id. prog. + data division. + working-storage section. + 01 tod pic x(64). + 01 tstart pic 9999. + 01 tend pic 9999. + 01 tspan pic 9999. + procedure division. + accept tod from time + move tod(5:) to tstart + continue after 1.0 seconds. + accept tod from time + move tod(5:) to tend + if tend < tstart + compute tend = tend + 6000 + end-if + compute tspan = tend - tstart + if tspan >= 75 and tspan <= 125 + display "Looks good" + else + display "Looks bad! " tstart space tend space tspan + end-if + goback. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.out b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.out new file mode 100644 index 0000000..74b5c81 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CONTINUE_AFTER_1_SECONDS.out @@ -0,0 +1,2 @@ +Looks good + diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.cob b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.cob new file mode 100644 index 0000000..f1ebd6a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-output-file "group2/CURRENCY_SIGN.out" } + + PROGRAM-ID. prog. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + CURRENCY SIGN IS "Y". + + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 amount pic Y(6)9.99. + + PROCEDURE DIVISION. + Move 1512.34 to Amount + Display "Amount is #" Amount '#' with no advancing. + + GOBACK + . + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.out b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.out new file mode 100644 index 0000000..d49ed31 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN.out @@ -0,0 +1 @@ +Amount is # Y1512.34# diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob new file mode 100644 index 0000000..eff0822 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.cob @@ -0,0 +1,32 @@ + *> { dg-do run } + *> { dg-output-file "group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out" } + + PROGRAM-ID. prog. + + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + *> note the space after EUR / before ct. + CURRENCY SIGN IS "EUR " WITH PICTURE SYMBOL "U", + CURRENCY SIGN IS " ct (EUR)" WITH PICTURE SYMBOL "c", + Currency Sign is "$US" with Picture Symbol "$". + + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 EUROS PIC U99v99. + 77 cents PIC 9,999c. + 77 DOLLARS Pic $$,$$9.99. + + PROCEDURE DIVISION. + MOVE 12.34 TO EUROS + MULTIPLY euros BY 100 GIVING cents. + DISPLAY "#" EUROS "# equal #" cents '#'. + Move 1500 to DOLLARS + Display "Invoice amount #1 is " DOLLARS '.'. + Move 12.34 to DOLLARS + Display "Invoice amount #2 is " DOLLARS '.'. + + GOBACK + . + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out new file mode 100644 index 0000000..861e65a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/CURRENCY_SIGN_WITH_PICTURE_SYMBOL.out @@ -0,0 +1,4 @@ +#EUR 12.34# equal #1,234 ct (EUR)# +Invoice amount #1 is $US1,500.00. +Invoice amount #2 is $US12.34. + diff --git a/gcc/testsuite/cobol.dg/group2/Class_check_with_reference_modification.cob b/gcc/testsuite/cobol.dg/group2/Class_check_with_reference_modification.cob new file mode 100644 index 0000000..62d6bc8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Class_check_with_reference_modification.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(6) VALUE "123 ". + PROCEDURE DIVISION. + IF X(1:3) NUMERIC + STOP RUN + END-IF. + DISPLAY "NG" NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.cob b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.cob new file mode 100644 index 0000000..797c6fe --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.cob @@ -0,0 +1,76 @@ + *> { dg-do run } + *> { dg-output-file "group2/Complex_HEX__VALUE_and_MOVE.out" } + + identification division. + program-id. hex-init. + data division. + working-storage section. + 01 var-01020304. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE X'01020304'. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + + 01 var-low. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE LOW-VALUES. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-space. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE SPACE. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-quote. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE QUOTE. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-zero. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE ZERO. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 var-high. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE HIGH-VALUES. + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + 01 move-target. + 05 filler1. + 10 filler2 pic x(2) VALUE "33". + 10 as-value pic x(4) VALUE "3333". + 10 filler3 pic x(2) VALUE "33". + 05 as-pointer redefines filler1 usage pointer. + procedure division. + display "the value is " as-pointer of var-01020304. + display "should be 0x3333040302013333" + display "var-low : " as-pointer of var-low + display "var-space: " as-pointer of var-space + display "var-quote: " as-pointer of var-quote + display "var-zero : " as-pointer of var-zero + display "var-high : " as-pointer of var-high + display "initial " as-pointer of move-target + move low-value to as-value of move-target + display "low-value " as-pointer of move-target + move space to as-value of move-target + display "space " as-pointer of move-target + move quote to as-value of move-target + display "quote " as-pointer of move-target + move zeroes to as-value of move-target + display "zeroes " as-pointer of move-target + move high-value to as-value of move-target + display "high-value " as-pointer of move-target + move X'01020304' to as-value of move-target + display "01020304 " as-pointer of move-target + move "33333333" to move-target + move X'00' to filler3 of move-target(1:1) + display "ref-mod " as-pointer of move-target + stop run. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.out b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.out new file mode 100644 index 0000000..366d0c2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_HEX__VALUE_and_MOVE.out @@ -0,0 +1,16 @@ +the value is 0x3333040302013333 +should be 0x3333040302013333 +var-low : 0x3333000000003333 +var-space: 0x3333202020203333 +var-quote: 0x3333222222223333 +var-zero : 0x3333303030303333 +var-high : 0x3333ffffffff3333 +initial 0x3333333333333333 +low-value 0x3333000000003333 +space 0x3333202020203333 +quote 0x3333222222223333 +zeroes 0x3333303030303333 +high-value 0x3333ffffffff3333 +01020304 0x3333040302013333 +ref-mod 0x3300333333333333 + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_IF.cob b/gcc/testsuite/cobol.dg/group2/Complex_IF.cob new file mode 100644 index 0000000..aa3ebde --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_IF.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-output-file "group2/Complex_IF.out" } + identification division. + program-id. phonebook. + data division. + working-storage section. + 01 name1 pic x(10) value "one". + 01 name2 pic x(10) value "two". + 01 flag pic x value 'a'. + procedure division. + move 'l' to flag + perform checkit + goback. + checkit. + if (name1 = name2 and flag = "F" or "f" ) + or flag = "L" or "l" + then + display "the test is TRUE" + else + display "the test is FALSE" + end-if. + end program phonebook. + diff --git a/gcc/testsuite/cobol.dg/group2/Complex_IF.out b/gcc/testsuite/cobol.dg/group2/Complex_IF.out new file mode 100644 index 0000000..ce94a61 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Complex_IF.out @@ -0,0 +1,2 @@ +the test is TRUE + diff --git a/gcc/testsuite/cobol.dg/group2/Concatenation_operator.cob b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.cob new file mode 100644 index 0000000..fef757b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Concatenation_operator.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 77 STR PIC X(05). + PROCEDURE DIVISION. + MOVE "OK" & " " + & "OK" + TO STR + DISPLAY STR NO ADVANCING + END-DISPLAY + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Concatenation_operator.out b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.out new file mode 100644 index 0000000..618798a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Concatenation_operator.out @@ -0,0 +1 @@ +OK OK diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.cob new file mode 100644 index 0000000..2362d15 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3,,,,,,5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.out new file mode 100644 index 0000000..0b9310e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__1_.out @@ -0,0 +1,2 @@ +00,50 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.cob new file mode 100644 index 0000000..b69ee3b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3,,,,,, 5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.out new file mode 100644 index 0000000..9dcfab9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__2_.out @@ -0,0 +1,2 @@ +03,00 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.cob new file mode 100644 index 0000000..114b9ea --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__3_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3,,,,,, 1,5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.out new file mode 100644 index 0000000..5a24d4d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__3_.out @@ -0,0 +1,2 @@ +01,50 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.cob new file mode 100644 index 0000000..d969c73 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__4_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + MOVE FUNCTION MIN (3, 1,5) TO X. + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.out new file mode 100644 index 0000000..5a24d4d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__4_.out @@ -0,0 +1,2 @@ +01,50 + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.cob b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.cob new file mode 100644 index 0000000..2ca9881 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-output-file "group2/DECIMAL-POINT_is_COMMA__5_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + DECIMAL-POINT IS COMMA. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99V99. + PROCEDURE DIVISION. + COMPUTE X=1 + ,1 + END-COMPUTE + DISPLAY X + END-DISPLAY. + COMPUTE X=1*,1 + END-COMPUTE + DISPLAY X + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.out b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.out new file mode 100644 index 0000000..809e6ae --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/DECIMAL-POINT_is_COMMA__5_.out @@ -0,0 +1,3 @@ +01,10 +00,10 + diff --git a/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.cob b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.cob new file mode 100644 index 0000000..60310f7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.cob @@ -0,0 +1,30 @@ + *> { dg-do run } + *> { dg-output-file "group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 9 VALUE 1. + 01 y PIC 9. + 01 a COMP-1 VALUE 1.E20. + 01 b COMP-1 VALUE 1.E20. + PROCEDURE DIVISION. + DIVIDE x BY 0.1 GIVING y + DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-TRUNCATION' + DISPLAY 'Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + SET LAST EXCEPTION TO OFF + MULTIPLY a BY b GIVING b + DISPLAY FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-OVERFLOW' + DISPLAY 'Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out new file mode 100644 index 0000000..8c86ad2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-TRUNCATION_EC-SIZE-OVERFLOW.out @@ -0,0 +1,3 @@ +EC-SIZE-TRUNCATION +EC-SIZE-OVERFLOW + diff --git a/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.cob b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.cob new file mode 100644 index 0000000..8b5657b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.cob @@ -0,0 +1,64 @@ + *> { dg-do run } + *> { dg-output-file "group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 x PIC 9 VALUE 0. + 01 y PIC 9 VALUE 0. + 01 fx comp-2 VALUE 0. + 01 fy comp-2 VALUE 0. + PROCEDURE DIVISION. + DISPLAY "Fixed-point divide by zero:" + DIVIDE x BY y GIVING y + DISPLAY "1 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '1 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + SET LAST EXCEPTION TO OFF + DISPLAY "2 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION EXCEPTION-STATUS NOT = SPACES + DISPLAY '2 Exception is not empty after reset: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + MOVE 0 TO y + COMPUTE y = x - 1 / y + 6.5 + DISPLAY "3 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '3 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + SET LAST EXCEPTION TO OFF + DISPLAY "Floating-point divide by zero:" + DIVIDE fx BY fy GIVING fy + DISPLAY "4 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '4 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + SET LAST EXCEPTION TO OFF + DISPLAY "5 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION EXCEPTION-STATUS NOT = SPACES + DISPLAY '5 Exception is not empty after reset: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF + MOVE 0 TO fy + COMPUTE fy = fx - 1 / fy + 6.5 + DISPLAY "6 - """ FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) """" + IF FUNCTION TRIM(FUNCTION EXCEPTION-STATUS) + NOT = 'EC-SIZE-ZERO-DIVIDE' + DISPLAY '6 Wrong/missing exception: ' + FUNCTION EXCEPTION-STATUS + END-DISPLAY + END-IF. + diff --git a/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out new file mode 100644 index 0000000..93da1b8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EC-SIZE-ZERO-DIVIDE__fixed_and_float.out @@ -0,0 +1,9 @@ +Fixed-point divide by zero: +1 - "EC-SIZE-ZERO-DIVIDE" +2 - "" +3 - "EC-SIZE-ZERO-DIVIDE" +Floating-point divide by zero: +4 - "EC-SIZE-ZERO-DIVIDE" +5 - "" +6 - "EC-SIZE-ZERO-DIVIDE" + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PARAGRAPH.cob b/gcc/testsuite/cobol.dg/group2/EXIT_PARAGRAPH.cob new file mode 100644 index 0000000..b637ecb --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PARAGRAPH.cob @@ -0,0 +1,21 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + A01. + PERFORM VARYING INDVAL FROM 1 BY 1 UNTIL INDVAL > 10 + IF INDVAL > 2 + EXIT PARAGRAPH + END-IF + END-PERFORM. + A02. + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.cob b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.cob new file mode 100644 index 0000000..d944ccd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/EXIT_PERFORM.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + DISPLAY "OK" NO ADVANCING + END-DISPLAY + EXIT PERFORM + DISPLAY "NOT OK" + END-DISPLAY + END-PERFORM + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.out b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.out new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM.out @@ -0,0 +1 @@ +OK diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.cob b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.cob new file mode 100644 index 0000000..7d67bd1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/EXIT_PERFORM_CYCLE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + DISPLAY "OK" NO ADVANCING + END-DISPLAY + EXIT PERFORM CYCLE + DISPLAY "NOT OK" + END-DISPLAY + END-PERFORM + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.out b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.out new file mode 100644 index 0000000..d65874e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_PERFORM_CYCLE.out @@ -0,0 +1 @@ +OKOK diff --git a/gcc/testsuite/cobol.dg/group2/EXIT_SECTION.cob b/gcc/testsuite/cobol.dg/group2/EXIT_SECTION.cob new file mode 100644 index 0000000..fc670f1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/EXIT_SECTION.cob @@ -0,0 +1,25 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + A01 SECTION. + A011. + PERFORM VARYING INDVAL FROM 1 BY 1 UNTIL INDVAL > 10 + IF INDVAL > 2 + EXIT SECTION + END-IF + END-PERFORM. + A012. + DISPLAY INDVAL NO ADVANCING + END-DISPLAY. + A02 SECTION. + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.cob b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.cob new file mode 100644 index 0000000..d8c81a3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.cob @@ -0,0 +1,43 @@ + *> { dg-do run } + *> { dg-output-file "group2/FLOAT-LONG_with_SIZE_ERROR.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + *------------------------ + 77 counter pic s9(4) binary value zero. + * FLOAT-LONG + 77 doubleValue COMP-2 value 2. + 77 lastDoubleValue COMP-2. + ****************************************************************** + procedure division. + main section. + perform varying counter from 1 by 1 until + counter > 1060 + *> display 'counter: ' counter ', value: ' doubleValue + compute doubleValue = doubleValue * 2 + ON SIZE ERROR + display 'SIZE ERROR raised' + end-display + display 'SIZE ERROR, last value = ' doubleValue + end-display + exit perform + not ON SIZE ERROR + if doubleValue > lastdoubleValue + move doubleValue to lastdoubleValue + else + display 'math ERROR, last value > current: ' + lastdoubleValue ' > ' doubleValue + end-display + exit perform + end-if + end-compute + end-perform + display "counter is " counter + if not (counter >= 1023 and <=1025) + display ' ' + display 'counter is ' counter + end-if + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.out b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.out new file mode 100644 index 0000000..208bd8a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-LONG_with_SIZE_ERROR.out @@ -0,0 +1,4 @@ +SIZE ERROR raised +SIZE ERROR, last value = 8.98846567431157954E+307 +counter is +1023 + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.cob b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.cob new file mode 100644 index 0000000..e00676c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.cob @@ -0,0 +1,164 @@ + *> { dg-do run } + *> { dg-output-file "group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 CMP1 COMP-1. + 01 SV1 COMP-1. + 01 CMP2 COMP-2. + 01 SV2 COMP-2. + + PROCEDURE DIVISION. + CND-000. + + DISPLAY "--- COMP-1 ---" + COMPUTE CMP1 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 + DISPLAY "A: " CMP1 + COMPUTE CMP1 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 + DISPLAY "B: " CMP1 + MOVE ZERO TO CMP1. + COMPUTE CMP1 = 1.0E3 / 2.1E0 + ON SIZE ERROR DISPLAY "Z: " CMP1 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "Z: " CMP1 " IS OK" + END-COMPUTE. + + DISPLAY " ..." + DISPLAY "--- COMP-2 ---" + COMPUTE CMP2 = (((1.0E7 / 2.1E0) / 3.1E0) - 5.0E-1) * 6.0E0 + *> because of possible rounding of intermediates and different + *> precision depending on math library / version: plain DISPLAY + IF CMP2 >= 9216586.86175114 AND <= 9216586.86175116 + DISPLAY "A ~ 9216586.86175115" + ELSE + DISPLAY "A: " CMP2 + END-IF + COMPUTE CMP2 = (((1.0E7 / 2.9E0) / 3.9E0) - 5.0E-1) * 6.0E0 + IF CMP2 >= 5305036.7877983 AND <= 5305036.7877985 + DISPLAY "B ~ 5305036.787798408" + ELSE + DISPLAY "B: " CMP2 + END-IF + MOVE ZERO TO CMP2. + COMPUTE CMP2 = 1.0E3 / 2.1E0 + ON SIZE ERROR DISPLAY "Z: " CMP2 " SIZE ERROR" + NOT ON SIZE ERROR + *> see note above + IF CMP2 >= 476.1904761904760 AND <= 476.1904761904763 + DISPLAY "Z ~ 476.1904761904761 IS OK" + ELSE + DISPLAY "Z: " CMP2 " IS OK" + END-IF + END-COMPUTE. + + DISPLAY " ..." + DISPLAY "--- 99 + 1 / 3 ---" + MOVE -1 TO CMP1, CMP2. + COMPUTE CMP1 = 99 + 1 / 3 + ON SIZE ERROR DISPLAY "CMP1: " CMP1 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP1: " CMP1 " IS OK" + END-COMPUTE. + COMPUTE CMP2 = 99 + 1 / 3 + ON SIZE ERROR DISPLAY "CMP2: " CMP2 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP2: " CMP2 " IS OK" + END-COMPUTE. + + DISPLAY " ..." + DISPLAY "--- 99 ---" + MOVE -1 TO CMP1, CMP2. + COMPUTE CMP1 = 99 + ON SIZE ERROR DISPLAY "CMP1: " CMP1 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP1: " CMP1 " IS OK" + END-COMPUTE. + COMPUTE CMP2 = 99 + ON SIZE ERROR DISPLAY "CMP2: " CMP2 " SIZE ERROR" + NOT ON SIZE ERROR DISPLAY "CMP2: " CMP2 " IS OK" + END-COMPUTE. + + CND-100-OK. + DISPLAY " ..." + DISPLAY "--- Test overflow ---" + + MOVE 990000 TO CMP1. + PERFORM 6500 TIMES + MOVE CMP1 TO SV1 + COMPUTE CMP1 = CMP1 * 10 + ON SIZE ERROR GO TO CND-350-ERR + END-COMPUTE + IF CMP1 < 9.0 + GO TO CND-350-ERR + END-IF + END-PERFORM. + DISPLAY "CMP1: " CMP1 " IS OK". + GO TO CND-350-OK. + CND-350-ERR. + DISPLAY "CMP1: after " SV1 " SIZE ERROR". + + CND-350-OK. + MOVE 9900000000 TO CMP2. + PERFORM 6500 TIMES + MOVE CMP2 TO SV2 + COMPUTE CMP2 = CMP2 * 10 + ON SIZE ERROR GO TO CND-380-ERR + END-COMPUTE + IF CMP2 < 9.0 + GO TO CND-380-ERR + END-IF + END-PERFORM. + DISPLAY "CMP2: " CMP2 " IS OK". + GO TO CND-500-OK. + CND-380-ERR. + *> because of possible rounding of intermediates and different + *> precision depending on math library / version: plain DISPLAY + IF SV2 >= 9.899999999999E+307 AND + <= 9.900000000001E+307 + DISPLAY "CMP2: after ~ 9.899999999999781E+307 SIZE ERROR" + ELSE + DISPLAY "CMP2: after " SV2 " SIZE ERROR" + END-IF + . + + CND-500-OK. + MOVE 0.000000099 TO CMP1. + PERFORM 350 TIMES + MOVE CMP1 TO SV1 + COMPUTE CMP1 = CMP1 / 10.0 + ON SIZE ERROR GO TO CND-500-ERR + END-COMPUTE + IF CMP1 = 0.0 + GO TO CND-500-ERR + END-IF + END-PERFORM. + DISPLAY "CMP1: " CMP1 " IS OK". + GO TO CND-600-OK. + CND-500-ERR. + DISPLAY "CMP1: after " SV1 " SIZE ERROR". + + CND-600-OK. + MOVE 0.000000099 TO CMP2. + PERFORM 350 TIMES + MOVE CMP2 TO SV2 + COMPUTE CMP2 = CMP2 / 10.0 + ON SIZE ERROR GO TO CND-600-ERR + END-COMPUTE + IF CMP2 = 0.0 + GO TO CND-600-ERR + END-IF + END-PERFORM. + DISPLAY "CMP2: " CMP2 " IS OK". + GO TO CND-600-XIT. + CND-600-ERR. + IF SV2 >= 9.8813129168249E-324 AND <= 9.881312916825E-324 + DISPLAY "CMP2: after ~ 9.881312916824931E-324 SIZE ERROR" + ELSE + DISPLAY "CMP2: after " SV2 " SIZE ERROR" + END-IF + . + CND-600-XIT. + + CND-999. + STOP RUN. + END PROGRAM prog. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out new file mode 100644 index 0000000..18fc770 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT___FLOAT-LONG_w_o_SIZE_ERROR.out @@ -0,0 +1,24 @@ +--- COMP-1 --- +A: 9.216587E+06 +B: 5.305037E+06 +Z: 476.1904907 IS OK + ... +--- COMP-2 --- +A ~ 9216586.86175115 +B ~ 5305036.787798408 +Z ~ 476.1904761904761 IS OK + ... +--- 99 + 1 / 3 --- +CMP1: 99.33333588 IS OK +CMP2: 99.3333333333333286 IS OK + ... +--- 99 --- +CMP1: 99 IS OK +CMP2: 99 IS OK + ... +--- Test overflow --- +CMP1: after 9.899998274E+37 SIZE ERROR +CMP2: after ~ 9.899999999999781E+307 SIZE ERROR +CMP1: after 1.401298464E-45 SIZE ERROR +CMP2: after ~ 9.881312916824931E-324 SIZE ERROR + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.cob b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.cob new file mode 100644 index 0000000..b194442 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + *> { dg-output-file "group2/FLOAT-SHORT_with_SIZE_ERROR.out" } + + identification division. + program-id. prog. + + data division. + working-storage section. + *------------------------ + 77 counter pic s9(4) binary value zero. + * FLOAT-SHORT (if binary-comp-1 is not active) + 77 floatValue COMP-1 value 2. + 77 lastFloatValue COMP-1. + + ****************************************************************** + procedure division. + main section. + perform varying counter from 1 by 1 until + counter > 130 + *> display 'counter: ' counter ', value: ' floatValue + compute floatValue = floatValue * 2 + ON SIZE ERROR + display 'SIZE ERROR, last value = ' floatValue + exit perform + not ON SIZE ERROR + if floatValue > lastFloatValue + move floatValue to lastFloatValue + else + display 'math ERROR, last value > current: ' + lastFloatValue ' > ' floatValue + exit perform + end-if + end-compute + end-perform + if counter not = 127 + display 'counter is ' counter + end-if + + goback. + diff --git a/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.out b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.out new file mode 100644 index 0000000..e5ba05f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/FLOAT-SHORT_with_SIZE_ERROR.out @@ -0,0 +1,2 @@ +SIZE ERROR, last value = 1.701411835E+38 + diff --git a/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.cob b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.cob new file mode 100644 index 0000000..2c23e7b --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + *> { dg-output-file "group2/Fixed_continuation_indicator.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(333) VALUE + '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWX + - 'YZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUV + - 'WXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRST + - 'UVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQR + - 'STUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOP + - 'QRSTUVWXYZ'. + PROCEDURE DIVISION. + DISPLAY X NO ADVANCING + END-DISPLAY. + DISPLAY '_' + END-DISPLAY. + MOVE + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01234567 + - "89abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ012345 + - "6789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123 + - "456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ01 + - "23456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXY + - "Z + - "0123456789" TO X. + DISPLAY X NO ADVANCING + END-DISPLAY. + DISPLAY '_' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.out b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.out new file mode 100644 index 0000000..2a472b8 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Fixed_continuation_indicator.out @@ -0,0 +1,3 @@ +0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ _ +abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789 _ + diff --git a/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.cob b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.cob new file mode 100644 index 0000000..88c24fd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + *> { dg-output-file "group2/Index_and_parenthesized_expression.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X OCCURS 1 INDEXED BY I. + PROCEDURE DIVISION. + IF I < (I + 2) + DISPLAY "OK" NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.out b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.out new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Index_and_parenthesized_expression.out @@ -0,0 +1 @@ +OK diff --git a/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.cob b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.cob new file mode 100644 index 0000000..7b24aed --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.cob @@ -0,0 +1,107 @@ + *> { dg-do run } + *> { dg-options "-dialect ibm" } + *> { dg-output-file "group2/LENGTH_OF_omnibus.out" } + + program-id. prog. + data division. + working-storage section. + 01 desc1. + 05 desc1-entry pic x(5) occurs 10. + + 01 desc2. + 05 desc2-table occurs 10 times. + 10 desc2-entry pic x(5). + + 01 desc3. + 05 desc3-outer occurs 1 to 5 times depending on desc3-lim. + 10 desc3-outer-txt pic x(7). + 10 desc3-inner occurs 11 times. + 15 desc3-inner-text pic x(13). + 77 desc3-lim binary-long. + + 77 msg pic x(64). + 77 should-be pic zzzz9. + 77 but-is pic zzzz9. + + procedure division. + + display "using LENGTH OF" + + move "Length of desc1" to msg + move 50 to should-be + move length of desc1 to but-is + perform result-is + + move "Length of desc1-entry" to msg + move 5 to should-be + move length of desc1-entry to but-is + perform result-is + + move "Length of desc1-entry(1)" to msg + move 5 to should-be + move length of desc1-entry(1) to but-is + perform result-is + + move "Length of desc2" to msg + move 50 to should-be + move length of desc2 to but-is + perform result-is + + move "Length of desc2-table" to msg + move 5 to should-be + move length of desc2-table to but-is + perform result-is + + move "Length of desc2-entry" to msg + move 5 to should-be + move length of desc2-entry to but-is + perform result-is + + move "Length of desc2-entry(1)" to msg + move 5 to should-be + move length of desc2-entry(1) to but-is + perform result-is + + move 5 to desc3-lim + + move "Length of desc3" to msg + move 750 to should-be + move length of desc3 to but-is + perform result-is + + move "Length of desc3-outer" to msg + move 150 to should-be + move length of desc3-outer to but-is + perform result-is + + move "Length of desc3-outer(1)" to msg + move 150 to should-be + move length of desc3-outer(1) to but-is + perform result-is + + move "Length of desc3-outer-txt" to msg + move 7 to should-be + move length of desc3-outer-txt to but-is + perform result-is + + move "Length of desc3-inner" to msg + move 13 to should-be + move length of desc3-inner to but-is + perform result-is + + move "Length of desc3-inner(1)" to msg + move 13 to should-be + move length of desc3-inner(1) to but-is + perform result-is + + goback. + result-is. + display function trim(msg) ": " with no advancing + if but-is equal to should-be + display function trim(but-is) + else + display "should be " function trim(should-be) + " but is " function trim(but-is) + end-if. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.out b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.out new file mode 100644 index 0000000..e4cf801 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LENGTH_OF_omnibus.out @@ -0,0 +1,15 @@ +using LENGTH OF +Length of desc1: 50 +Length of desc1-entry: 5 +Length of desc1-entry(1): 5 +Length of desc2: 50 +Length of desc2-table: 5 +Length of desc2-entry: 5 +Length of desc2-entry(1): 5 +Length of desc3: 750 +Length of desc3-outer: 150 +Length of desc3-outer(1): 150 +Length of desc3-outer-txt: 7 +Length of desc3-inner: 13 +Length of desc3-inner(1): 13 + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.cob b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.cob new file mode 100644 index 0000000..a4410fa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + *> { dg-output-file "group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + PROCEDURE DIVISION. + CALL "callee" + END-CALL. + STOP RUN. + end program caller. + + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WRK-X PIC 999 VALUE 5. + LOCAL-STORAGE SECTION. + 01 LCL-X PIC 999 . + PROCEDURE DIVISION. + display "On entry: " wrk-x + move wrk-x to lcl-x + subtract 1 from wrk-x + if wrk-x > 0 + call "callee". + display "On exit: " lcl-x + goback. + end program callee. + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out new file mode 100644 index 0000000..839de4f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__3__with_recursive_PROGRAM-ID.out @@ -0,0 +1,11 @@ +On entry: 005 +On entry: 004 +On entry: 003 +On entry: 002 +On entry: 001 +On exit: 001 +On exit: 002 +On exit: 003 +On exit: 004 +On exit: 005 + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.cob b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.cob new file mode 100644 index 0000000..64d0072 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + *> { dg-output-file "group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + PROCEDURE DIVISION. + CALL "callee" + END-CALL. + STOP RUN. + end program caller. + + IDENTIFICATION DIVISION. + PROGRAM-ID. callee. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WRK-X PIC 999 VALUE 5. + LOCAL-STORAGE SECTION. + 01 LCL-X PIC 999 . + PROCEDURE DIVISION. + display "On entry: " wrk-x + move wrk-x to lcl-x + subtract 1 from wrk-x + if wrk-x > 0 + call "callee". + display "On exit: " lcl-x + goback. + end program callee. + diff --git a/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out new file mode 100644 index 0000000..839de4f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/LOCAL-STORAGE__4__with_recursive_PROGRAM-ID_..._USING.out @@ -0,0 +1,11 @@ +On entry: 005 +On entry: 004 +On entry: 003 +On entry: 002 +On entry: 001 +On exit: 001 +On exit: 002 +On exit: 003 +On exit: 004 +On exit: 005 + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.cob new file mode 100644 index 0000000..c92ab35 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.cob @@ -0,0 +1,34 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_Z_literal_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC XXXX. + 01 XRED REDEFINES X. + 03 XBYTE1 PIC X. + 03 XBYTE2 PIC X. + 03 XBYTE3 PIC X. + 03 XBYTE4 PIC X. + PROCEDURE DIVISION. + MOVE Z"012" TO X. + IF XBYTE1 = "0" AND + XBYTE2 = "1" AND + XBYTE3 = "2" AND + XBYTE4 = LOW-VALUE + DISPLAY "OK" NO ADVANCING + END-DISPLAY + ELSE + DISPLAY "X = " X (1:3) NO ADVANCING + END-DISPLAY + IF XBYTE4 = LOW-VALUE + DISPLAY " WITH LOW-VALUE" + END-DISPLAY + ELSE + DISPLAY " WITHOUT LOW-VALUE BUT '" XBYTE4 "'" + END-DISPLAY + END-IF + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.out b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.out new file mode 100644 index 0000000..d86bac9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_Z_literal_.out @@ -0,0 +1 @@ +OK diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_indexes.cob b/gcc/testsuite/cobol.dg/group2/MOVE_indexes.cob new file mode 100644 index 0000000..9ededd2c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_indexes.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X OCCURS 10 INDEXED I. + PROCEDURE DIVISION. + SET I TO ZERO. + SET X(1) TO I + IF X(1) NOT = "0" + DISPLAY X(1) NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.cob b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.cob new file mode 100644 index 0000000..61be48f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_integer_literal_to_alphanumeric.out" } + + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(04) VALUE SPACES. + PROCEDURE DIVISION. + MOVE 0 TO X. + DISPLAY X NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.out b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.out new file mode 100644 index 0000000..4af5951 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_integer_literal_to_alphanumeric.out @@ -0,0 +1 @@ +0 diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.cob new file mode 100644 index 0000000..37f813f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.cob @@ -0,0 +1,31 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_JUSTIFIED_item.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC-1 PIC S9(04) VALUE 11. + 01 SRC-2 PIC S9(04) COMP VALUE 22. + 01 SRC-3 PIC S9(04) COMP-5 VALUE 33. + 01 SRC-4 PIC S9(04)PP VALUE 4400. + 01 SRC-5 PIC S9(04)PPPPP VALUE 55500000. + 01 EDT-FLD PIC X(07) JUSTIFIED RIGHT. + PROCEDURE DIVISION. + MOVE SRC-1 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-2 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-3 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-4 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + MOVE SRC-5 TO EDT-FLD. + DISPLAY '>' EDT-FLD '<' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.out new file mode 100644 index 0000000..5e300fa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_JUSTIFIED_item.out @@ -0,0 +1,6 @@ +> 0011< +> 0022< +> 0033< +> 004400< +>5500000< + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.cob new file mode 100644 index 0000000..86ef0ae --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_edited_item__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC-1 PIC S99V99 VALUE 1.10. + 01 SRC-2 PIC S99V99 VALUE 0.02. + 01 SRC-3 PIC S99V99 VALUE -0.03. + 01 SRC-4 PIC S99V99 VALUE -0.04. + 01 SRC-5 PIC S99V99 VALUE -0.05. + 01 EDT-1 PIC -(04)9. + 01 EDT-2 PIC -(04)9. + 01 EDT-3 PIC -(04)9. + 01 EDT-4 PIC +(04)9. + 01 EDT-5 PIC -(05). + PROCEDURE DIVISION. + MOVE SRC-1 TO EDT-1. + MOVE SRC-2 TO EDT-2. + MOVE SRC-3 TO EDT-3. + MOVE SRC-4 TO EDT-4. + MOVE SRC-5 TO EDT-5. + DISPLAY '>' EDT-1 '<' + END-DISPLAY. + DISPLAY '>' EDT-2 '<' + END-DISPLAY. + DISPLAY '>' EDT-3 '<' + END-DISPLAY. + DISPLAY '>' EDT-4 '<' + END-DISPLAY. + DISPLAY '>' EDT-5 '<' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.out new file mode 100644 index 0000000..9557d50 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__1_.out @@ -0,0 +1,6 @@ +> 1< +> 0< +> 0< +> +0< +> < + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.cob new file mode 100644 index 0000000..cde8096 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_edited_item__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 SRC-1 PIC S99V99 VALUE -0.06. + 01 SRC-2 PIC S99V99 VALUE -0.07. + 01 SRC-3 PIC S99V99 VALUE -0.08. + 01 SRC-4 PIC S99V99 VALUE -0.09. + 01 SRC-5 PIC S99V99 VALUE -1.10. + 01 EDT-1 PIC 9(04)-. + 01 EDT-2 PIC 9(04)+. + 01 EDT-3 PIC Z(04)+. + 01 EDT-4 PIC 9(04)DB. + 01 EDT-5 PIC 9(04)DB. + PROCEDURE DIVISION. + MOVE SRC-1 TO EDT-1. + MOVE SRC-2 TO EDT-2. + MOVE SRC-3 TO EDT-3. + MOVE SRC-4 TO EDT-4. + MOVE SRC-5 TO EDT-5. + DISPLAY '>' EDT-1 '<' + END-DISPLAY. + DISPLAY '>' EDT-2 '<' + END-DISPLAY. + DISPLAY '>' EDT-3 '<' + END-DISPLAY. + DISPLAY '>' EDT-4 '<' + END-DISPLAY. + DISPLAY '>' EDT-5 '<' + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.out new file mode 100644 index 0000000..a704296 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_edited_item__2_.out @@ -0,0 +1,6 @@ +>0000 < +>0000+< +> < +>0000 < +>0001DB< + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.cob new file mode 100644 index 0000000..92711a9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.cob @@ -0,0 +1,23 @@ + *> { dg-do run } + *> { dg-output-file "group2/MOVE_to_item_with_simple_and_floating_insertion.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 num-1 PIC -*B*99. + 01 num-2 PIC $BB**,***.**. + 01 num-3 PIC $BB--,---.--. + + PROCEDURE DIVISION. + MOVE -123 TO num-1 + DISPLAY ">" num-1 "<" + + MOVE 1234.56 TO num-2 + DISPLAY ">" num-2 "<" + + MOVE 1234.56 TO num-3 + DISPLAY ">" num-3 "<" + . + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.out b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.out new file mode 100644 index 0000000..9012693 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_item_with_simple_and_floating_insertion.out @@ -0,0 +1,4 @@ +>-**123< +>$ *1,234.56< +>$ 1,234.56< + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_to_itself.cob b/gcc/testsuite/cobol.dg/group2/MOVE_to_itself.cob new file mode 100644 index 0000000..475b5d9 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_to_itself.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 99 VALUE 12. + PROCEDURE DIVISION. + MOVE X TO X. + IF X NOT = 12 + DISPLAY X NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_with_group_refmod.cob b/gcc/testsuite/cobol.dg/group2/MOVE_with_group_refmod.cob new file mode 100644 index 0000000..834d81d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_with_group_refmod.cob @@ -0,0 +1,16 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC 9999 VALUE 1234. + PROCEDURE DIVISION. + MOVE "99" TO G(3:2). + IF G NOT = "1299" + DISPLAY G NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod.cob b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod.cob new file mode 100644 index 0000000..455951a --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod.cob @@ -0,0 +1,15 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 9(4) VALUE 0. + PROCEDURE DIVISION. + MOVE "1" TO X(1:1). + IF X NOT = 1000 + DISPLAY X NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod__variable_.cob b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod__variable_.cob new file mode 100644 index 0000000..b3fb550 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/MOVE_with_refmod__variable_.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC X(4) VALUE "1234". + 01 Y PIC X(4) VALUE "abcd". + 01 I PIC 9 VALUE 1. + PROCEDURE DIVISION. + MOVE X(1:I) TO Y. + IF Y NOT = "1 " + DISPLAY Y NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob new file mode 100644 index 0000000..6aa9388 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + *> { dg-output-file "group2/Multi-target_MOVE_with_subscript_re-evaluation.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. mover. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FILLER. + 02 ADATA VALUE "654321". + 02 A REDEFINES ADATA PIC 9 OCCURS 6 TIMES. + 02 B PIC 9. + 02 CDATA VALUE "999999". + 02 C REDEFINES CDATA PIC 9 OCCURS 6 TIMES. + 01 TEMP PIC 9. + PROCEDURE DIVISION. + INITIALIZE CDATA ALL TO VALUE + MOVE 2 TO B + MOVE A(B) TO B, C(B) + *> That should pick up 5, move it to B, and then move 5 to C(5), + IF CDATA NOT EQUAL TO "999959" + DISPLAY CDATA " Should be ""999959"", but isn't" + ELSE + DISPLAY CDATA " Should be ""999959""". + *> See 14.9.25.4 MOVE General Rules + INITIALIZE CDATA ALL TO VALUE + MOVE 2 TO B + MOVE A(B) TO TEMP + MOVE TEMP TO B + MOVE TEMP TO C(B) + IF CDATA NOT EQUAL TO "999959" + DISPLAY CDATA " Should be ""999959"", but isn't" + ELSE + DISPLAY CDATA " Should be ""999959""". + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.out b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.out new file mode 100644 index 0000000..30076d7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Multi-target_MOVE_with_subscript_re-evaluation.out @@ -0,0 +1,3 @@ +999959 Should be "999959" +999959 Should be "999959" + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.cob b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.cob new file mode 100644 index 0000000..6b38f79 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/Non-numeric_data_in_numeric_items__1_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X. + 03 X-NUM PIC 9(06) VALUE 123. + 77 NUM PIC 9(06). + PROCEDURE DIVISION. + MOVE x"0000" TO X (2:2) + IF X-NUM NUMERIC + DISPLAY "low-value is numeric" UPON SYSERR + END-DISPLAY + END-IF + MOVE x"01" TO X (3:1) + IF X-NUM NUMERIC + DISPLAY "SOH is numeric" UPON SYSERR + END-DISPLAY + END-IF + MOVE X-NUM TO NUM + DISPLAY "test over" + END-DISPLAY + * + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.out b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.out new file mode 100644 index 0000000..ac61d84 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__1_.out @@ -0,0 +1,2 @@ +test over + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob new file mode 100644 index 0000000..e80071f --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-output-file "group2/Non-numeric_data_in_numeric_items__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X. + 03 X-NUM PIC 9(06) PACKED-DECIMAL VALUE 123. + 77 NUM PIC 9(06). + PROCEDURE DIVISION. + MOVE x"0A" TO X (2:1) + IF X-NUM NUMERIC + DISPLAY "bad prog" + END-DISPLAY + END-IF + MOVE X-NUM TO NUM + DISPLAY "test over" + END-DISPLAY + * + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out new file mode 100644 index 0000000..ac61d84 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-numeric_data_in_numeric_items__2_.out @@ -0,0 +1,2 @@ +test over + diff --git a/gcc/testsuite/cobol.dg/group2/Non-overflow_after_overflow.cob b/gcc/testsuite/cobol.dg/group2/Non-overflow_after_overflow.cob new file mode 100644 index 0000000..fb6cdc7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Non-overflow_after_overflow.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X PIC 9(2) VALUE 0. + 01 Y PIC 9(2) VALUE 0. + PROCEDURE DIVISION. + COMPUTE X = 100 + END-COMPUTE. + COMPUTE Y = 99 + END-COMPUTE. + IF Y NOT = 99 + DISPLAY Y NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/OCCURS_clause_with_1_entry.cob b/gcc/testsuite/cobol.dg/group2/OCCURS_clause_with_1_entry.cob new file mode 100644 index 0000000..f244407 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/OCCURS_clause_with_1_entry.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 D1. + 03 FILLER OCCURS 1. + 05 D1-ENTRY PIC X(03) value '123'. + 01 D2. + 03 D2-ENTRY PIC X(03) value 'ABC' OCCURS 1. + 01 D1TOR. + 03 FILLER PIC X(03) value '456'. + 01 D1-R REDEFINES D1TOR. + 03 FILLER OCCURS 1. + 05 D1-R-ENTRY PIC X(03). + 01 D2TOR. + 03 FILLER PIC X(03) value 'DEF'. + 01 D2-R REDEFINES D2TOR. + 03 D2-R-ENTRY PIC X(03) OCCURS 1. + + PROCEDURE DIVISION. + IF D1-ENTRY (1) NOT = "123" + DISPLAY D1-ENTRY (1) + END-DISPLAY + END-IF. + IF D2-ENTRY (1) NOT = "ABC" + DISPLAY D2-ENTRY (1) + END-DISPLAY + END-IF. + IF D1-R-ENTRY (1) NOT = "456" + DISPLAY D1-R-ENTRY (1) + END-DISPLAY + END-IF. + IF D2-R-ENTRY (1) NOT = "DEF" + DISPLAY D2-R-ENTRY (1) + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.cob b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.cob new file mode 100644 index 0000000..ff047bf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.cob @@ -0,0 +1,40 @@ + *> { dg-do run } + *> { dg-output-file "group2/OSVS_Arithmetic_Test__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 VAL PIC S9(7)V99 COMP-3 VALUE 20500. + 01 DIV1 PIC S9(7)V99 COMP-3 VALUE 0.9. + 01 DIV2 PIC S9(7)V99 COMP-3 VALUE 33.45. + 01 DIV3 PIC S9(7)V99 COMP-3 VALUE 9. + 01 MUL1 PIC S9(7)V99 COMP-3 VALUE 10. + 01 MUL2 PIC S9(7)V99 COMP-3 VALUE 5. + 01 MUL3 PIC S9(7)V99 COMP-3 VALUE 2. + 01 RES PIC S9(7)V99 COMP-3. + PROCEDURE DIVISION. + COMPUTE RES = VAL / DIV1 / DIV2. + DISPLAY 'RES = ' RES. + COMPUTE RES ROUNDED = VAL / DIV1 / DIV2. + DISPLAY 'RES ROUNDED = ' RES. + COMPUTE RES = VAL * MUL1 / DIV3 / DIV2. + DISPLAY 'RES MULT1 = ' RES. + COMPUTE RES = VAL * MUL2 * MUL3 / DIV3 / DIV2. + DISPLAY 'RES MULT2 = ' RES. + COMPUTE RES = VAL / DIV1. + DISPLAY 'RES 1 = ' RES. + COMPUTE RES = RES / DIV2. + DISPLAY 'RES F = ' RES. + COMPUTE RES = + VAL / DIV1 / DIV2. + DISPLAY 'RES NOT ROUNDED = ' RES. + COMPUTE RES ROUNDED MODE NEAREST-AWAY-FROM-ZERO = + VAL / DIV1 / DIV2. + DISPLAY 'RES ROUNDED NEAREST-AWAY = ' RES. + COMPUTE RES ROUNDED MODE AWAY-FROM-ZERO = + VAL / DIV1 / DIV2. + DISPLAY 'RES ROUNDED AWAY = ' RES. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.out b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.out new file mode 100644 index 0000000..d0816cd --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/OSVS_Arithmetic_Test__2_.out @@ -0,0 +1,10 @@ +RES = +0000680.95 +RES ROUNDED = +0000680.95 +RES MULT1 = +0000680.95 +RES MULT2 = +0000680.95 +RES 1 = +0022777.77 +RES F = +0000680.94 +RES NOT ROUNDED = +0000680.95 +RES ROUNDED NEAREST-AWAY = +0000680.95 +RES ROUNDED AWAY = +0000680.96 + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_..._CONTINUE.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_..._CONTINUE.cob new file mode 100644 index 0000000..5f39fc5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_..._CONTINUE.cob @@ -0,0 +1,9 @@ + *> { dg-do compile } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + PERFORM 2 TIMES + CONTINUE + END-PERFORM. + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_inline__1_.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__1_.cob new file mode 100644 index 0000000..7f6f3aa --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__1_.cob @@ -0,0 +1,19 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + PERFORM VARYING INDVAL FROM 1 + BY 1 UNTIL INDVAL > 2 + CONTINUE + END-PERFORM + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF + STOP RUN + . + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_inline__2_.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__2_.cob new file mode 100644 index 0000000..e3e0458 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_inline__2_.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 INDVAL PIC 9(4). + PROCEDURE DIVISION. + PERFORM VARYING INDVAL FROM 1 + BY 1 UNTIL INDVAL > 2 + CONTINUE + END-PERFORM + IF INDVAL NOT = 3 + DISPLAY INDVAL NO ADVANCING + END-DISPLAY + END-IF + . + diff --git a/gcc/testsuite/cobol.dg/group2/PERFORM_type_OSVS.cob b/gcc/testsuite/cobol.dg/group2/PERFORM_type_OSVS.cob new file mode 100644 index 0000000..e64d679 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PERFORM_type_OSVS.cob @@ -0,0 +1,28 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 MYOCC PIC 9(8) COMP VALUE 0. + PROCEDURE DIVISION. + ASTART SECTION. + A01. + PERFORM BTEST. + IF MYOCC NOT = 2 + DISPLAY MYOCC + END-DISPLAY + END-IF. + STOP RUN. + BTEST SECTION. + B01. + PERFORM B02 VARYING MYOCC FROM 1 BY 1 + UNTIL MYOCC > 5. + GO TO B99. + B02. + IF MYOCC > 1 + GO TO B99 + END-IF. + B99. + EXIT. + diff --git a/gcc/testsuite/cobol.dg/group2/PIC_ZZZ-__ZZZ_.cob b/gcc/testsuite/cobol.dg/group2/PIC_ZZZ-__ZZZ_.cob new file mode 100644 index 0000000..a8ad589 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/PIC_ZZZ-__ZZZ_.cob @@ -0,0 +1,44 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 X-ZZZN PIC ZZZ-. + 01 XZN-RED REDEFINES X-ZZZN PIC X(4). + 01 X-ZZZP PIC ZZZ+. + 01 XZP-RED REDEFINES X-ZZZP PIC X(4). + PROCEDURE DIVISION. + MOVE -1 TO X-ZZZN. + IF XZN-RED NOT = " 1-" + DISPLAY "(" X-ZZZN ")" + END-DISPLAY + END-IF. + MOVE 0 TO X-ZZZN. + IF XZN-RED NOT = " " + DISPLAY "(" X-ZZZN ")" + END-DISPLAY + END-IF. + MOVE +1 TO X-ZZZN. + IF XZN-RED NOT = " 1 " + DISPLAY "(" X-ZZZN ")" + END-DISPLAY + END-IF. + + MOVE -1 TO X-ZZZP. + IF XZP-RED NOT = " 1-" + DISPLAY "(" X-ZZZP ")" + END-DISPLAY + END-IF. + MOVE 0 TO X-ZZZP. + IF XZP-RED NOT = " " + DISPLAY "(" X-ZZZP ")" + END-DISPLAY + END-IF. + MOVE +1 TO X-ZZZP. + IF XZP-RED NOT = " 1+" + DISPLAY "(" X-ZZZP ")" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.cob b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.cob new file mode 100644 index 0000000..5e73de6 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.cob @@ -0,0 +1,17 @@ + *> { dg-do run } + *> { dg-options "-dialect mf" } + *> { dg-output-file "group2/Quick_check_of_PIC_XX_COMP-5.out" } + identification division. + program-id. wrapper. + data division. + working-storage section. + 01 memx pic x(2) comp-5. + 77 ptr pointer. + procedure division. + Initialize ptr.display "LENGTH OF X(2) is " length of memx + move 12345 to memx + display memx + IF ptr <> NULL then display 'bad pointer'. + goback. + end program wrapper. + diff --git a/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.out b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.out new file mode 100644 index 0000000..a79f3be --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quick_check_of_PIC_XX_COMP-5.out @@ -0,0 +1,3 @@ +LENGTH OF X(2) is 2 +12345 + diff --git a/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.cob b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.cob new file mode 100644 index 0000000..70564e4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.cob @@ -0,0 +1,11 @@ + *> { dg-do run } + *> { dg-output-file "group2/Quote_marks_in_comment_paragraphs.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATE-written. hello'". + *> Written is intentionally lowercase. + *> extra " to fix syntax highlighting + PROCEDURE DIVISION. + DISPLAY "Hello, world!". + diff --git a/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.out b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.out new file mode 100644 index 0000000..297edb3 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Quote_marks_in_comment_paragraphs.out @@ -0,0 +1,2 @@ +Hello, world! + diff --git a/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.cob b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.cob new file mode 100644 index 0000000..2367ad5 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.cob @@ -0,0 +1,38 @@ + *> { dg-do run } + *> { dg-output-file "group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 TSRDF. + 05 WS-ASK-ID-DATE PIC X(10). + 05 WS-ASK-ID-DATE-R REDEFINES WS-ASK-ID-DATE. + 10 WS-ASK-ID-DATE-YYYY PIC 9(4) VALUE 2017. + 10 FILLER PIC X VALUE '-'. + 10 WS-ASK-ID-DATE-MM PIC 9(2). + 10 FILLER PIC X VALUE '-'. + 10 WS-ASK-ID-DATE-DD PIC 9(2). + PROCEDURE DIVISION. + MOVE ALL '*' TO WS-ASK-ID-DATE + MOVE 2015 TO WS-ASK-ID-DATE-YYYY + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " Compiled". + + INITIALIZE WS-ASK-ID-DATE-R. + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " INITIALIZE". + + INITIALIZE WS-ASK-ID-DATE-R WITH FILLER. + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " WITH FILLER". + + INITIALIZE WS-ASK-ID-DATE-R WITH FILLER ALL TO VALUE. + MOVE 08 TO WS-ASK-ID-DATE-MM + MOVE 21 TO WS-ASK-ID-DATE-DD + DISPLAY "The date is " WS-ASK-ID-DATE " ALL TO VALUE". + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out new file mode 100644 index 0000000..6a24172 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/REDEFINES_values_on_FILLER_and_INITIALIZE.out @@ -0,0 +1,5 @@ +The date is 2015*08*21 Compiled +The date is 0000*08*21 INITIALIZE +The date is 0000 08 21 WITH FILLER +The date is 2017-08-21 ALL TO VALUE + diff --git a/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.cob b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.cob new file mode 100644 index 0000000..3eb0685 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.cob @@ -0,0 +1,22 @@ + *> { dg-do run } + *> { dg-output-file "group2/Recursive_PERFORM_paragraph.out" } + identification division. + program-id. prog. + data division. + working-storage section. + 77 n binary-double unsigned. + 77 f binary-double unsigned. + procedure division. + move 20 to n + move 1 to f + display "compute " n " factorial". + fact. + compute f = f * n + subtract 1 from n + if n not equal to zero then + perform fact + end-if. + end-fact. + display f. + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.out b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.out new file mode 100644 index 0000000..97f0737 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Recursive_PERFORM_paragraph.out @@ -0,0 +1,3 @@ +compute 0000000000000000020 factorial +2432902008176640000 + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__1_.cob b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__1_.cob new file mode 100644 index 0000000..9bf4892 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__1_.cob @@ -0,0 +1,29 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + SPECIAL-NAMES. + ALPHABET ALPHA IS EBCDIC. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC X(10) VALUE "d4b2e1a3c5". + 01 G. + 02 TBL OCCURS 10. + 03 X PIC X. + PROCEDURE DIVISION. + MOVE Z TO G. + SORT TBL ASCENDING KEY X SEQUENCE ALPHA. + IF G NOT = "abcde12345" + DISPLAY G + END-DISPLAY + END-IF. + MOVE Z TO G. + SORT TBL DESCENDING KEY X SEQUENCE ALPHA. + IF G NOT = "54321edcba" + DISPLAY G + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__2_.cob b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__2_.cob new file mode 100644 index 0000000..2a10d2d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__EBCDIC_table_sort__2_.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + CONFIGURATION SECTION. + OBJECT-COMPUTER. + x86 PROGRAM COLLATING SEQUENCE IS EBCDIC-CODE. + SPECIAL-NAMES. + ALPHABET EBCDIC-CODE IS EBCDIC. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 Z PIC X(10) VALUE "d4b2e1a3c5". + 01 G. + 02 TBL OCCURS 10. + 03 X PIC X. + PROCEDURE DIVISION. + MOVE Z TO G. + SORT TBL ASCENDING KEY X. + IF G NOT = "abcde12345" + DISPLAY G. + MOVE Z TO G. + SORT TBL DESCENDING KEY X. + IF G NOT = "54321edcba" + DISPLAY G. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort.cob new file mode 100644 index 0000000..52fc973 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort.cob @@ -0,0 +1,33 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G VALUE "d4b2e1a3c5". + 02 TBL OCCURS 5. + 03 X PIC X. + 03 Y PIC 9. + PROCEDURE DIVISION. + SORT TBL ASCENDING KEY X. + IF G NOT = "a3b2c5d4e1" + DISPLAY G + END-DISPLAY + END-IF. + SORT TBL DESCENDING KEY Y. + IF G NOT = "c5d4a3b2e1" + DISPLAY G + END-DISPLAY + END-IF. + SORT TBL ASCENDING KEY TBL. + IF G NOT = "a3b2c5d4e1" + DISPLAY G + END-DISPLAY + END-IF. + SORT TBL DESCENDING KEY. + IF G NOT = "e1d4c5b2a3" + DISPLAY G + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.cob new file mode 100644 index 0000000..d30b4ea --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.cob @@ -0,0 +1,96 @@ + *> { dg-do run } + *> { dg-output-file "group2/SORT__table_sort__2_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 K PIC 9(2). + + 01 CNT1 PIC 9(9) COMP-5 VALUE 4. + 01 TAB1. + 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 + DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99. + + 01 TAB2. + 05 CNT2 PIC 9(9) COMP-5 VALUE 4. + 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT2 + DESCENDING TAB2-NR. + 10 TAB2-NR PIC 99. + + 01 TAB3. + 05 CNT3 PIC 9(9) COMP-5 VALUE 10. + 05 ROW3 OCCURS 1 TO 10 DEPENDING CNT3 + DESCENDING TAB3-NR + ASCENDING TAB3-DATA. + 10 TAB3-NR PIC 99. + 10 FILLER PIC X(2). + 10 TAB3-DATA PIC X(5). + 10 FILLER PIC X(2). + 10 TAB3-DATA2 PIC X(5). + + + PROCEDURE DIVISION. + A. + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + MOVE K TO TAB1-NR(K), TAB2-NR(K) + END-PERFORM + + MOVE 1 TO TAB3-NR(1). + MOVE 1 TO TAB3-NR(8). + MOVE 1 TO TAB3-NR(4). + MOVE 6 TO TAB3-NR(2). + MOVE 5 TO TAB3-NR(3). + MOVE 5 TO TAB3-NR(9). + MOVE 2 TO TAB3-NR(5). + MOVE 2 TO TAB3-NR(10). + MOVE 4 TO TAB3-NR(6). + MOVE 3 TO TAB3-NR(7). + + MOVE "abcde" TO TAB3-DATA(1). + MOVE "AbCde" TO TAB3-DATA(2). + MOVE "abcde" TO TAB3-DATA(3). + MOVE "zyx" TO TAB3-DATA(4). + MOVE "12345" TO TAB3-DATA(5). + MOVE "zyx" TO TAB3-DATA(6). + MOVE "abcde" TO TAB3-DATA(7). + MOVE "AbCde" TO TAB3-DATA(8). + MOVE "abc" TO TAB3-DATA(9). + MOVE "12346" TO TAB3-DATA(10). + + MOVE "day" TO TAB3-DATA2(1). + MOVE "The" TO TAB3-DATA2(2). + MOVE "eats" TO TAB3-DATA2(3). + MOVE "." TO TAB3-DATA2(4). + MOVE "mooos" TO TAB3-DATA2(5). + MOVE "grass" TO TAB3-DATA2(6). + MOVE "and" TO TAB3-DATA2(7). + MOVE "whole" TO TAB3-DATA2(8). + MOVE "cow" TO TAB3-DATA2(9). + MOVE "the" TO TAB3-DATA2(10). + + SORT ROW1 DESCENDING TAB1-NR + SORT ROW2 DESCENDING TAB2-NR + + DISPLAY "SINGLE TABLE" END-DISPLAY + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR(K) END-DISPLAY + END-PERFORM + + DISPLAY "LOWER LEVEL TABLE" END-DISPLAY + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB2-NR(K) END-DISPLAY + END-PERFORM + + SORT ROW3 DESCENDING TAB3-NR ASCENDING TAB3-DATA + + DISPLAY "MULTY KEY SORT" END-DISPLAY + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 10 + DISPLAY FUNCTION TRIM(ROW3(K)) + END-DISPLAY + END-PERFORM + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.out b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.out new file mode 100644 index 0000000..5866ecf --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__2_.out @@ -0,0 +1,22 @@ +SINGLE TABLE +04 +03 +02 +01 +LOWER LEVEL TABLE +04 +03 +02 +01 +MULTY KEY SORT +06 AbCde The +05 abc cow +05 abcde eats +04 zyx grass +03 abcde and +02 12345 mooos +02 12346 the +01 AbCde whole +01 abcde day +01 zyx . + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.cob new file mode 100644 index 0000000..660f93c --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.cob @@ -0,0 +1,48 @@ + *> { dg-do run } + *> { dg-output-file "group2/SORT__table_sort__3A_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 K PIC 9(2). + + 01 CNT1 PIC 9(9) COMP-5 VALUE 4. + 01 TAB1. + 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 + DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99. + 10 TAB-DATA PIC X(5). + 01 TAB2. + 05 ROW2 OCCURS 1 TO 4 DEPENDING CNT1 + ASCENDING ROW2. + 10 TAB2-NR PIC 99. + 10 TAB2-DATA PIC X(5). + + PROCEDURE DIVISION. + A. + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + MOVE K TO TAB1-NR (K) + MOVE 'BLA' TO TAB-DATA(K) + END-PERFORM + + SORT ROW1 + + DISPLAY "After SORT [DESCENDING] ROW1" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + MOVE TAB1 TO TAB2 + SORT ROW2 + + DISPLAY "After SORT [ASCENDING] ROW2" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB2-NR(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.out b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.out new file mode 100644 index 0000000..29ea985 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3A_.out @@ -0,0 +1,5 @@ +After SORT [DESCENDING] ROW1 +04030201 +After SORT [ASCENDING] ROW2 +01020304 + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.cob b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.cob new file mode 100644 index 0000000..3afea83 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.cob @@ -0,0 +1,44 @@ + *> { dg-do run } + *> { dg-output-file "group2/SORT__table_sort__3B_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog2. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 K PIC 9(2). + + 01 CNT1 PIC 9(9) COMP-5 VALUE 4. + 01 TAB1. + 05 ROW1 OCCURS 5 DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99 VALUE ZERO. + 10 TAB-DATA PIC X(5). + 01 TAB2. + 05 ROW1 OCCURS 1 TO 4 DEPENDING CNT1 + DESCENDING TAB1-NR. + 10 TAB1-NR PIC 99. + 10 TAB-DATA PIC X(5). + + PROCEDURE DIVISION. + A. + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + MOVE K TO TAB1-NR OF TAB2(K) + MOVE 'BLA' TO TAB-DATA OF TAB2(K) + END-PERFORM + + DISPLAY "Before sort" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR OF TAB2(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + SORT ROW1 OF TAB2. + + DISPLAY "After descending sort" + PERFORM VARYING K FROM 1 BY 1 UNTIL K > 4 + DISPLAY TAB1-NR OF TAB2(K) NO ADVANCING END-DISPLAY + END-PERFORM + DISPLAY "" + + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.out b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.out new file mode 100644 index 0000000..4721770 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SORT__table_sort__3B_.out @@ -0,0 +1,5 @@ +Before sort +01020304 +After descending sort +04030201 + diff --git a/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.cob b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.cob new file mode 100644 index 0000000..29b266e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.cob @@ -0,0 +1,27 @@ + *> { dg-do run } + *> { dg-output-file "group2/SOURCE_FIXED_FREE_directives.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + >>SOURCE FREE + DATA DIVISION. + WORKING-STORAGE SECTION. + >>SOURCE FIXED + PROCEDURE DIVISION. FIXED + DISPLAY "OK" NO ADVANCING + END-DISPLAY. + >>SOURCE FREE + DISPLAY + "OK" + NO ADVANCING + END-DISPLAY. + >>SOURCE FORMAT FIXED + DISPLAY "OK" NO ADVANCING FIXED + END-DISPLAY. + >>SOURCE FORMAT IS FREE + DISPLAY + "OK" + NO ADVANCING + END-DISPLAY. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.out b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.out new file mode 100644 index 0000000..ed898e2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/SOURCE_FIXED_FREE_directives.out @@ -0,0 +1 @@ +OKOKOKOK diff --git a/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_ERROR_STATUS.cob b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_ERROR_STATUS.cob new file mode 100644 index 0000000..c5f8fe7 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_ERROR_STATUS.cob @@ -0,0 +1,10 @@ + *> { dg-do run } + *> { dg-xfail-run-if "" { *-*-* } } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + STOP RUN WITH ERROR STATUS. + diff --git a/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_NORMAL_STATUS.cob b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_NORMAL_STATUS.cob new file mode 100644 index 0000000..9950a77 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STOP_RUN_WITH_NORMAL_STATUS.cob @@ -0,0 +1,9 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + PROCEDURE DIVISION. + STOP RUN WITH NORMAL STATUS. + diff --git a/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.cob b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.cob new file mode 100644 index 0000000..8397189 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.cob @@ -0,0 +1,104 @@ + *> { dg-do run } + *> { dg-output-file "group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out" } + + identification division. + program-id. prog. + data division. + working-storage section. + 77 simple-str pic x(20). + 77 err-str pic x(50). + *----------------------------------------------------------------- + procedure division. + * STRING test + move spaces to simple-str + string 'data' + delimited by size + into simple-str + on overflow + move spaces to err-str + string 'STRING OVERFLOW' + delimited by size + into err-str + end-string + display err-str upon syserr + end-display + display '1 failed' + end-display + not on overflow + display '1 passed' + end-display + end-string + if simple-str not = 'data' + display 'STRING ERROR (1): "' simple-str '"' + end-display + end-if + * + move spaces to simple-str + string 'data is too big here...' + delimited by size + into simple-str + on overflow + display '2 passed' + end-display + not on overflow + display '2 failed' + end-display + move spaces to err-str + string 'missing OVERFLOW' + delimited by size + into err-str + end-string + display err-str upon syserr + end-display + end-string + if simple-str not = 'data is too big here' + display 'STRING ERROR (2): "' simple-str '"' + end-display + end-if + * + * UNSTRING test + move spaces to simple-str + unstring 'data' + into simple-str + on overflow + move spaces to err-str + unstring 'UNSTRING OVERFLOW' + into err-str + end-unstring + display err-str upon syserr + end-display + display '3 failed' + end-display + not on overflow + display '3 passed' + end-display + end-unstring + if simple-str not = 'data' + display 'UNSTRING ERROR (1): "' simple-str '"' + end-display + end-if + * + move spaces to simple-str + unstring 'data is too big here...' + into simple-str + on overflow + display '4 passed' + end-display + not on overflow + display '4 failed' + end-display + move spaces to err-str + string 'missing OVERFLOW' + delimited by size + into err-str + end-string + display err-str upon syserr + end-display + end-unstring + if simple-str not = 'data is too big here' + display 'UNSTRING ERROR (2): "' simple-str '"' + end-display + end-if + * + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out new file mode 100644 index 0000000..f819dc4 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STRING___UNSTRING__NOT__ON_OVERFLOW.out @@ -0,0 +1,5 @@ +1 passed +2 passed +3 passed +4 passed + diff --git a/gcc/testsuite/cobol.dg/group2/STRING_with_subscript_reference.cob b/gcc/testsuite/cobol.dg/group2/STRING_with_subscript_reference.cob new file mode 100644 index 0000000..66a5477 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/STRING_with_subscript_reference.cob @@ -0,0 +1,18 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 02 X PIC X(3) OCCURS 3. + PROCEDURE DIVISION. + MOVE SPACES TO G. + STRING "abc" INTO X(2) + END-STRING. + IF G NOT = " abc " + DISPLAY X(1) NO ADVANCING + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.cob b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.cob new file mode 100644 index 0000000..fa43889 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.cob @@ -0,0 +1,20 @@ + *> { dg-do run } + *> { dg-options "-fno-static-call -rdynamic" } + *> { dg-output-file "group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. caller. + PROCEDURE DIVISION. + CALL "callee1" ON EXCEPTION + CALL "callee2" ON EXCEPTION + DISPLAY "neither callee1 nor callee2 found" + END-CALL + END-CALL + GOBACK. + END PROGRAM caller. + IDENTIFICATION DIVISION. + PROGRAM-ID. callee2. + PROCEDURE DIVISION. + DISPLAY "this is callee2" NO ADVANCING + GOBACK. + diff --git a/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out new file mode 100644 index 0000000..4f18f54 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/Static_CALL_with_ON_EXCEPTION__with_-fno-static-call_.out @@ -0,0 +1 @@ +this is callee2 diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_LOW-VALUE.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_LOW-VALUE.cob new file mode 100644 index 0000000..495feef --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_LOW-VALUE.cob @@ -0,0 +1,26 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 G. + 03 FILLER PIC XXX VALUE "ABC". + 03 FILLER PIC XX VALUE LOW-VALUE. + 03 FILLER PIC XXX VALUE "DEF". + 01 A PIC XXX. + 01 B PIC XXX. + PROCEDURE DIVISION. + UNSTRING G DELIMITED BY ALL LOW-VALUE + INTO A B + END-UNSTRING. + IF A NOT = "ABC" + DISPLAY "A is " """" A """" + END-DISPLAY + END-IF. + IF B NOT = "DEF" + DISPLAY "B is " """" B """" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_SPACE-2.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_SPACE-2.cob new file mode 100644 index 0000000..9bbbd8e --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_ALL_SPACE-2.cob @@ -0,0 +1,56 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-RECORD. + 02 VALUE SPACE PIC X(04). + 02 VALUE "ABC AND DE" PIC X(10). + 02 VALUE SPACE PIC X(07). + 02 VALUE "FG AND HIJ" PIC X(10). + 02 VALUE SPACE PIC X(08). + 01 SPACE-2 PIC X(02) VALUE SPACE. + 01 WS-DUMMY PIC X(15). + 01 WS-POINTER PIC 99. + PROCEDURE DIVISION. + MOVE 1 TO WS-POINTER. + * + PERFORM 0001-SUB. + IF WS-DUMMY NOT = SPACE + DISPLAY "Expected space - Got " WS-DUMMY + END-DISPLAY + END-IF. + IF WS-POINTER NOT = 5 + DISPLAY "Expected 5 - Got " WS-POINTER + END-DISPLAY + END-IF. + * + PERFORM 0001-SUB. + IF WS-DUMMY NOT = "ABC AND DE" + DISPLAY "Expected ABC AND DE - Got " WS-DUMMY + END-DISPLAY + END-IF. + IF WS-POINTER NOT = 21 + DISPLAY "Expected 21 - Got " WS-POINTER + END-DISPLAY + END-IF. + * + PERFORM 0001-SUB. + IF WS-DUMMY NOT = " FG AND HIJ" + DISPLAY "Expected FG AND HIJ - Got " WS-DUMMY + END-DISPLAY + END-IF. + IF WS-POINTER NOT = 40 + DISPLAY "Expected 40 - Got " WS-POINTER + END-DISPLAY + END-IF. + STOP RUN. + 0001-SUB. + UNSTRING WS-RECORD + DELIMITED BY ALL SPACE-2 + INTO WS-DUMMY + POINTER WS-POINTER + END-UNSTRING. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_POINTER.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_POINTER.cob new file mode 100644 index 0000000..5d3fdf2 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITED_POINTER.cob @@ -0,0 +1,45 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WS-LAY-RECORD PIC X(66). + 01 WS-DUMMY PIC X(50). + 01 WS-KEYWORD PIC X(32). + 01 WS-POINTER PIC 99. + PROCEDURE DIVISION. + MOVE + ' 10 AF-RECORD-TYPE-SEQUENCE-04 PIC 9(05) COMP-3.' + TO WS-LAY-RECORD. + MOVE 1 TO WS-POINTER. + PERFORM 0001-SUB. + IF WS-POINTER NOT = 48 + DISPLAY "Expected 48 - Got " WS-POINTER + END-DISPLAY + END-IF. + ADD 7 TO WS-POINTER + END-ADD. + PERFORM 0001-SUB. + IF WS-POINTER NOT = 62 + DISPLAY "Expected 62 - Got " WS-POINTER + END-DISPLAY + END-IF. + PERFORM 0001-SUB. + IF WS-POINTER NOT = 63 + DISPLAY "Expected 63 - Got " WS-POINTER + END-DISPLAY + END-IF. + STOP RUN. + 0001-SUB. + UNSTRING WS-LAY-RECORD + DELIMITED + BY ' PIC ' + OR ' COMP-3' + OR '.' + INTO WS-DUMMY + DELIMITER WS-KEYWORD + POINTER WS-POINTER + END-UNSTRING. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITER_IN.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITER_IN.cob new file mode 100644 index 0000000..714dba1 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_DELIMITER_IN.cob @@ -0,0 +1,35 @@ + *> { dg-do run } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + ENVIRONMENT DIVISION. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 WK-CMD PIC X(8) VALUE "WWADDBCC". + 01 WK-SIGNS PIC XX VALUE "AB". + 01 WKS REDEFINES WK-SIGNS. + 03 WK-SIGN PIC X OCCURS 2. + 01 . + 02 WK-DELIM PIC X OCCURS 2. + 01 . + 02 WK-DATA PIC X(2) OCCURS 3. + PROCEDURE DIVISION. + UNSTRING WK-CMD DELIMITED BY WK-SIGN(1) OR WK-SIGN(2) + INTO WK-DATA(1) DELIMITER IN WK-DELIM(1) + WK-DATA(2) DELIMITER IN WK-DELIM(2) + WK-DATA(3) + END-UNSTRING + IF WK-DATA(1) NOT = "WW" + OR WK-DATA(2) NOT = "DD" + OR WK-DATA(3) NOT = "CC" + OR WK-DELIM(1) NOT = "A" + OR WK-DELIM(2) NOT = "B" + DISPLAY """" WK-DATA(1) + WK-DATA(2) + WK-DATA(3) + WK-DELIM(1) + WK-DELIM(2) """" + END-DISPLAY + END-IF. + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.cob b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.cob new file mode 100644 index 0000000..f4c8032 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.cob @@ -0,0 +1,42 @@ + *> { dg-do run } + *> { dg-output-file "group2/UNSTRING_with_FUNCTION___literal.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + DATA DIVISION. + WORKING-STORAGE SECTION. + 01 FILLER. + 05 TSTUNS PIC X(479). + 05 PRM PIC X(16) OCCURS 4 TIMES. + PROCEDURE DIVISION. + MOVE "The,Quick,Brown,Fox" TO TSTUNS. + UNSTRING TSTUNS DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + UNSTRING FUNCTION UPPER-CASE(TSTUNS) DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "Now using UPPER-CASE" + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + UNSTRING "Daddy,was,a,Rolling stone" DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "Now using Literal" + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + UNSTRING FUNCTION LOWER-CASE("Daddy,was,a,Rolling stone") + DELIMITED BY ',' + INTO PRM(1), PRM(2), PRM(3), PRM(4). + DISPLAY "Now using Literal + LOWER-CASE" + DISPLAY "PRM(1) is " PRM(1) ":". + DISPLAY "PRM(2) is " PRM(2) ":". + DISPLAY "PRM(3) is " PRM(3) ":". + DISPLAY "PRM(4) is " PRM(4) ":". + STOP RUN. + diff --git a/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.out b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.out new file mode 100644 index 0000000..297f254 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/UNSTRING_with_FUNCTION___literal.out @@ -0,0 +1,20 @@ +PRM(1) is The : +PRM(2) is Quick : +PRM(3) is Brown : +PRM(4) is Fox : +Now using UPPER-CASE +PRM(1) is THE : +PRM(2) is QUICK : +PRM(3) is BROWN : +PRM(4) is FOX : +Now using Literal +PRM(1) is Daddy : +PRM(2) is was : +PRM(3) is a : +PRM(4) is Rolling stone : +Now using Literal + LOWER-CASE +PRM(1) is daddy : +PRM(2) is was : +PRM(3) is a : +PRM(4) is rolling stone : + diff --git a/gcc/testsuite/cobol.dg/group2/_-static__compilation.cob b/gcc/testsuite/cobol.dg/group2/_-static__compilation.cob new file mode 100644 index 0000000..7843d3d --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/_-static__compilation.cob @@ -0,0 +1,10 @@ + *> { dg-do run } + *> { dg-options "-static" } + *> { dg-output-file "group2/_-static__compilation.out" } + + IDENTIFICATION DIVISION. + PROGRAM-ID. prog. + PROCEDURE DIVISION. + DISPLAY "hello, world". + end program prog. + diff --git a/gcc/testsuite/cobol.dg/group2/_-static__compilation.out b/gcc/testsuite/cobol.dg/group2/_-static__compilation.out new file mode 100644 index 0000000..ae0e511 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/_-static__compilation.out @@ -0,0 +1,2 @@ +hello, world + diff --git a/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob new file mode 100644 index 0000000..5cf0446 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.cob @@ -0,0 +1,34 @@ + *> { dg-do run } + *> { dg-output-file "group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out" } + + identification division. + program-id. caller. + data division. + working-storage section. + 01 x pic x(4) value '9876'. + procedure division. + call 'callee' using x + end-call + call 'callee' using omitted + end-call + stop run. + end program caller. + + identification division. + program-id. callee. + data division. + working-storage section. + 01 py pointer. + linkage section. + 01 x. + 05 y pic x(4). + procedure division using optional x. + set py to address of x. + if py is not equal to zero + display y + else + display "parameter omitted" + end-if. + goback. + end program callee. + diff --git a/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out new file mode 100644 index 0000000..9e82a04 --- /dev/null +++ b/gcc/testsuite/cobol.dg/group2/access_to_OPTIONAL_LINKAGE_item_not_passed.out @@ -0,0 +1,3 @@ +9876 +parameter omitted + diff --git a/gcc/testsuite/gcc.dg/torture/pr120211-1.c b/gcc/testsuite/gcc.dg/torture/pr120211-1.c new file mode 100644 index 0000000..f9bc97c --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr120211-1.c @@ -0,0 +1,20 @@ +/* { dg-do compile } */ + +int a, b, d; +void e() { + do { + int f = 0; + while (1) { + int c = a; + for (; (c & 1) == 0; c = 1) + for (; c & 1;) + ; + if (a) + break; + f++; + } + b = f & 5; + if (b) + break; + } while (d++); +} diff --git a/gcc/testsuite/gcc.dg/tree-ssa/gen-vect-28.c b/gcc/testsuite/gcc.dg/tree-ssa/gen-vect-28.c index 5c0ea58..4b3ce4e 100644 --- a/gcc/testsuite/gcc.dg/tree-ssa/gen-vect-28.c +++ b/gcc/testsuite/gcc.dg/tree-ssa/gen-vect-28.c @@ -9,7 +9,8 @@ /* unaligned store. */ -int main_1 (int off) +int __attribute__((noipa)) +main_1 (int off) { int i; char ia[N+OFF]; diff --git a/gcc/testsuite/gcc.dg/vect/vect-early-break_135-pr120211.c b/gcc/testsuite/gcc.dg/vect/vect-early-break_135-pr120211.c new file mode 100644 index 0000000..664b60d --- /dev/null +++ b/gcc/testsuite/gcc.dg/vect/vect-early-break_135-pr120211.c @@ -0,0 +1,12 @@ +/* { dg-add-options vect_early_break } */ +/* { dg-additional-options "-O3 -fno-tree-copy-prop -fno-tree-dominator-opts -fno-tree-loop-ivcanon -fno-tree-pre -fno-code-hoisting" } */ + +int a, b[1]; +int main() { + int c = 0; + for (; c < 1; c++) { + while (a) + c++; + b[c] = 0; + } +} diff --git a/gcc/testsuite/gcc.target/i386/pr91446.c b/gcc/testsuite/gcc.target/i386/pr91446.c index 0243ca3..d129405 100644 --- a/gcc/testsuite/gcc.target/i386/pr91446.c +++ b/gcc/testsuite/gcc.target/i386/pr91446.c @@ -21,4 +21,4 @@ foo (unsigned long long width, unsigned long long height, bar (&t); } -/* { dg-final { scan-assembler-times "vmovdqa\[^\n\r\]*xmm\[0-9\]" 2 } } */ +/* { dg-final { scan-assembler-times "vmovdqa\[^\n\r\]*xmm\[0-9\]" 2 { xfail *-*-* } } } */ diff --git a/gcc/testsuite/gcc.target/i386/pr99881.c b/gcc/testsuite/gcc.target/i386/pr99881.c index 3e087eb..a1ec1d1b 100644 --- a/gcc/testsuite/gcc.target/i386/pr99881.c +++ b/gcc/testsuite/gcc.target/i386/pr99881.c @@ -1,7 +1,7 @@ /* PR target/99881. */ /* { dg-do compile { target { ! ia32 } } } */ /* { dg-options "-Ofast -march=skylake" } */ -/* { dg-final { scan-assembler-not "xmm\[0-9\]" { xfail *-*-* } } } */ +/* { dg-final { scan-assembler-not "xmm\[0-9\]" } } */ void foo (int* __restrict a, int n, int c) diff --git a/gcc/testsuite/gcc.target/mips/pr54240.c b/gcc/testsuite/gcc.target/mips/pr54240.c index d3976f6..31b793b 100644 --- a/gcc/testsuite/gcc.target/mips/pr54240.c +++ b/gcc/testsuite/gcc.target/mips/pr54240.c @@ -27,4 +27,4 @@ NOMIPS16 int foo(S *s) return next->v; } -/* { dg-final { scan-tree-dump "Hoisting adjacent loads" "phiopt1" } } */ +/* { dg-final { scan-tree-dump "Hoisting adjacent loads" "phiopt2" } } */ diff --git a/gcc/testsuite/gcc.target/riscv/arch-52.c b/gcc/testsuite/gcc.target/riscv/arch-52.c index da6aea8..6133370 100644 --- a/gcc/testsuite/gcc.target/riscv/arch-52.c +++ b/gcc/testsuite/gcc.target/riscv/arch-52.c @@ -1,6 +1,6 @@ /* { dg-do compile } */ /* { dg-options "-march=rva22u64v -mabi=lp64" } */ -/* { dg-warning "*Should use \"_\" to contact Profiles with other extensions" } */ +/* { dg-warning "Should use \"_\" to contact Profiles with other extensions" "" { target *-*-* } 0 } */ int foo () {} diff --git a/gcc/testsuite/gfortran.dg/interface_61.f90 b/gcc/testsuite/gfortran.dg/interface_61.f90 new file mode 100644 index 0000000..15db3b8a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/interface_61.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options -Wexternal-argument-mismatch } +! PR fortran/120163 - this used to cause an error. +! Original test case by Bálint Aradi +module mod1 + implicit none + + abstract interface + pure subroutine callback_interface(a) + real, intent(in) :: a + end subroutine callback_interface + end interface + +contains + + subroutine caller(callback) + procedure(callback_interface) :: callback + real :: a + call callback(a) + end subroutine caller + +end module mod1 + + +module mod2 + use mod1 +end module mod2 diff --git a/gcc/testsuite/lib/target-supports.exp b/gcc/testsuite/lib/target-supports.exp index 287e51b..24d0b3d 100644 --- a/gcc/testsuite/lib/target-supports.exp +++ b/gcc/testsuite/lib/target-supports.exp @@ -10145,6 +10145,7 @@ proc check_effective_target_sync_int_long { } { || ([istarget arc*-*-*] && [check_effective_target_arc_atomic]) || [check_effective_target_mips_llsc] || [istarget nvptx*-*-*] + || ([istarget xtensa*-*-*] && [check_effective_target_xtensa_atomic]) }}] } @@ -10182,7 +10183,9 @@ proc check_effective_target_sync_char_short { } { || ([istarget riscv*-*-*] && ([check_effective_target_riscv_zalrsc] || [check_effective_target_riscv_zabha])) - || [check_effective_target_mips_llsc] }}] + || [check_effective_target_mips_llsc] + || ([istarget xtensa*-*-*] && [check_effective_target_xtensa_atomic]) + }}] } # Return 1 if thread_fence does not rely on __sync_synchronize @@ -14407,3 +14410,12 @@ proc check_effective_target_speculation_barrier_defined { } { } }] } + +# Return 1 if this is a compiler supporting Xtensa atomic operations +proc check_effective_target_xtensa_atomic { } { + return [check_no_compiler_messages xtensa_atomic assembly { + #if __XCHAL_HAVE_S32C1I != 1 && __XCHAL_HAVE_EXCLUSIVE != 1 + #error FOO + #endif + }] +} diff --git a/gcc/tree-vect-stmts.cc b/gcc/tree-vect-stmts.cc index efe6a2c..bd390b2 100644 --- a/gcc/tree-vect-stmts.cc +++ b/gcc/tree-vect-stmts.cc @@ -424,6 +424,7 @@ vect_stmt_relevant_p (stmt_vec_info stmt_info, loop_vec_info loop_vinfo, alternate exit. */ if (LOOP_VINFO_EARLY_BREAKS (loop_vinfo) && is_a <gphi *> (stmt) + && gimple_bb (stmt) == LOOP_VINFO_LOOP (loop_vinfo)->header && ((! VECTORIZABLE_CYCLE_DEF (STMT_VINFO_DEF_TYPE (stmt_info)) && ! *live_p) || STMT_VINFO_DEF_TYPE (stmt_info) == vect_induction_def)) diff --git a/libgcobol/ChangeLog b/libgcobol/ChangeLog index fe41ffb..2eadc73 100644 --- a/libgcobol/ChangeLog +++ b/libgcobol/ChangeLog @@ -1,3 +1,9 @@ +2025-05-11 Robert Dubner <rdubner@symas.com> + + PR cobol/119377 + * common-defs.h: (struct cbl_declaratives_t): Change "bool global" to + "uint32_t global". + 2025-05-10 Robert Dubner <rdubner@symas.com> * common-defs.h (ec_cmp): Delete "getenv("match_declarative")" calls. diff --git a/libgcobol/common-defs.h b/libgcobol/common-defs.h index 026f377..e3471c5 100644 --- a/libgcobol/common-defs.h +++ b/libgcobol/common-defs.h @@ -458,11 +458,25 @@ struct cbl_enabled_exception_t { struct cbl_declarative_t { enum { files_max = 16 }; size_t section; // implies program - bool global; + uint32_t global; // See the note below ec_type_t type; uint32_t nfile, files[files_max]; cbl_file_mode_t mode; +/* The ::global member originally was "bool global". A bool, however, occupies + only one byte of storage. The structure, in turn, is constructed on + four-byte boundaries for members, so there were three padding bytes between + the single byte of global and the ::type member. + + When used to create a "blob", where the structure was treated as a stream + of bytes that were used to create a constructor for an array of bytes, + valgrind noticed that those three padding bytes were not initialized, and + generated the appropriate error message. This made it hard to find other + problems. + + Changing the declaration from "bool" to "uint32_t" seems to have eliminated + the valgrind error without affecting overall performance. */ + cbl_declarative_t( cbl_file_mode_t mode = file_mode_none_e ) : section(0), global(false) , type(ec_none_e) |