[gcc r17-2765] cobol: Consolidate parsing of Level 78 constants and ISO 01 constants.
"James K. Lowden via Gcc-cvs" <[email protected]>
| Newsgroups | gmane.comp.gcc.cvs |
|---|---|
| Message-ID | <[email protected]> |
https://gcc.gnu.org/g:7c68607a459ee9540c58e3d8eb6eff86c7d6f444 commit r17-2765-g7c68607a459ee9540c58e3d8eb6eff86c7d6f444 Author: James K. Lowden <[email protected]> Date: Tue Jul 28 17:35:55 2026 -0400 cobol: Consolidate parsing of Level 78 constants and ISO 01 constants. MF-defined Level 78 constants were handled "specially" and in some cases incorrectly. They are now treated as merely syntactically different. The logic for both is the same. gcc/cobol/ChangeLog: * parse.y: Remove value78 nonterminal, introduce level_constant nonterminal for all constants. Move validation to level_constant. Remove other special handling for Level 78. * scan_post.h (prelex): Correct Level 78/88 typo. Diff: --- gcc/cobol/parse.y | 114 ++++++++++++++------------------------------------ gcc/cobol/scan_post.h | 2 +- 2 files changed, 32 insertions(+), 84 deletions(-) diff --git a/gcc/cobol/parse.y b/gcc/cobol/parse.y index e25275d2242d..b95a5e2e8fcd 100644 --- a/gcc/cobol/parse.y +++ b/gcc/cobol/parse.y @@ -754,7 +754,6 @@ class locale_tgt_t { %type <log_expr_t> log_expr rel_abbrs eval_abbrs %type <rel_term_t> rel_term rel_term1 -%type <field_data> value78 %type <field> literal name nume typename %type <field> num_constant num_literal signed_literal @@ -765,7 +764,7 @@ class locale_tgt_t { %type <refer> eval_subject1 %type <vargs> vargs disp_vargs trim_expr -%type <field> level_name +%type <field> level_name level_constant %type <number> fd_name %type <string> picture_sym name66 paragraph_name %type <literal> literalism @@ -3998,6 +3997,8 @@ level_name: LEVEL ctx_name case 77: case 88: break; + case 78: + break; default: if( 1 <= $LEVEL && $LEVEL <= 49 ) break; error_msg(@LEVEL, "LEVEL %d not supported", $LEVEL); @@ -4020,6 +4021,9 @@ level_name: LEVEL ctx_name case 77: case 88: break; + case 78: + dialect_ok(@LEVEL, MfLevel78, "LEVEL 78"); + break; default: if( 1 <= $LEVEL && $LEVEL <= 49 ) break; error_msg(@LEVEL, "LEVEL %d not supported", $LEVEL); @@ -4037,6 +4041,28 @@ level_name: LEVEL ctx_name } ; +level_constant: level_name CONSTANT is_global as { + cbl_field_t& field = *$1; + if( field.level != 1 ) { + error_msg(@1, "%s must be an 01-level data item", field.name); + YYERROR; + } + field.attr |= constant_e; + if( $is_global ) field.attr |= global_e; + $$ = $1; + } + | LEVEL78[level] NAME[name] VALUE is { + dialect_ok(@level, MfLevel78, "LEVEL 78"); + struct cbl_field_t field = { FldInvalid, + uint32_t($level), + @level.first_line }; + namcpy(@name, field.name, $name); + field.attr |= constant_e; + $$ = field_add(@1, &field); + current_field($$); // make available for data_clauses + } + ; + data_descr: data_descr1 { $$ = current_field($1); // make available for occurs, etc. @@ -4063,37 +4089,6 @@ const_value: cce_expr } ; -value78: literalism - { - cbl_field_data_t data; - data.capacity( capacity_cast(strlen($1.data)) ); - data.original($1.data); - $$.encoding = $1.encoding; - $$.data = new cbl_field_data_t(data); - } - | const_value - { - cbl_field_data_t data; - data = build_real (float128_type_node, $1.r); - auto s = $1.s ? $1.s : reinterpret_cast<char*>(data.etc.value); - data.original(s); - $$.encoding = no_encoding_e; - $$.data = new cbl_field_data_t(data); - } - | reserved_value[value] - { - const auto figconst = constant_of(constant_index($value)); - $$.encoding = current_encoding('A'); - $$.data = new cbl_field_data_t(figconst->data); - } - - | true_false - { - cbl_unimplemented("Boolean constant"); - YYERROR; - } - ; - data_descr1: level_name { assert($1 == current_field()); @@ -4102,16 +4097,9 @@ data_descr1: level_name } } - | level_name CONSTANT is_global as const_value[cce] + | level_constant const_value[cce] { cbl_field_t& field = *$1; - if( field.level != 1 ) { - error_msg(@1, "%s must be an 01-level data item", field.name); - YYERROR; - } - - field.attr |= constant_e; - if( $is_global ) field.attr |= global_e; field.type = FldLiteralN; field.data = build_real (float128_type_node, $cce.r); const char *s = $cce.s? $cce.s : string_of($cce.r); @@ -4125,15 +4113,9 @@ data_descr1: level_name } } - | level_name CONSTANT is_global as reserved_value[value] + | level_constant reserved_value[value] { cbl_field_t& field = *$1; - if( field.level != 1 ) { - error_msg(@1, "%s must be an 01-level data item", field.name); - YYERROR; - } - field.attr |= constant_e; - if( $is_global ) field.attr |= global_e; field.type = FldLiteralA; auto fig = constant_of(constant_index($value)); field.data = fig->data; @@ -4141,11 +4123,9 @@ data_descr1: level_name field.set_initial(@value); } - | level_name CONSTANT is_global as literalism[lit] + | level_constant literalism[lit] { cbl_field_t& field = *$1; - field.attr |= constant_e; - if( $is_global ) field.attr |= global_e; field.type = FldLiteralA; field.attr |= literal_attr($lit.prefix); @@ -4156,10 +4136,6 @@ data_descr1: level_name field.data.original( $lit.data ); field.set_initial(@lit); - if( field.level != 1 ) { - error_msg(@lit, "%s must be an 01-level data item", field.name); - YYERROR; - } if( cdf_value(field.name) ) { cbl_message(@1, Par78CdfDefinedW, "%s was defined by CDF", field.name); @@ -4189,34 +4165,6 @@ data_descr1: level_name field.data = cdfval->number; } } - | LEVEL78 NAME[name] VALUE is value78[data] - { - dialect_ok(@1, MfLevel78, "LEVEL 78"); - cbl_field_t field = { FldLiteralA, constant_e, *$data.data, - 78, $name, @name.first_line }; - // cce reports no encoded initial value - if( $data.encoding == no_encoding_e ) { - field.type = FldLiteralN; - field.codeset.set(); - field.data.initial = string_of(field.data.value_of()); - if( cdf_value(field.name) ) { - cbl_message(@name, Par78CdfDefinedW, - "%s was defined by CDF", field.name); - } - } else{ - field.attr |= quoted_e; - field.codeset.set($data.encoding); - field.set_initial(@data); - if( cdf_value(field.name) ) { - cbl_message(@name, Par78CdfDefinedW, - "%s was defined by CDF", field.name); - } - } - - if( ($$ = field_add(@name, &field)) == NULL ) { - error_msg(@name, "failed level 78"); - } - } | LEVEL88 NAME /* VALUE */ NULLPTR { diff --git a/gcc/cobol/scan_post.h b/gcc/cobol/scan_post.h index 0ad0f95fcdb2..67a484ef80c6 100644 --- a/gcc/cobol/scan_post.h +++ b/gcc/cobol/scan_post.h @@ -421,7 +421,7 @@ prelex() { token = LEVEL78; break; case 88: - token = LEVEL78; + token = LEVEL88; break; } }